jadedctrl/ mirror-img
1
0
Disbranĉigi 0
Fontkodo Issues Tirpetoj Activity

Use keyword rather than optional arguments

This commit is contained in:
Jaidyn Ann 2024-05-28 15:07:27 -05:00
parent 0b4ceff91f
commit 927f80e1ee
1 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/mirror-img.lisp
View File

@ -21,31 +21,32 @@
(in-package :mirror-img)
(defvar *src-tags* '("audio" "embed" "img" "input" "script" "source" "track" "video"))
(defvar *href-tags* '("link"))
(defparameter +src-tags+ '("audio" "embed" "img" "input" "script" "source" "track" "video"))
(defparameter +href-tags+ '("link"))
(defparameter *default-tags* (append +src-tags+ +href-tags+))
;;; Mirror-img
;;; ————————————————————————————————————————
;; pathname pathname list → string
(defun mirror-img (html-file base-dir &optional (tags '("img")))
(defun mirror-img (html-file base-dir &key (tags *default-tags*))
"Attempt to mirror all remote HREF/SRC URLs of an HTML file’s tags,
downloading them to base-dir. The remote URLs will be replaced with the
local version, where downloading was successful.
Returns a string of the modified page’s HTML."
(let* ((dom (lquery:$ (lquery:initialize html-file)))
(url→pathname-alist
(mirror-linked-urls dom (append *src-tags* *href-tags*) base-dir))
(mirror-linked-urls dom :tags tags :base-dir base-dir))
(url→relative-url-alist
(mapcar (lambda (pair) (cons (car pair) (namestring (cdr pair))))
url→pathname-alist)))
(substitute-urls dom
url→relative-url-alist
(append *src-tags* *href-tags*))
:tags tags)
(aref (lquery:$ dom (serialize)) 0)))
;; lquery-dom list pathname → alist
(defun mirror-linked-urls (dom &optional (tags '("link" "img" "script")) base-dir)
(defun mirror-linked-urls (dom &key (tags *default-tags*) base-dir)
"Mirror all URLs in the HREF/SRC attributes of the given tags in an LQuery
DOM, downloading them to either the current-working directory or the base-dir.
Returns an associative list containing pairs of remote-URLs to local pathnames.
@ -57,13 +58,13 @@ For example:
(mapcar (lambda (url)
(let ((download-path
(ensure-directories-exist
(mirrored-pathname url base-dir))))
(mirrored-pathname url :base-dir base-dir))))
(if (http-fetch url download-path)
(cons url download-path))))
(linked-urls dom tags))))
(linked-urls dom :tags tags))))
;; lquery-dom alist list → nil
(defun substitute-urls (dom substitution-alist &optional (tags '("img")))
(defun substitute-urls (dom substitution-alist &key (tags '("img")))
"Replace SRC or HREF attributes of certain tags in an LQuery DOM, based on a
substitution associative list. The substitution alist is made up of cons-cells
mapping replacee URLs to substition URLs.
@ -84,7 +85,7 @@ among the given tags."
dom)
;; string pathname → pathname
(defun mirrored-pathname (url &optional base-dir)
(defun mirrored-pathname (url &key base-dir)
"Given a URL, return the corresponding path we would download it to, were we
to mirror it."
(let* ((url (quri:uri url))
@ -101,7 +102,7 @@ to mirror it."
;;; DOM-parsing
;;; ————————————————————————————————————————
;; lquery-dom list → list
(defun linked-urls (dom &optional (tags '("link" "img" "script")))
(defun linked-urls (dom &key (tags *default-tags*))
"Return a list of all URLs in the LQuery DOM contained in the given tags’
HREF and SRC attributes."
(flet ((url-list-of-tag (tag)