robot.tcl

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