robot.tcl

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