Commit 1d366452 authored by Michael Raskin's avatar Michael Raskin

Syncing from Monotone at 20200213-150342. Last commit message was More or less...

Syncing from Monotone at 20200213-150342. Last commit message was More or less import classname logic
parent 74c37287
......@@ -69,7 +69,6 @@ as readable content in case this element is picked as a part of main content.
text
"Alphabetic" "Sentence_Terminal" "Punctuation")
(let* ((commas (- punctuation sentences))
(total (length text))
(length-points (min 3 (truncate letters 90))))
(if (< letters 25) 0 (+ commas length-points 1)))))
......@@ -102,6 +101,7 @@ as readable content in case this element is picked as a part of main content.
(multiple-value-bind
(score level-scores text content)
(html-score-content protocol c cache)
(declare (ignorable score))
(push level-scores top-level-scores)
(when text (push text texts))
(when content (push content content-children))))
......@@ -143,6 +143,7 @@ as readable content in case this element is picked as a part of main content.
(multiple-value-bind
(sub-scores own-text content)
(collect-child-scoring-data protocol element cache)
(declare (ignorable sub-scores))
(values -1 (list -0.1) own-text content)))
(def-html-score-content
(:element
......@@ -157,6 +158,7 @@ as readable content in case this element is picked as a part of main content.
(multiple-value-bind
(sub-scores own-text content)
(collect-child-scoring-data protocol element cache)
(declare (ignorable sub-scores))
(values (html-score-text protocol own-text)
(list) own-text content))))
......@@ -169,7 +171,7 @@ as readable content in case this element is picked as a part of main content.
(content html5-parser::document-fragment)
parent document)
(declare (ignorable content parent document))
(html5-parser:make-fragment))
(html5-parser:make-fragment document))
(defmethod build-content-dom ((protocol html-text-score-protocol)
content
(parent null) document)
......@@ -235,3 +237,48 @@ as readable content in case this element is picked as a part of main content.
nil nil))
(if textify-protocol
(html-element-to-text textify-protocol target) target)))
(defclass html-classname-score-protocol (html-text-score-protocol) ())
(defparameter *removable-classname-regexp*
"-ad-|ai2html|banner|breadcrumbs|combx|comment|community|cover-wrap|disqus|extra|footer|gdpr|header|legends|menu|related|remark|replies|rss|shoutbox|sidebar|skyscraper|social|sponsor|supplemental|ad-break|agegate|pagination|pager|popup|yom-remote")
(defparameter *no-remove-classname-regexp* "and|article|body|column|content|main|shadow")
(defparameter *boost-classname-regexp* "article|body|content|entry|hentry|h-entry|main|page|pagination|post|text|blog|story")
(defparameter *suppress-classname-regexp* "hidden|^hid$| hid$| hid |^hid |banner|combx|comment|com-|contact|foot|footer|footnote|gdpr|masthead|media|meta|outbrain|promo|related|scroll|share|shoutbox|sidebar|skyscraper|sponsor|shopping|tags|tool|widget")
(with-html-score-content-protocol
(html-classname-score-protocol) (protocol element cache)
(def-html-score-content (:element (:form :fieldset :object :embed :footer :link :video
:iframe :input :textarea :select :button))
(values 0 () "" nil)))
(defmethod html-score-content-dispatch ((protocol html-classname-score-protocol)
(type (eql :element)) tag element cache)
(let* ((class-attribute (html5-parser:element-attribute element "class"))
(id (html5-parser:element-attribute element "id"))
(classes (cl-ppcre:split
(format nil "[~{~a~}]+" (or *whitespace-list* (list #\Space)))
(string-downcase class-attribute)))
(boost
(+ (if (find-if (lambda (x)
(cl-ppcre:scan *boost-classname-regexp* x))
classes)
+25 0)
(if (find-if (lambda (x)
(cl-ppcre:scan *suppress-classname-regexp* x))
classes)
-25 0)
(if (cl-ppcre:scan *boost-classname-regexp* id) +25 0)
(if (cl-ppcre:scan *suppress-classname-regexp* id) -25 0)))
(drop (and (not (cl-ppcre:scan *no-remove-classname-regexp* id))
(not (find-if (lambda (x)
(cl-ppcre:scan *no-remove-classname-regexp* x))
classes))
(or (cl-ppcre:scan *removable-classname-regexp* id)
(find-if (lambda (x)
(cl-ppcre:scan *removable-classname-regexp* x))
classes)))))
(cond (drop (values 0 () "" nil))
(t (multiple-value-bind (score subscores pass-text content) (call-next-method)
(let* ((boosted (+ score boost))
(pass-boosted (+ score (if (> boost 0) 0 (/ boost 2)))))
(values boosted (cons pass-boosted (cdr subscores)) pass-text content)))))))
......@@ -3,7 +3,8 @@
(defun save-web-page (url target basename &key
fetcher fetcher-parameters
drakma-args html-textifier-protocol
html-content-score-protocol)
html-content-score-protocol
skip-extract-main-content skip-cookies skip-forms)
(ensure-directories-exist (format nil "~a/" target))
(let* ((f (or fetcher
(apply 'make-instance 'http-fetcher fetcher-parameters)))
......@@ -19,7 +20,7 @@
(format out "~a~%" (current-content f)))
(with-open-file (out (format nil "~a/~a.html.txt" target basename)
:direction :output)
(format out "→[ ~a ]~%→[ ~a ]~%~a~%~a~%~{~%(~{~s~%~})~%~%~}~S~%#.~S~%~%~a~%"
(format out "→[ ~a ]~%→[ ~a ]~%~a~%~a~%~{~%(~{~s~%~})~%~%~}~{~S~%#.~S~%~}~%~a~%"
url (current-url f)
(or
(ignore-errors
......@@ -31,37 +32,39 @@
"")
(or
(ignore-errors
(html-extract-main-content
(parsed-content f)
(or html-content-score-protocol
(make-instance 'html-text-score-protocol))
(or
html-textifier-protocol
(make-instance 'html-textifier-protocol-inspector))))
(unless skip-extract-main-content
(html-extract-main-content
(parsed-content f)
(or html-content-score-protocol
(make-instance 'html-classname-score-protocol))
(or
html-textifier-protocol
(make-instance 'html-textifier-protocol-inspector)))))
"")
(when (parsed-content f)
(when (and (not skip-forms) (parsed-content f))
(loop for form in (css-selectors:query
"form" (parsed-content f))
collect (form-parameters form :fetcher f)))
:cookie-jar
`(make-instance
'drakma:cookie-jar
:cookies
(list
,@(loop for c in (drakma:cookie-jar-cookies (cookie-jar f))
collect
`(make-instance
'drakma:cookie
:name
,(drakma:cookie-name c)
:value
,(drakma:cookie-value c)
:domain
,(drakma:cookie-domain c)
:path
,(drakma:cookie-path c)
:expires
,(drakma:cookie-expires c)))))
(unless skip-cookies
:cookie-jar
`(make-instance
'drakma:cookie-jar
:cookies
(list
,@(loop for c in (drakma:cookie-jar-cookies (cookie-jar f))
collect
`(make-instance
'drakma:cookie
:name
,(drakma:cookie-name c)
:value
,(drakma:cookie-value c)
:domain
,(drakma:cookie-domain c)
:path
,(drakma:cookie-path c)
:expires
,(drakma:cookie-expires c))))))
(if (parsed-content f)
(html-element-to-text
(or html-textifier-protocol
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment