robot.tcl

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