robot.tcl

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