;; @module ownload.lsp
;; @description Helps to download video from many sites (YouTube etc)
;; @author Cyril Slobin
;; @location http://slobin.pp.ru/newlisp/ownload.lsp
;; @version $Id: ownload.lsp,v 1.41 2010/02/07 16:00:31 slobin Exp $

(println "ownload: " ((parse "$Revision: 1.41 $" " ") 1))

; Great thanks to creators of these wonderful services!
; Sorry I want not to see your advertising any more...

(setq services '(
                  ; YouTube can be handled by this script by itself
                  ; Added in version 1.41
                  ("foo" ; not used
                   "youtube.com (direct)"
                   "bar=%s" ; not used
                   SELF
                   ({\"fmt_(?:url|stream)_map\"\:\s+\"([^"]*)\"}
                    {\|([^,]*)(?:\,|$)}))

                  ; The standard interface MUST be probed AFTER this
                  ; Added in version 1.30, last change in 1.37
                  ("http://flashvideodownloader.org/download.php"
                   "flashvideodownloader.org (direct)"
                   "u=%s"
                   TEST
                   ({video\/flv\r\n(?:.*\r\n)*\r\n(.*)$}))
                  
                  ; The direct interface MUST be probed BEFORE this
                  ; Added in version 1.27
                  ("http://flashvideodownloader.org/download.php"
                   "flashvideodownloader.org (standard)"
                   "u=%s"
                   GET
                   ({href\="([^"]*)\"[^>]*title\=\"Click}))
                 
                  ; Added in version 1.33
                  ("http://www.kcoolonline.com/"
                   "kcoolonline.com"
                   "url=%s"
                   GET
                   ({href\=\'([^']*)\'[^>]*title\=\'[^']*Flv}))
                 
                  ; Added in version 1.12, last change in 1.26
                  ("http://cs.videosaver.ru/xurl/"
                   "videosaver.ru"
                   "url=%s"
                   GET
                   ({id\=\"rlink\"[^>]*href\=\"([^"]*)\"}))
                 
                  ; Added in version 1.40; long live Lithuania!
                  ("http://download.uzeik.net/yten.php"
                   "download.uzeik.net"
                   "msg=%s&fr=1"
                   POST
                   ({href\='([^']*)\'[^>]*class\=\'ddl'}))

;                 ; Added in version 1.15, removed in 1.41 (temporary?)
;                 ("http://keepvid.com/"
;                  "keepvid.com"
;                  "url=%s"
;                  GET
;                  ({href\=\"([^"]*)\"[^>]*\>[^.]*\.flv}))

;                 ; Added in version 1.13, removed in 1.26
;                 ("http://0download.ru/"
;                  "0download"
;                  "url=%s"
;                  GET
;                  ({copytoclipboard\(\'([^']*)\'\)}))

;                 ; Added in the first version, removed in 1.26
;                 ("http://vidirect.ru/backend/main_backend.php"
;                  "vidirect"
;                  "url=%s"
;                  GET
;                  ({^(.*)$}))
                 ))

; Replace nil with true for debugging

(when nil (setq services (list (services (int (env "TEST"))))))

; Check for condition, optionally print a message, throw error

(define (check test message)
  (unless test (when message (println message)) (throw 'error)))

; Name of built-in function

(define (fname func) (replace {\s*\<[^<]*$} (string func) "" 0))

; Block with a catch

(define-macro (block) (catch (eval (cons 'begin (args)))))

; If this script is shipped as executable, search for the other
; executables in the same directory as the script itself first.

(define (my function command , dir cmd tail file)
  (println "my: " (fname function) " " command)
  (block
    (check (= ostype "Win32"))
    (check linked-with-executable)
    (check (regex {(.+)\\[^\\]+} (main-args 0)))
    (setq dir $1)
    (regex {(\S+)\s*(.*)} command)
    (setq cmd $1 tail $2)
    (setq file (format {%s\%s.exe} dir cmd))
    (check (file? file))
    (setq command (format {""%s" %s"} file tail)))
  (function command))

; URL encode

(define (encode str)
  (replace {([^0-9A-Za-z])} str (format "%%%02X" (char $1)) 0))

; URL decode

(define (decode str)
  (replace {\%([0-9A-Fa-f]{2})} str (char (int (append "0x" $1))) 0))

; Unified GET/POST command (the POST branch was not heavily tested)
; The TEST command returns HTTP headers followed by the URL itself
; The SELF command uses the query argument as full URL

(setq mimetype "application/x-www-form-urlencoded")
(setq timeout 60000)

(define (obtain-url command host param query , data url)
  (setq data (format param (encode query)))
  (setq url (append host "?" data))
  (case command
    (GET (get-url url timeout))
    (POST (post-url host data mimetype timeout))
    (TEST (append (get-url url "header" timeout) url))
    (SELF (get-url query timeout))))

; Guess a clip name from a link

(setq clipforms '({%s\.i?flv(?:\W|$)} {id\=%s} {url\=%s} {clip\:%s} {%s\W*$}))
(setq clippatterns (map (fn (s) (format s {([\w.-]+)})) clipforms))

(define (guess-clip link , pattern result)
  (dolist (pattern clippatterns (setq result (regex pattern link))))
  (if result $1 nil))

; Main

(setq base (if linked-with-executable 1 2))
(cond
  ((= (length (main-args)) (+ base 1))
    (setq video (main-args base)))
  ((and (= (length (main-args)) base) (= ostype "Win32"))
    (setq video ((my exec "winclip -p") 0)))
  (true
    (println "syntax: ownload.lsp url") (exit)))

(println "video: " video)
(setq clip nil)

(dolist (service services)
  (block
    (map set '(srv-host srv-title srv-param srv-command srv-patlist) service)
    (println "service: " srv-title)
    (setq page (obtain-url srv-command srv-host srv-param video))
    (check (!= page "") "error: empty page received")
    (check (not (starts-with page "ERR:")) ((parse page {\r?\n} 0) 0))
    (setq link page)
    (dolist (pattern srv-patlist)
      (check (regex pattern link) (format "error: no link found %d" $idx))
      (setq link (decode $1)))
    (replace "^/" link srv-host 0)
    (println "link: " link)
    (check (starts-with link "http://") "error: not a http link")
    (setq clip (guess-clip link))
    (check (!= clip nil) "error: should not happen")
    ; no more checks, just do it
    (replace {\W} clip "_" 0)
    (setq temp (append clip ".!lv"))
    (setq file (append clip ".flv"))
    (println "file: " file)
    (my ! (format {wget -O "%s" "%s"} temp link))
    (delete-file file)
    (rename-file temp file)
    (exit)))

(println "failure: no more services")
(exit)