steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Refactor spider vocab to fix a bug and remove a rot

db4
Doug Coleman 2010-08-18 11:34:36 -05:00
parent 9c308ac4c5
commit 8b0a95e4a0
1 changed files with 22 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
extra/spider/spider.factor
View File

@ -31,12 +31,14 @@ fetched-in parsed-html links processed-in fetched-at ;
: <spider-result> ( url depth -- spider-result ) : <spider-result> ( url depth -- spider-result )
spider-result new spider-result new
swap >>depth swap >>depth
swap >>url ; swap >>url ; inline
<PRIVATE <PRIVATE
: apply-filters ( links spider -- links' ) : apply-filters ( links spider -- links' )
filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ; filters>> [
'[ [ _ 1&& ] filter ] call( seq -- seq' )
] when* ;
: push-links ( links level unique-deque -- ) : push-links ( links level unique-deque -- )
'[ _ _ push-url ] each ; '[ _ _ push-url ] each ;
@ -51,13 +53,18 @@ fetched-in parsed-html links processed-in fetched-at ;
[ base>> host>> ] [ links>> members ] bi* [ base>> host>> ] [ links>> members ] bi*
[ host>> = ] with partition ; [ host>> = ] with partition ;
: add-spidered ( spider spider-result -- ) :: add-spidered ( spider spider-result -- )
[ [ 1 + ] change-count ] dip spider [ 1 + ] change-count drop
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
[ filter-base-links ] 2keep spider-result dup url>>
depth>> 1 + swap spider spidered>> set-at
[ add-nonmatching ]
[ dup '[ _ apply-filters ] curry 2dip add-todo ] 2bi ; spider spider-result filter-base-links :> ( matching nonmatching )
spider-result depth>> 1 + :> depth
nonmatching depth spider add-nonmatching
matching spider apply-filters depth spider add-todo ;
: normalize-hrefs ( base links -- links' ) : normalize-hrefs ( base links -- links' )
[ derive-url ] with map ; [ derive-url ] with map ;
@ -93,10 +100,10 @@ fetched-in parsed-html links processed-in fetched-at ;
: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ; : spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
: queue-initial-links ( spider -- ) : queue-initial-links ( spider -- spider )
[ [ [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 ]
[ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 [ add-todo ]
] keep add-todo ; [ ] tri ;
: spider-page? ( spider -- ? ) : spider-page? ( spider -- ? )
{ {
@ -123,5 +130,6 @@ PRIVATE>
: run-spider ( spider -- spider ) : run-spider ( spider -- spider )
"spider" [ "spider" [
dup queue-initial-links [ run-spider-loop ] keep queue-initial-links
[ run-spider-loop ] keep
] with-logging ; ] with-logging ;