robot.tcl

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