robot.tcl

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