robot.tcl

   1 #!/usr/bin/tclsh
   2 # $Id: robot.tcl,v 1.28 2001/11/13 11:17:26 adam Exp $
   3 #
   4 proc RobotFileNext1 {area lead} {
   5     # puts "RobotFileNext1 area=$area lead=$lead"
   6     if {[catch {set ns [glob ${area}/*]}]} {
   7         return {}
   8     }
   9     foreach n $ns {
  10         if {[file isfile $n]} {
  11             set off [string last / $n]
  12             incr off 2
  13             return $lead/[string range $n $off end]
  14         }
  15     }
  16     foreach n $ns {
  17         if {[file isdirectory $n]} {
  18             set off [string last / $n]
  19             incr off 2
  20             set sb [RobotFileNext1 $n $lead/[string range $n $off end]]
  21             if {[string length $sb]} {
  22                 return $sb
  23             }
  24         }
  25     }
  26     return {}
  27 }
  28
  29 proc RobotWriteRecord {outf fromurl distance} {
  30     puts $outf "<zmbot>"
  31     puts $outf "<distance>"
  32     puts $outf $distance
  33     puts $outf "</distance>"
  34     puts $outf "<fromurl>"
  35     puts $outf $fromurl
  36     puts $outf "</fromurl>"
  37     puts $outf "</zmbot>"
  38 }
  39
  40 proc RobotReadRecord {inf fromurlx distancex} {
  41     upvar $fromurlx fromurl
  42     upvar $distancex distance
  43     gets $inf
  44     gets $inf
  45     set distance [string trim [gets $inf]]
  46     # puts "got distance = $distance"
  47     gets $inf
  48     gets $inf
  49     set fromurl [string trim [gets $inf]]
  50 }
  51
  52 proc RobotFileNext {area} {
  53     global robotSeq
  54     global idletime ns
  55     global status
  56
  57     # puts "RobotFileNext robotSeq=$robotSeq"
  58     if {$robotSeq < 0} {
  59         return {}
  60     }
  61     if {$robotSeq == 0} {
  62         if {[catch {set ns [glob ${area}/*]}]} {
  63             return {}
  64         }
  65     }
  66     set off [string length $area]
  67     incr off
  68     set n [lindex $ns $robotSeq]
  69     if {![string length $n]} {
  70         set robotSeq -1
  71         flush stdout
  72         puts "Round robin un,ba,vi=$status(unvisited),$status(bad),$status(visited)"
  73         return wait
  74     }
  75     incr robotSeq
  76     if {[file isfile $n/frobots.txt]} {
  77         puts "ok returning http://[string range $n $off end]/robots.txt"
  78         return http://[string range $n $off end]/robots.txt
  79     } elseif {[file isdirectory $n]} {
  80         set sb [RobotFileNext1 $n http://[string range $n $off end]]
  81         if {[string length $sb]} {
  82             return $sb
  83         }
  84     }
  85     puts "no more work at end of RobotFileNext n=$n"
  86     puts "ns=$ns"
  87     return {}
  88 }
  89
  90
  91 proc RobotFileExist {area host path} {
  92     # puts "RobotFileExist begin area=$area host=$host path=$path"
  93     set lpath [split $path /]
  94     set l [llength $lpath]
  95     incr l -1
  96     set t [lindex $lpath $l]
  97     incr l -1
  98     set npath $area/$host[join [lrange $lpath 0 $l] /d]/f$t
  99     # puts "RobotFileExist end npath=$npath"
 100     return [file exists $npath]
 101 }
 102
 103 proc RobotFileUnlink {area host path} {
 104     global status
 105     # puts "RobotFileUnlink begin"
 106     # puts "area=$area host=$host path=$path"
 107     set lpath [split $path /]
 108     set l [llength $lpath]
 109     incr l -1
 110     set t [lindex $lpath $l]
 111     incr l -1
 112     set npath $area/$host[join [lrange $lpath 0 $l] /d]/f$t
 113     # puts "npath=$npath"
 114     set comp [split $npath /]
 115     if {[catch {exec rm [join $comp /]}]} return
 116
 117     set l [llength $comp]
 118     incr l -1
 119     incr l -1
 120     incr status($area) -1
 121     for {set i $l} {$i > 0} {incr i -1} {
 122         set path [join [lrange $comp 0 $i] /]
 123         if {![catch {glob $path/*}]} return
 124         exec rmdir ./$path
 125     }
 126     # puts "RobotFileUnlink end"
 127 }
 128
 129 proc RobotFileClose {out} {
 130     if [string compare $out stdout] {
 131         close $out
 132     }
 133 }
 134
 135 proc RobotFileOpen {area host path {mode w}} {
 136     set orgPwd [pwd]
 137     global workdir
 138     global status
 139
 140     if {![info exists workdir]} {
 141         return stdout
 142     }
 143     #puts "RobotFileOpen orgPwd=$orgPwd area=$area host=$host path=$path mode=$mode"
 144     if {[string compare $orgPwd $workdir]} {
 145         puts "ooops. RobotFileOpen failed"
 146         puts "workdir = $workdir"
 147         puts "pwd = $orgPwd"
 148         exit 1
 149     }
 150     set comp [split $area/$host$path /]
 151     set len [llength $comp]
 152     incr len -1
 153     for {set i 0} {$i < $len} {incr i} {
 154         if {$i > 1} {
 155             set d "d[lindex $comp $i]"
 156         } else {
 157             set d [lindex $comp $i]
 158         }
 159         if {[catch {cd ./$d}]} {
 160             exec mkdir $d
 161             cd ./$d
 162             if {![string compare $area unvisited] && $i == 1 && $mode == "w"} {
 163                 set out [open frobots.txt w]
 164                 puts "creating robots.txt in $d"
 165                 close $out
 166                 incr status(unvisited)
 167             }
 168         }
 169     }
 170     set d [lindex $comp $len]
 171     if {[string length $d]} {
 172         if {[file isdirectory $d]} {
 173             set out [open $d/f $mode]
 174         } else {
 175             set out [open f$d $mode]
 176         }
 177     } else {
 178         set out [open f $mode]
 179     }
 180     if {$mode == "w"} {
 181         incr status($area)
 182     }
 183     cd $orgPwd
 184     return $out
 185 }
 186
 187 proc RobotRR {} {
 188     global robotSeq robotsRunning
 189
 190     incr robotsRunning -1
 191     while {$robotsRunning} {
 192         vwait robotsRunning
 193     }
 194     set robotSeq 0
 195     RobotStart
 196 }
 197
 198 proc RobotRestart {url sock} {
 199     global URL robotsRunning
 200
 201     close $sock
 202     after cancel $URL($sock,cancel)
 203
 204     foreach v [array names URL $url,*] {
 205         unset URL($v)
 206     }
 207
 208     incr robotsRunning -1
 209     RobotStart
 210 }
 211
 212 proc RobotStart {} {
 213     global URL
 214     global robotsRunning robotsMax idletime
 215
 216     # puts "RobotStart"
 217     while {1} {
 218         set url [RobotFileNext unvisited]
 219         if {![string length $url]} {
 220             return
 221         }
 222         incr robotsRunning
 223         if {[string compare $url wait] == 0} {
 224             after $idletime RobotRR
 225             return
 226         }
 227         set r [RobotGetUrl $url {}]
 228         if {!$r} {
 229             if {$robotsRunning >= $robotsMax} return
 230         } else {
 231             incr robotsRunning -1
 232             if {![RobotFileExist bad $URL($url,hostport) $URL($url,path)]} {
 233                 set outf [RobotFileOpen bad $URL($url,hostport) $URL($url,path)]
 234                 RobotFileClose $outf
 235             }
 236             RobotFileUnlink unvisited $URL($url,hostport) $URL($url,path)
 237         }
 238     }
 239 }
 240
 241 proc headSave {url out} {
 242     global URL
 243
 244     if {[info exists URL($url,head,last-modified)]} {
 245         puts $out "<lastmodified>$URL($url,head,last-modified)</lastmodified>"
 246     }
 247     puts $out {<si>}
 248     if {[info exists URL($url,head,date)]} {
 249         puts $out " <date>$URL($url,head,date)</date>"
 250     }
 251     if {[info exists URL($url,head,content-length)]} {
 252         puts $out " <by>$URL($url,head,content-length)</by>"
 253     }
 254     if {[info exists URL($url,head,server)]} {
 255         puts $out " <format>$URL($url,head,server)</format>"
 256     }
 257     puts $out {</si>}
 258     puts $out {<publisher>}
 259     puts $out " <identifier>$url</identifier>"
 260     if {[info exists URL($url,head,content-type)]} {
 261         puts $out " <type>$URL($url,head,content-type)</type>"
 262     }
 263     puts $out {</publisher>}
 264 }
 265
 266 proc RobotHref {url hrefx hostx pathx} {
 267     global URL domains debuglevel
 268     upvar $hrefx href
 269     upvar $hostx host
 270     upvar $pathx path
 271
 272     if {$debuglevel > 1} {
 273         puts "Ref input url = $url href=$href"
 274     }
 275
 276     if {[string first { } $href] >= 0} {
 277         return 0
 278     }
 279     if {[string length $href] > 256} {
 280         return 0
 281     }
 282     if {[string first {?} $href] >= 0} {
 283         return 0
 284     }
 285     if {[string first {?} $url] >= 0 && [string first {?} $href] >= 0} {
 286         return 0
 287     }
 288     # get method (if any)
 289     if {![regexp {^([^/:]+):(.*)} $href x method hpath]} {
 290         set hpath $href
 291         set method http
 292     } else {
 293         if {[string compare $method http]} {
 294             return 0
 295         }
 296     }
 297     # get host (if any)
 298     if {[regexp {^//([^/]+)([^\#]*)} $hpath x host surl]} {
 299         if {![string length $surl]} {
 300             set surl /
 301         }
 302         if {[info exist domains]} {
 303             set ok 0
 304             foreach domain $domains {
 305                 if {[string match $domain $host]} {
 306                     set ok 1
 307                     break
 308                  }
 309             }
 310             if {!$ok} {
 311                 return 0
 312             }
 313         }
 314     } else {
 315         regexp {^([^\#]*)} $hpath x surl
 316         set host $URL($url,hostport)
 317     }
 318     if {![string length $surl]} {
 319         return 0
 320     }
 321     if {[string first / $surl]} {
 322         # relative path
 323         regexp {^([^\#?]*)} $URL($url,path) x dpart
 324         set l [string last / $dpart]
 325         if {[expr $l >= 0]} {
 326             set surl [string range $dpart 0 $l]$surl
 327         } else {
 328             set surl $dpart/$surl
 329         }
 330     }
 331     set surllist [split $surl /]
 332     catch {unset path}
 333     set pathl 0
 334     foreach c $surllist {
 335         switch -- $c {
 336             .. {
 337                 if {$pathl > 1} {
 338                     incr pathl -2
 339                     set path [lrange $path 0 $pathl]
 340                     incr pathl
 341                 }
 342             }
 343             . {
 344
 345             }
 346             default {
 347                 incr pathl
 348                 lappend path $c
 349             }
 350         }
 351     }
 352     if {$debuglevel > 4} {
 353         puts "pathl=$pathl output path=$path"
 354     }
 355     set path [join $path /]
 356     if {![string length $path]} {
 357         set path /
 358     }
 359     regsub -all {~} $path {%7E} path
 360     set href "$method://$host$path"
 361
 362     if {$debuglevel > 1} {
 363         puts "Ref result = $href"
 364     }
 365     return [checkrule url $href]
 366 }
 367
 368 proc RobotError {url code} {
 369     global URL
 370
 371     puts "Bad URL $url (code $code)"
 372     set fromurl {}
 373     set distance -1
 374     if {[RobotFileExist unvisited $URL($url,hostport) $URL($url,path)]} {
 375         set inf [RobotFileOpen unvisited $URL($url,hostport) $URL($url,path) r]
 376         RobotReadRecord $inf fromurl distance
 377         RobotFileClose $inf
 378     }
 379     RobotFileUnlink unvisited $URL($url,hostport) $URL($url,path)
 380     if {![RobotFileExist bad $URL($url,hostport) $URL($url,path)]} {
 381         set outf [RobotFileOpen bad $URL($url,hostport) $URL($url,path)]
 382         RobotWriteRecord $outf $fromurl $distance
 383         RobotFileClose $outf
 384     }
 385 }
 386
 387 proc RobotRedirect {url tourl code} {
 388     global URL
 389
 390     puts "Redirecting from $url to $tourl"
 391
 392     set distance {}
 393     set fromurl {}
 394     if {[RobotFileExist unvisited $URL($url,hostport) $URL($url,path)]} {
 395         set inf [RobotFileOpen unvisited $URL($url,hostport) $URL($url,path) r]
 396         RobotReadRecord $inf fromurl distance
 397         RobotFileClose $inf
 398     }
 399     if {![RobotFileExist bad $URL($url,hostport) $URL($url,path)]} {
 400         set outf [RobotFileOpen bad $URL($url,hostport) $URL($url,path)]
 401         RobotWriteRecord $outf $fromurl $distance
 402         RobotFileClose $outf
 403     }
 404     if {[RobotHref $url tourl host path]} {
 405         if {![RobotFileExist visited $host $path]} {
 406             if {![RobotFileExist unvisited $host $path]} {
 407                 set outf [RobotFileOpen unvisited $host $path]
 408                 RobotWriteRecord $outf $fromurl $distance
 409                 RobotFileClose $outf
 410             }
 411         } else {
 412             set olddistance {}
 413             set inf [RobotFileOpen visited $host $path r]
 414             RobotReadRecord $inf oldurl olddistance
 415             RobotFileClose $inf
 416             if {[string length $olddistance] == 0} {
 417                 set olddistance 1000
 418             }
 419             if {[string length $distance] == 0} {
 420                 set distance 1000
 421             }
 422             puts "distance=$distance olddistance=$olddistance"
 423             if {[expr $distance < $olddistance]} {
 424                 set outf [RobotFileOpen unvisited $host $path]
 425                 RobotWriteRecord $outf $tourl $distance
 426                 RobotFileClose $outf
 427             }
 428         }
 429     }
 430     if {[catch {RobotFileUnlink unvisited $URL($url,hostport) $URL($url,path)}]} {
 431         puts "unlink failed"
 432         exit 1
 433     }
 434 }
 435
 436 proc RobotTextHtml {url out} {
 437     global URL maxdistance
 438
 439     set distance 0
 440     if {$maxdistance < 1000 && [info exists URL($url,dist)]} {
 441         set distance [expr $URL($url,dist) + 1]
 442     }
 443     htmlSwitch $URL($url,buf) \
 444         title {
 445             puts $out "<title>$body</title>"
 446         } -nonest meta {
 447             puts -nonewline $out "<meta"
 448             foreach a [array names parm] {
 449                 puts -nonewline $out " $a"
 450                 puts -nonewline $out {="}
 451                 puts -nonewline $out $parm($a)
 452                 puts -nonewline $out {"}
 453             }
 454             puts $out {></meta>}
 455         } body {
 456             regsub -all {<!--[^-]*->} $body { } abody
 457             regsub -all -nocase {<script[^<]*</script>} $abody {} bbody
 458             regsub -all {<[^\>]+>} $bbody {} nbody
 459             puts $out "<documentcontent>"
 460             puts $out $nbody
 461             puts $out "</documentcontent>"
 462         } -nonest a {
 463             if {![info exists parm(href)]} {
 464                 puts "no href"
 465                 continue
 466             }
 467             if {[expr $distance <= $maxdistance]} {
 468                 set href [string trim $parm(href)]
 469                 if {![RobotHref $url href host path]} continue
 470
 471                 puts $out "<cr>"
 472                 puts $out "<identifier>$href</identifier>"
 473                 puts $out "<description>$body</description>"
 474                 puts $out "</cr>"
 475
 476                 if {![RobotFileExist visited $host $path]} {
 477                     set olddistance 1000
 478                     if {![RobotFileExist bad $host $path]} {
 479                         if {[RobotFileExist unvisited $host $path]} {
 480                             set inf [RobotFileOpen unvisited $host $path r]
 481                             RobotReadRecord $inf oldurl olddistance
 482                             RobotFileClose $inf
 483                         }
 484                     } else {
 485                         set olddistance 0
 486                     }
 487                     if {[string length $olddistance] == 0} {
 488                         set olddistance 1000
 489                     }
 490                     if {[expr $distance < $olddistance]} {
 491                         set outf [RobotFileOpen unvisited $host $path]
 492                         RobotWriteRecord $outf $url $distance
 493                         RobotFileClose $outf
 494                     }
 495                 } elseif {[string compare $href $url]} {
 496                     set inf [RobotFileOpen visited $host $path r]
 497                     RobotReadRecord $inf xurl olddistance
 498                     close $inf
 499                     if {[string length $olddistance] == 0} {
 500                         set olddistance 1000
 501                     }
 502                     if {[expr $distance < $olddistance]} {
 503                         puts "OK remarking url=$url href=$href"
 504                         puts "olddistance = $olddistance"
 505                         puts "newdistance = $distance"
 506                         set outf [RobotFileOpen unvisited $host $path]
 507                         RobotWriteRecord $outf $url $distance
 508                         RobotFileClose $outf
 509                     }
 510                 }
 511             }
 512         } -nonest area {
 513             if {![info exists parm(href)]} {
 514                 puts "no href"
 515                 continue
 516             }
 517             if {[expr $distance <= $maxdistance]} {
 518                 set href [string trim $parm(href)]
 519                 if {![RobotHref $url href host path]} continue
 520
 521                 puts $out "<cr>"
 522                 puts $out "<identifier>$href</identifier>"
 523                 puts $out "<description></description>"
 524                 puts $out "</cr>"
 525
 526                 if {![RobotFileExist visited $host $path]} {
 527                     set olddistance 1000
 528                     if {![RobotFileExist bad $host $path]} {
 529                         if {[RobotFileExist unvisited $host $path]} {
 530                             set inf [RobotFileOpen unvisited $host $path r]
 531                             RobotReadRecord $inf oldurl olddistance
 532                             RobotFileClose $inf
 533                         }
 534                     } else {
 535                         set olddistance 0
 536                     }
 537                     if {[string length $olddistance] == 0} {
 538                         set olddistance 1000
 539                     }
 540                     if {[expr $distance < $olddistance]} {
 541                         set outf [RobotFileOpen unvisited $host $path]
 542                         RobotWriteRecord $outf $url $distance
 543                         RobotFileClose $outf
 544                     }
 545                 } elseif {[string compare $href $url]} {
 546                     set inf [RobotFileOpen visited $host $path r]
 547                     RobotReadRecord $inf xurl olddistance
 548                     close $inf
 549                     if {[string length $olddistance] == 0} {
 550                         set olddistance 1000
 551                     }
 552                     if {[expr $distance < $olddistance]} {
 553                         puts "OK remarking url=$url href=$href"
 554                         puts "olddistance = $olddistance"
 555                         puts "newdistance = $distance"
 556                         set outf [RobotFileOpen unvisited $host $path]
 557                         RobotWriteRecord $outf $url $distance
 558                         RobotFileClose $outf
 559                     }
 560                 }
 561             }
 562         } -nonest frame {
 563             if {![info exists parm(src)]} {
 564                 puts "no src"
 565                 continue
 566             }
 567             if {[expr $distance <= $maxdistance]} {
 568                 set href [string trim $parm(src)]
 569                 if {![RobotHref $url href host path]} continue
 570
 571                 puts $out "<cr>"
 572                 puts $out "<identifier>$href</identifier>"
 573                 puts $out "<description></description>"
 574                 puts $out "</cr>"
 575
 576                 if {![RobotFileExist visited $host $path]} {
 577                     set olddistance 1000
 578                     if {![RobotFileExist bad $host $path]} {
 579                         if {[RobotFileExist unvisited $host $path]} {
 580                             set inf [RobotFileOpen unvisited $host $path r]
 581                             RobotReadRecord $inf oldurl olddistance
 582                             RobotFileClose $inf
 583                         }
 584                     } else {
 585                         set olddistance 0
 586                     }
 587                     if {[string length $olddistance] == 0} {
 588                         set olddistance 1000
 589                     }
 590                     if {[expr $distance < $olddistance]} {
 591                         set outf [RobotFileOpen unvisited $host $path]
 592                         RobotWriteRecord $outf $url $distance
 593                         RobotFileClose $outf
 594                     }
 595                 } elseif {[string compare $href $url]} {
 596                     set inf [RobotFileOpen visited $host $path r]
 597                     RobotReadRecord $inf xurl olddistance
 598                     close $inf
 599                     if {[string length $olddistance] == 0} {
 600                         set olddistance 1000
 601                     }
 602                     if {[expr $distance < $olddistance]} {
 603                         puts "OK remarking url=$url href=$href"
 604                         puts "olddistance = $olddistance"
 605                         puts "newdistance = $distance"
 606                         set outf [RobotFileOpen unvisited $host $path]
 607                         RobotWriteRecord $outf $url $distance
 608                         RobotFileClose $outf
 609                     }
 610                 }
 611             }
 612         }
 613 }
 614
 615 proc RobotsTxt {url} {
 616     global agent URL
 617
 618     RobotsTxt0 URL(URL($url,hostport),robots) $URL($url,buf)
 619 }
 620
 621 proc RobotsTxt0 {v buf} {
 622     global URL agent
 623     set section 0
 624     foreach l [split $buf \n] {
 625         if {[regexp {([-A-Za-z]+):[ ]*([^\# ]+)} $l match cmd arg]} {
 626             puts "cmd=$cmd arg=$arg"
 627             switch -- [string tolower $cmd] {
 628                 user-agent {
 629                     if {$section} break
 630                     set pat [string tolower $arg]*
 631                     set section [string match $pat $agent]
 632                 }
 633                 disallow {
 634                     if {$section} {
 635                         puts "rule [list 0 $arg]"
 636                         lappend $v [list 0 $arg]
 637                     }
 638                 }
 639                 allow {
 640                     if {$section} {
 641                         puts "rule [list 1 $arg]"
 642                         lappend $v [list 1 $arg]
 643                     }
 644                 }
 645             }
 646         }
 647     }
 648 }
 649
 650 proc RobotTextPlain {url out} {
 651     global URL
 652
 653     puts $out "<documentcontent>"
 654     regsub -all {<} $URL($url,buf) {\&lt;} content
 655     puts $out $content
 656     puts $out "</documentcontent>"
 657
 658     if {![string compare $URL($url,path) /robots.txt]} {
 659         RobotsTxt $url
 660     }
 661 }
 662
 663 proc RobotWriteMetadata {url out} {
 664     global URL domains
 665
 666     puts $out "<zmbot>"
 667
 668     set distance 1000
 669     if {[RobotFileExist unvisited $URL($url,hostport) $URL($url,path)]} {
 670         set inf [RobotFileOpen unvisited $URL($url,hostport) $URL($url,path) r]
 671         RobotReadRecord $inf fromurl distance
 672         RobotFileClose $inf
 673     }
 674     set URL($url,dist) $distance
 675     puts $out "<distance>"
 676     puts $out "  $distance"
 677     puts $out "</distance>"
 678     headSave $url $out
 679     puts "Parsing $url distance=$distance"
 680     switch $URL($url,head,content-type) {
 681         text/html {
 682             if {[string length $distance]} {
 683                 RobotTextHtml $url $out
 684             }
 685         }
 686         text/plain {
 687             RobotTextPlain $url $out
 688         }
 689     }
 690     puts $out "</zmbot>"
 691 }
 692
 693 proc Robot200 {url} {
 694     global URL domains
 695
 696     set out [RobotFileOpen raw $URL($url,hostport) $URL($url,path)]
 697     puts -nonewline $out $URL($url,buf)
 698     RobotFileClose $out
 699
 700     set out [RobotFileOpen visited $URL($url,hostport) $URL($url,path)]
 701     RobotWriteMetadata $url $out
 702     RobotFileClose $out
 703
 704     RobotFileUnlink unvisited $URL($url,hostport) $URL($url,path)
 705 }
 706
 707 proc RobotReadContent {url sock binary} {
 708     global URL
 709
 710     set buffer [read $sock 16384]
 711     set readCount [string length $buffer]
 712
 713     if {$readCount <= 0} {
 714         Robot200 $url
 715         RobotRestart $url $sock
 716     } elseif {!$binary && [string first \0 $buffer] >= 0} {
 717         Robot200 $url
 718         RobotRestart $url $sock
 719     } else {
 720         # puts "Got $readCount bytes"
 721         set URL($url,buf) $URL($url,buf)$buffer
 722     }
 723 }
 724
 725 proc RobotReadHeader {url sock} {
 726     global URL debuglevel
 727
 728     if {$debuglevel > 1} {
 729         puts "HTTP head $url"
 730     }
 731     if {[catch {set buffer [read $sock 2148]}]} {
 732         RobotError $url 404
 733         RobotRestart $url $sock
 734         return
 735     }
 736     set readCount [string length $buffer]
 737
 738     if {$readCount <= 0} {
 739         RobotError $url 404
 740         RobotRestart $url $sock
 741     } else {
 742         # puts "Got $readCount bytes"
 743         set URL($url,buf) $URL($url,buf)$buffer
 744
 745         set n [string first \r\n\r\n $URL($url,buf)]
 746         if {$n > 1} {
 747             set code 0
 748             set version {}
 749             set headbuf [string range $URL($url,buf) 0 $n]
 750             incr n 4
 751             set URL($url,buf) [string range $URL($url,buf) $n end]
 752
 753             regexp {^HTTP/([0-9.]+)[ ]+([0-9]+)} $headbuf x version code
 754             set lines [split $headbuf \n]
 755             foreach line $lines {
 756                 if {[regexp {^([^:]+):[ ]+([^;]*)} $line x name value]} {
 757                     set URL($url,head,[string tolower $name]) [string trim $value]
 758                 }
 759             }
 760             puts "HTTP CODE $code"
 761             set URL($url,state) skip
 762             switch $code {
 763                 301 {
 764                     RobotRedirect $url $URL($url,head,location) 301
 765                     RobotRestart $url $sock
 766                 }
 767                 302 {
 768                     RobotRedirect $url $URL($url,head,location) 302
 769                     RobotRestart $url $sock
 770                 }
 771                 200 {
 772                     if {![info exists URL($url,head,content-type)]} {
 773                         set URL($url,head,content-type) {}
 774                     }
 775                     set binary 1
 776                     switch -glob -- $URL($url,head,content-type) {
 777                         text/* {
 778                             set binary 0
 779                         }
 780                     }
 781                     if {![regexp {/robots.txt$} $url]} {
 782                         if {![checkrule mime $URL($url,head,content-type)]} {
 783                             RobotError $url mimedeny
 784                             RobotRestart $url $sock
 785                             return
 786                         }
 787                     }
 788                     fileevent $sock readable [list RobotReadContent $url $sock $binary]
 789                 }
 790                 default {
 791                     RobotError $url $code
 792                     RobotRestart $url $sock
 793                 }
 794             }
 795         }
 796     }
 797 }
 798
 799 proc RobotSockCancel {url sock} {
 800
 801     puts "RobotSockCancel sock=$sock url=$url"
 802     RobotError $url 401
 803     RobotRestart $url $sock
 804 }
 805
 806 proc RobotConnect {url sock} {
 807     global URL agent acceptLanguage
 808
 809     fconfigure $sock -translation {lf crlf} -blocking 0
 810     fileevent $sock readable [list RobotReadHeader $url $sock]
 811     puts $sock "GET $URL($url,path) HTTP/1.0"
 812     puts $sock "Host: $URL($url,host)"
 813     puts $sock "User-Agent: $agent"
 814     if {[string length $acceptLanguage]} {
 815         puts $sock "Accept-Language: $acceptLanguage"
 816     }
 817     puts $sock ""
 818     flush $sock
 819     set URL($sock,cancel) [after 30000 [list RobotSockCancel $url $sock]]
 820 }
 821
 822 proc RobotNop {} {
 823
 824 }
 825
 826 proc RobotGetUrl {url phost} {
 827     global URL robotsRunning
 828     flush stdout
 829     puts "Retrieve $robotsRunning url=$url"
 830     if {![regexp {([^:]+)://([^/]+)(.*)} $url x method hostport path]} {
 831         return -1
 832     }
 833     if {![regexp {([^:]+):([0-9]+)} $hostport x host port]} {
 834         set port 80
 835         set host $hostport
 836     }
 837     set URL($url,method) $method
 838     set URL($url,host) $host
 839     set URL($url,hostport) $hostport
 840     set URL($url,path) $path
 841     set URL($url,state) head
 842     set URL($url,buf) {}
 843
 844     if {[string compare $path /robots.txt]} {
 845         set ok 1
 846         if {![info exists URL($hostport,robots)]} {
 847             puts "READING robots.txt for host $hostport"
 848             if {[RobotFileExist visited $hostport /robots.txt]} {
 849                 set inf [RobotFileOpen visited $hostport /robots.txt r]
 850                 set buf [read $inf 32768]
 851                 close $inf
 852             } else {
 853                 set buf "User-agent: *\nAllow: /\n"
 854             }
 855             RobotsTxt0 URL($hostport,robots) $buf
 856         }
 857         if {[info exists URL($hostport,robots)]} {
 858             foreach l $URL($hostport,robots) {
 859                 if {[string first [lindex $l 1] $path] == 0} {
 860                     set ok [lindex $l 0]
 861                     break
 862                 }
 863             }
 864         }
 865         if {!$ok} {
 866             puts "skipped due to robots.txt"
 867             return -1
 868         }
 869     }
 870     if [catch {set sock [socket -async $host $port]}] {
 871         return -1
 872     }
 873     RobotConnect $url $sock
 874
 875     return 0
 876 }
 877
 878 if {![llength [info commands htmlSwitch]]} {
 879     set e [info sharedlibextension]
 880     if {[catch {load ./tclrobot$e}]} {
 881         load tclrobot$e
 882     }
 883 }
 884
 885 set agent "zmbot/0.1"
 886 if {![catch {set os [exec uname -s -r]}]} {
 887     set agent "$agent ($os)"
 888 }
 889
 890 puts "agent: $agent"
 891
 892 proc bgerror {m} {
 893     global errorInfo
 894     puts "BGERROR $m"
 895     puts $errorInfo
 896 }
 897
 898 set robotsRunning 0
 899 set robotSeq 0
 900 set workdir [pwd]
 901 set idletime 60000
 902 set acceptLanguage {}
 903 set debuglevel 0
 904 set status(unvisited) 0
 905 set status(visited) 0
 906 set status(bad) 0
 907 set status(raw) 0
 908
 909
 910 # Rules: allow, deny, url
 911
 912 proc checkrule {type this} {
 913     global alrules
 914     global debuglevel
 915
 916     if {$debuglevel > 3} {
 917         puts "CHECKRULE $type $this"
 918     }
 919     if {[info exist alrules]} {
 920         foreach l $alrules {
 921             if {$debuglevel > 3} {
 922                 puts "consider $l"
 923             }
 924             # consider type
 925             if {[lindex $l 1] != $type} continue
 926             # consider mask (! negates)
 927             set masks [lindex $l 2]
 928             set ok 0
 929             foreach mask $masks {
 930                 if {$debuglevel > 4} {
 931                     puts "consider single mask $mask"
 932                 }
 933                 if {[string index $mask 0] == "!"} {
 934                     set mask [string range $mask 1 end]
 935                     if {[string match $mask $this]}  continue
 936                 } else {
 937                     if {![string match $mask $this]} continue
 938                 }
 939                 set ok 1
 940             }
 941             if {$debuglevel > 4} {
 942                 puts "ok = $ok"
 943             }
 944             if {!$ok} continue
 945             # OK, we have a match
 946             if {[lindex $l 0] == "allow"} {
 947                 if {$debuglevel > 3} {
 948                     puts "CHECKRULE MATCH OK"
 949                 }
 950                 return 1
 951             } else {
 952                 if {$debuglevel > 3} {
 953                     puts "CHECKFULE MATCH FAIL"
 954                 }
 955                 return 0
 956             }
 957         }
 958     }
 959     if {$debuglevel > 3} {
 960         puts "CHECKRULE MATCH OK"
 961     }
 962     return 1
 963 }
 964
 965
 966 proc url {href} {
 967     global debuglevel
 968
 969     if {[RobotHref http://www.indexdata.dk/ href host path]} {
 970         if {![RobotFileExist visited $host $path]} {
 971             set outf [RobotFileOpen unvisited $host $path]
 972             RobotWriteRecord $outf href 0
 973             RobotFileClose $outf
 974         }
 975     }
 976 }
 977
 978 proc deny {type stuff} {
 979     global alrules
 980
 981     lappend alrules [list deny $type $stuff]
 982 }
 983
 984 proc allow {type stuff} {
 985     global alrules
 986
 987     lappend alrules [list allow $type $stuff]
 988 }
 989
 990 proc debug {level} {
 991     global debuglevel
 992
 993     set debuglevel $level
 994 }
 995
 996 # Parse options
 997
 998 set i 0
 999 set l [llength $argv]
1000
1001 if {$l < 2} {
1002     puts {tclrobot: usage:}
1003     puts {tclrobot [-j jobs] [-i idle] [-c count] [-d domain] [-r rules] [url ..]}
1004     puts " Example: -c 3 -d '*.dk' http://www.indexdata.dk/"
1005
1006     exit 1
1007 }
1008 while  {$i < $l} {
1009     set arg [lindex $argv $i]
1010     switch -glob -- $arg {
1011         -j* {
1012             set robotsMax [string range $arg 2 end]
1013             if {![string length $robotsMax]} {
1014                 set robotsMax [lindex $argv [incr i]]
1015             }
1016         }
1017         -c* {
1018             set maxdistance [string range $arg 2 end]
1019             if {![string length $maxdistance]} {
1020                 set maxdistance [lindex $argv [incr i]]
1021             }
1022         }
1023         -d* {
1024             set dom [string range $arg 2 end]
1025             if {![string length $dom]} {
1026                 set dom [lindex $argv [incr i]]
1027             }
1028             lappend domains $dom
1029         }
1030         -i* {
1031             set idletime [string range $arg 2 end]
1032             if {![string length $idletime]} {
1033                 set idletime [lindex $argv [incr i]]
1034             }
1035         }
1036         -l* {
1037             set acceptLanguage [string range $arg 2 end]
1038             if {![string length $acceptLanguage]} {
1039                 set acceptLanguage [lindex $argv [incr i]]
1040             }
1041         }
1042         -r* {
1043             set rfile [string range $arg 2 end]
1044             if {![string length $rfile]} {
1045                 set rfile [lindex $argv [incr i]]
1046             }
1047             source $rfile
1048         }
1049         default {
1050             set href $arg
1051             if {[RobotHref http://www.indexdata.dk/ href host path]} {
1052                 if {![RobotFileExist visited $host $path]} {
1053                     set outf [RobotFileOpen unvisited $host $path]
1054                     RobotWriteRecord $outf href 0
1055                     RobotFileClose $outf
1056                 }
1057             }
1058         }
1059     }
1060     incr i
1061 }
1062
1063 if {![info exist domains]} {
1064     set domains {*}
1065 }
1066 if {![info exist maxdistance]} {
1067     set maxdistance 50
1068 }
1069 if {![info exist robotsMax]} {
1070     set robotsMax 5
1071 }
1072
1073 puts "domains=$domains"
1074 puts "max distance=$maxdistance"
1075 puts "max jobs=$robotsMax"
1076
1077
1078 RobotStart
1079
1080
1081 while {$robotsRunning} {
1082     vwait robotsRunning
1083 }
1084
1085 puts "End un,ba,vi=$status(unvisited),$status(bad),$status(visited)"