|
#!/bin/sh |
|
#|-*- mode:lisp -*-|# |
|
#| |
|
exec ros -Q -- $0 "$@" |
|
|# |
|
(defpackage :ros.script.download-slideshare.lisp.3663837159 |
|
(:use :cl)) |
|
(in-package :ros.script.download-slideshare.lisp.3663837159) |
|
|
|
(ql:quickload :drakma :silent t) |
|
(ql:quickload :closure-html :silent t) |
|
;;(ql:quickload :stp-query :silent t) |
|
(ql:quickload :cxml-stp :sielnt t) |
|
(ql:quickload :cl-fad :silent t) |
|
|
|
(defun save-data (data filename directory) |
|
(with-open-file (out (merge-pathnames (pathname filename) directory) |
|
:direction :output |
|
:element-type '(unsigned-byte 8)) |
|
(write-sequence (make-array (length data) |
|
:element-type '(unsigned-byte 8) |
|
:initial-contents data) |
|
out))) |
|
|
|
;; (defun retrive-image-urls (text) |
|
;; (let ((doc (chtml:parse text (cxml-stp:make-builder)))) |
|
;; (loop |
|
;; :for element :in ($:find doc "img") |
|
;; :for url := ($:attr element "data-full") |
|
;; :when url |
|
;; :collect url))) |
|
|
|
(defun retrive-image-urls (text) |
|
(let ((doc (chtml:parse text (cxml-stp:make-builder)))) |
|
(loop |
|
:for element :in (stp:filter-recursively |
|
(lambda (c) |
|
(and (typep c 'stp:element) |
|
(string= "img" (stp:local-name c)))) |
|
doc) |
|
:for url := (loop :for attr :in (stp:list-attributes element) |
|
:when (equal (stp:local-name attr) "data-full") |
|
:do (return (stp:value attr))) |
|
:when url |
|
:collect url))) |
|
|
|
(defun fetch-images (url directory) |
|
(loop |
|
:for url :in (retrive-image-urls (drakma:http-request url)) |
|
:for i :from 0 |
|
:do (sleep 1) |
|
(format t "downloading ~a ..." url) |
|
(let ((filename (format nil "~5,'0d.jpg" i))) |
|
(save-data (drakma:http-request url) |
|
filename |
|
directory) |
|
(format t "save as ~a~%" filename)))) |
|
|
|
(defun usage () |
|
(format t "usage: ./download-slideshare.ros url [directory]~%")) |
|
|
|
(defun main (&rest argv) |
|
(cond ((not (< 0 (length argv))) |
|
(usage)) |
|
(t |
|
(destructuring-bind (url &optional name) argv |
|
(let ((directory |
|
(if name |
|
(cl-fad:pathname-as-directory name) |
|
(cl-fad:pathname-as-directory (pathname-name url))))) |
|
(ensure-directories-exist directory) |
|
(fetch-images (car argv) directory)))))) |
