download-slideshare.ros

#!/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))))))