1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators combinators.short-circuit
4 fry html.parser http.client io kernel locals math math.statistics
5 sequences sets splitting unicode urls urls.encoding shuffle ;
6 IN: html.parser.analyzer
8 : scrape-html ( url -- response vector )
11 : attribute ( tag string -- obj/f )
12 swap attributes>> at ;
14 : attribute* ( tag string -- obj ? )
15 swap attributes>> at* ;
17 : attribute? ( tag string -- ? )
18 swap attributes>> key? ;
20 : find-all ( seq quot -- alist )
21 [ <enum> >alist ] [ '[ second @ ] ] bi* filter ; inline
23 : loopn-index ( n quot -- )
24 [ iota ] [ '[ @ not ] ] bi* find 2drop ; inline
27 [ drop ] prepose loopn-index ; inline
29 : html-class? ( tag string -- ? )
30 swap "class" attribute [ blank? ] split-when member? ;
32 : html-id? ( tag string -- ? )
33 swap "id" attribute = ;
35 ERROR: undefined-find-nth m n seq quot ;
37 : check-trivial-find ( m n seq quot -- m n seq quot )
38 pick 0 = [ undefined-find-nth ] when ; inline
40 : find-nth-from ( m n seq quot -- i/f elt/f )
41 check-trivial-find [ f ] 3dip '[
42 drop _ _ find-from [ dup [ 1 + ] when ] dip over
43 ] loopn [ dup [ 1 - ] when ] dip ; inline
45 : find-nth ( n seq quot -- i/f elt/f )
46 [ 0 ] 3dip find-nth-from ; inline
48 : find-last-nth-from ( m n seq quot -- i/f elt/f )
49 check-trivial-find [ f ] 3dip '[
50 drop _ _ find-last-from [ dup [ 1 - ] when ] dip over
51 ] loopn [ dup [ 1 + ] when ] dip ; inline
53 : find-last-nth ( n seq quot -- i/f elt/f )
54 [ [ nip length 1 - ] [ ] 2bi ] dip find-last-nth-from ; inline
56 : find-first-name ( vector string -- i/f tag/f )
57 >lower '[ name>> _ = ] find ; inline
59 : stack-find ( seq quot: ( elt -- 1/0/-1 ) -- i/f )
60 map cum-sum 0 swap index ; inline
62 : tag-classifier ( string -- quot )
64 '[ dup name>> _ = [ closing?>> -1 1 ? ] [ drop 0 ] if ] ; inline
66 : find-between* ( vector i/f tag/f -- vector )
68 [ tail-slice ] [ name>> ] bi*
69 dupd tag-classifier stack-find [ 1 + ] [ 1 ] if*
75 : find-between ( vector i/f tag/f -- vector )
76 find-between* dup length 3 >= [
77 [ rest-slice but-last-slice ] keep like
80 : find-between-first ( vector string -- vector' )
81 dupd find-first-name find-between ; inline
83 : find-between-all ( vector quot -- seq )
85 '[ _ [ closing?>> not ] bi and ] find-all
86 [ first2 find-between* ] with map ; inline
88 : remove-blank-text ( vector -- vector' )
91 [ text>> [ blank? ] all? not ] [ drop t ] if
94 : trim-text ( vector -- vector' )
97 [ [ [ blank? ] trim ] change-text ] when
100 : find-by-id ( vector id -- vector' elt/f )
101 '[ _ html-id? ] find ;
103 : find-by-class ( vector id -- vector' elt/f )
104 '[ _ html-class? ] find ;
106 : find-by-name ( vector string -- vector elt/f )
107 >lower '[ name>> _ = ] find ;
109 : find-by-id-between ( vector string -- vector' )
110 '[ _ html-id? ] dupd find find-between* ;
112 : find-by-class-between ( vector string -- vector' )
113 '[ _ html-class? ] dupd find find-between* ;
115 : find-by-class-id-between ( vector class id -- vector' )
117 [ _ html-class? ] [ _ html-id? ] bi and
118 ] dupd find find-between* ;
120 : find-by-attribute-key ( vector key -- vector' )
121 >lower '[ _ attribute? ] filter sift ;
123 : find-by-attribute-key-value ( vector value key -- vector' )
124 >lower swap '[ _ attribute _ = ] filter sift ;
126 : find-first-attribute-key-value ( vector value key -- i/f tag/f )
127 >lower swap '[ _ attribute _ = ] find ;
129 : find-links ( vector -- vector' )
130 [ { [ name>> "a" = ] [ "href" attribute ] } 1&& ]
133 : find-images ( vector -- vector' )
134 [ { [ name>> "img" = ] [ "src" attribute ] } 1&& ] filter sift
135 [ "src" attribute ] map ;
137 : find-by-text ( seq quot -- tag )
138 [ dup name>> text = ] prepose find drop ; inline
140 : find-opening-tags-by-name ( name seq -- seq )
141 [ { [ name>> = ] [ closing?>> not ] } 1&& ] with find-all ;
143 : href-contains? ( str tag -- ? )
144 "href" attribute* [ subseq? ] [ 2drop f ] if ;
146 : find-hrefs ( vector -- vector' )
147 [ { [ name>> "a" = ] [ "href" attribute? ] } 1&& ] filter sift
148 [ "href" attribute >url ] map ;
150 : find-frame-links ( vector -- vector' )
151 [ { [ name>> "frame" = ] [ "src" attribute? ] } 1&& ] filter sift
152 [ "src" attribute >url ] map ;
154 : find-script-links ( vector -- vector' )
155 [ { [ name>> "script" = ] [ "src" attribute? ] } 1&& ] filter sift
156 [ "src" attribute >url ] map ;
158 : find-all-links ( vector -- vector' )
159 [ find-hrefs ] [ find-frame-links ] [ find-script-links ] tri union union ;
161 : find-forms ( vector -- vector' )
162 "form" over find-opening-tags-by-name
163 swap [ [ first2 ] dip find-between* ] curry map
164 [ [ name>> { "form" "input" } member? ] filter ] map ;
166 : find-html-objects ( vector string -- vector' )
167 over find-opening-tags-by-name
168 [ first2 find-between* ] with map ;
170 : form-action ( vector -- string )
171 [ name>> "form" = ] find nip "action" attribute ;
173 : hidden-form-values ( vector -- strings )
174 [ "type" attribute "hidden" = ] filter ;
177 [ name>> print ] [ attributes>> ] bi
178 [ bl bl bl bl [ write "=" write ] [ write bl ] bi* nl ] assoc-each ;
180 : form. ( vector -- )
181 [ closing?>> ] reject
184 { [ dup name>> "form" = ]
185 [ "form action: " write "action" attribute print ] }
186 { [ dup name>> "input" = ] [ input. ] }
191 : query>assoc* ( str -- hash )
192 "?" split1 nip query>assoc ;
194 : opening-tag? ( tag -- ? )
197 TUPLE: link attributes clickable ;
199 : <link> ( vector -- link )
200 [ first attributes>> ]
201 [ [ name>> { text "img" } member? ] filter ] bi
204 : link. ( vector -- )
205 [ "href" attribute write nl ]
206 [ clickable>> [ bl bl text>> print ] each nl ] bi ;