------------------
He retocado el Spider y creo que ha mejorado un poco, si no en la respuesta, si en optimización de código.
Aún se pueden mejorar cosas como los sitios que ponen antes el CONTENT que el NAME en cuyo caso sigue sin devolver nada, y el problema de los acentos que se puede resolver usando el método ResponseBody de XMLHTTP en lugar de ResponseText y leyendo el retorno con Request.BinaryRead. Yo no dispongo de mucho más tiempo.
Quizá algún maestro...Los siguientes errores han sido arreglados:
1. Daba un error cuando no se encontraba la página. Ahora se detecta y te lo comunica.
2. Este otro bug consistía en que no daba error y no ocurría nada pero no devolvía ningún valor para el sitio encontrado. Este error era debido a que en las cadenas a buscar, por ejemplo "<meta name='description' content='" en muchos siitios, entre palabras dejaban más de un espacio y en consecuencia, no se encontraba. También se ha resuelto para una gran mayoría de los casos.
3. Este otro era igual que el anterior, pero en este caso, se daba porque hay sitios que en vez de estar escritos en HTML, están escritos en XHTML y los metas acaban en vez de en '> en espacio /> y al no encontrar etiqueta final devolvía mucha basura. Esto está solucionado.
El Spider retocado se puede descargar en http://www.laventanita.net/tutorial/spider.zip
No lo he dejado para probar poque si se hacen varias peticiones al mismo tiempo y algunas son fallidas el servidor se queda pillado. Es algo a tener muy en cuenta.
Mejor descargar el ejemplo que copiar el código de aquí, para que las sentencias y bucles no pierdan la sangría. Cuestión de ahorrase trabajo. No obstante os pongo el código y explico los cambios:
Sólo comentar que en este ejemplo elimino la página Default.asp y ahora Spider.asp muestra el formulario y realiza la búsqueda, con lo que todo queda en un página.
Igualmente el código que ha quedado es unas 8 veces menor.
Spider.asp
<%@ LANGUAGE="VBSCRIPT"%>
<%Option Explicit
Response.Expires = -1000
Response.Buffer = False%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>Spider</title>
Unos estilitos y así ya me servía para mi sitio. Sólo debeis cambiar estos 4 estilos y ya...
<style type="text/css">
body { font-size: 11px; font-family: Verdana }
.fPeq { font-size: 11px; font-family: Verdana }
.fBlan { font-size: 11px; font-family: Verdana; background-color: #FFFFFF; border: 1px solid #A5ACB2 }
.fCafe { font-size: 11px; font-family: Verdana; background-color: #F5E8D8; border: 1px solid #BD7B42 }
</style>
</head>
<body><%
Ahora sólo declaramos 6 variables...
Dim oXML, cURL, cConten, cKey, cDescrip, cTit
cURL = Request.Form("url")
If cURL <> "" Then
On Error Resume Next
Set oXML = Server.CreateObject("Microsoft.XMLHTTP")
oXML.open "GET", cURL, False
oXML.Send
Controlamos el error cuando el sitio no existe...
If Err.number <> 0 Then
Response.Write "Ha sido imposible encontrar el sitio. " & "[<a href='javascript:history.back()'>Volver</a>]"
Response.End
End If
If oXML.statusText = "OK" Then
cConten = oXML.ResponseText
Recogemos los metas. Las 147 líneas que se usaban para esto se quedan en sólo 3!! llamando a una pequeña función EncuentraCad() que se reutiliza para los 3 valores.
Para ello, dentro de esta función convertimos todo a minúsculas una sola vez para hacer la comparación pero los datos los extraemos de la cadena normal, respetando las mayúsculas que puedan tener, sobre todo el título y la descripción.
cTit = EncuentraCad(cConten, "<title>", "</title>")
cDescrip = EncuentraCad(cConten, "meta name='description' content='", ">")
ckey = EncuentraCad(cConten, "meta name='keywords' content='", ">")%>
Mostramos los datos en un formulario con sus respectivos inputs y así podemos copiar y pegar...
<form name="Mostrar">
<table width="700" border="0">
<tr>
<td class="fPeq"><b>URL</b></td>
<td><input class="fBlan" type="text" name="Url" size="100" value="<%=cURL%>" onfocus="this.className='fCafe'" onblur="this.className='fBlan'"></td>
</tr>
<tr>
<td class="fPeq"><b>Título</b></td>
<td><input class="fBlan" type="text" name="Titulo" size="100" value="<%=cTit%>" onfocus="this.className='fCafe'" onblur="this.className='fBlan'"></td>
</tr>
<tr>
<td class="fPeq"><b>Descripción</b></td>
<td><input class="fBlan" type="text" name="Descripcion" size="100" value="<%=cDescrip%>" onfocus="this.className='fCafe'" onblur="this.className='fBlan'"></td>
</tr>
<tr>
<td class="fPeq" valign="top"><b>Keywords</b></td>
<td><textarea class="fBlan" name="Keywords" cols="99" rows="5" onfocus="this.className='fCafe'" onblur="this.className='fBlan'"><%=cKey%></textarea></td>
</tr>
</table>
</form>
<hr class="fPeq"><%
Se controla de nuevo si no se encontró la página...
Else
Response.Write "Error obteniendo página. " & oXML.statustext & " [<a href='javascript:history.back()'>Volver</a>]"
End If
Set oXML = Nothing
End If%>
Formulario para la búsqueda...
<table width="450" border="0">
<tr><td>
<form name="form1" method="post" action="spider.asp">
<input class="fBlan" type="text" name="url" value="http://" size="45" onfocus="this.className='fCafe'" onblur="this.className='fBlan'">
<input class="fPeq" type="submit" name="Submit" value="Indexar">
</form>
</td></tr>
</table>
<br><br><a href="spider.zip">Descargar Spider (1,5 Kb)</a>
</body>
</html><%
'-------------------- FUNCIONES
Esta es la sencilla función que llamamos arriba y que parsea el texto...
Function EncuentraCad(cCad, cDesde, cHasta)
'Encuentra una subcadena entre dos subcadenas dadas
Dim cAct, cOri, nIni, nFin
cAct = Replace(cCad, " ", " ") 'Controlando dobles espacios... Originaba el error!!
cOri = Replace(cAct, Chr(34), "'") 'Original, respeta mayúsculas, dobles comillas por comillas simples...
cAct = LCase(Replace(cAct, Chr(34), "'")) 'Dobles comillas por comillas simples y pasando a minúsculas...
nIni = InStr(1, cAct, cDesde)
If nIni = 0 Then Exit Function
nIni = InStr(1, cAct, cDesde) + Len(cDesde)
nFin = InStr(nIni, cAct, cHasta) - nIni
EncuentraCad = SinFull(Mid(cOri, nIni, nFin))
End Function
Esta otra función se añade para quitar la barra, la contrabarra y la comilla simple final, si existiese, ya que para el código XHTML como cadena final sólo buscamos > y no '> como antes.
Lo único que hace son varios Replace() metiendo los valores a eliminar en un array o arreglo. Si se añaden más caracteres al array, no olvidar aumentar el contador i
Function SinFull(cCad)
'Devuelve una cadena sin guarrerías
Dim i, aCon
aCon = Array("/", "\", "'")
For i = 0 To 2
cCad = Replace(cCad, aCon(i), "")
Next
SinFull = Trim(cCad)
End Function%>
Fin Spider.asp
Espero les sirva, un saludote.
entre el código publicado aquí y el mio para eliminar los continuos replace que yo hacía. Pero no consigo que me funcione imprimiendo los resultados obtenidos en las cajas de texto pero sí me funciona si imprimo los resultados por pantalla con un simple response.write
Este tema le ha gustado a 1 personas