Fixed bug regarding relative URLs.

[tclrobot.git] / robot.tcl

diff --git a/robot.tcl b/robot.tcl
index 4a30d17..f6d7900 100755 (executable)
--- a/robot.tcl
+++ b/robot.tcl
@@ -1,5 +1,5 @@
 #!/usr/bin/tclsh 
-# $Id: robot.tcl,v 1.22 2001/10/30 08:29:54 adam Exp $
+# $Id: robot.tcl,v 1.26 2001/11/08 13:49:06 adam Exp $
 #
 proc RobotFileNext1 {area lead} {
     # puts "RobotFileNext1 area=$area lead=$lead"
@@ -324,7 +324,7 @@ proc RobotHref {url hrefx hostx pathx} {
     foreach c $surllist {
         switch -- $c {
            .. {
-               if {$pathl > 0} {
+               if {$pathl > 1} {
                    incr pathl -2
                    set path [lrange $path 0 $pathl]
                    incr pathl
@@ -339,10 +339,12 @@ proc RobotHref {url hrefx hostx pathx} {
            }
        }
     }
-    if {$pathl} {
-       set path [join $path /]
-    } else {
-       set path ""
+    if {$debuglevel > 4} {
+        puts "pathl=$pathl output path=$path"
+    }
+    set path [join $path /]
+    if {![string length $path]} {
+       set path /
     }
     regsub -all {~} $path {%7E} path
     set href "$method://$host$path"
@@ -441,8 +443,9 @@ proc RobotTextHtml {url out} {
             }
            puts $out {></meta>}
        } body {
-           regsub -all -nocase {<script([^<]|(<!.*>))*</script>} $body {} abody
-           regsub -all {<[^\>]+>} $abody {} nbody
+           regsub -all {<!--[^-]*->} $body { } abody
+           regsub -all -nocase {<script[^<]*</script>} $abody {} bbody
+           regsub -all {<[^\>]+>} $bbody {} nbody
            puts $out "<documentcontent>"
             puts $out $nbody
             puts $out "</documentcontent>"
@@ -597,19 +600,9 @@ proc RobotTextPlain {url out} {
     }
 }
 
-proc Robot200 {url} {
+proc RobotWriteMetadata {url out} {
     global URL domains
-    
-    set out [RobotFileOpen raw $URL($url,hostport) $URL($url,path)]
-    puts -nonewline $out $URL($url,buf)
-    RobotFileClose $out
 
-    if {![checkrule mime $URL($url,head,content-type)]} {
-        RobotError $url mimedeny
-        return
-    }
-
-    set out [RobotFileOpen visited $URL($url,hostport) $URL($url,path)]
     puts $out "<zmbot>"
 
     set distance 1000
@@ -640,8 +633,23 @@ proc Robot200 {url} {
         }
     }
     puts $out "</zmbot>"
+}
+
+proc Robot200 {url} {
+    global URL domains
+    
+    set out [RobotFileOpen raw $URL($url,hostport) $URL($url,path)]
+    puts -nonewline $out $URL($url,buf)
+    RobotFileClose $out
+
+    if {![checkrule mime $URL($url,head,content-type)]} {
+        RobotError $url mimedeny
+        return
+    }
+    set out [RobotFileOpen visited $URL($url,hostport) $URL($url,path)]
+    RobotWriteMetadata $url $out
     RobotFileClose $out
-    # puts "Parsing done"
+
     RobotFileUnlink unvisited $URL($url,hostport) $URL($url,path)
 }
 
@@ -833,19 +841,10 @@ set robotSeq 0
 set workdir [pwd]
 set idletime 60000
 set acceptLanguage {}
+set debuglevel 0
 
-set i 0
-set l [llength $argv]
-
-if {$l < 2} {
-    puts {tclrobot: usage:}
-    puts {tclrobot [-j jobs] [-i idle] [-c count] [-d domain] [-r rules] [url ..]}
-    puts " Example: -c 3 -d '*.dk' http://www.indexdata.dk/"
-    exit 1
-}
 
 # Rules: allow, deny, url
-set debuglevel 0
 
 proc checkrule {type this} {
     global alrules
@@ -862,17 +861,28 @@ proc checkrule {type this} {
             # consider type
             if {[lindex $l 1] != $type} continue
             # consider mask (! negates)
-            set mask [lindex $l 2]
-            if {[string index $mask 0] == "!"} {
-                set mask [string range $mask 1 end]
-                if {[string match $mask $this]} continue
-            } else {
-                if {![string match $mask $this]} continue
+            set masks [lindex $l 2]
+           set ok 0
+           foreach mask $masks {       
+                if {$debuglevel > 4} {
+                    puts "consider single mask $mask"
+                }
+                if {[string index $mask 0] == "!"} {
+                    set mask [string range $mask 1 end]
+                    if {[string match $mask $this]}  continue
+                } else {
+                    if {![string match $mask $this]} continue
+                }
+                set ok 1
+            }
+            if {$debuglevel > 4} {
+                puts "ok = $ok"
             }
+            if {!$ok} continue
             # OK, we have a match
             if {[lindex $l 0] == "allow"} {
                 if {$debuglevel > 3} {
-                    puts "CHECKRULE MATH OK"
+                    puts "CHECKRULE MATCH OK"
                 }
                 return 1
             } else {
@@ -884,7 +894,7 @@ proc checkrule {type this} {
         }
     }
     if {$debuglevel > 3} {
-        puts "CHECKRULE MATH OK"
+        puts "CHECKRULE MATCH OK"
     }
     return 1
 }
@@ -922,6 +932,16 @@ proc debug {level} {
 
 # Parse options
 
+set i 0
+set l [llength $argv]
+
+if {$l < 2} {
+    puts {tclrobot: usage:}
+    puts {tclrobot [-j jobs] [-i idle] [-c count] [-d domain] [-r rules] [url ..]}
+    puts " Example: -c 3 -d '*.dk' http://www.indexdata.dk/"
+
+    exit 1
+}
 while  {$i < $l} {
     set arg [lindex $argv $i]
     switch -glob -- $arg {
@@ -993,6 +1013,7 @@ puts "max jobs=$robotsMax"
 
 RobotStart
 
+
 while {$robotsRunning} {
     vwait robotsRunning
 }