Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 64 lines (52 sloc) 1.98 KB
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
#|
QuicktimeTcl Interfaces
Copyright (C) 2007 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :celtk)
(export! mk-movie url tk-file plug-n-play-movie)
(deftk movie (widget)
()
(:tk-spec movie -url (tk-file -file)
-controller -custombutton -highlightbackground -highlightcolor
-highlightthickness -height -loadcommand -loadintoram -loopstate
-mccommand -mcedit -palindromeloopstate -preferredrate -progressproc
-qtprogress -qtvrqualitymotion -qtvrqualitystatic -resizable
-swing -swingspeed -volume -width)
(:default-initargs
:tile? nil))
(defobserver tk-file :around ((self movie))
(call-next-method)
(with-cc :playmovie
(when (plusp (length new-value)) ;; gets nil and ""
(plug-n-play-movie self new-value nil)
#+goodluck (app-idle-task-new
(let ((start (now)))
(lambda (task app)
(declare (ignore app))
(when (> (- (now) start) 2)
(with-cc
(setf (tk-file self) "")
(app-idle-task-destroy task)))))))))
(defun plug-n-play-movie (m file &optional (install? t))
;
; silly harcodes follow....
;
(when install? (setf (tk-file m) file))
#-silliness
(tk-format `(:fini ,m) "~a play" (path m))
;
; this off-on sequence apparently necessary each time a file is loaded or sth.
;
#+silliness
(with-cc :loopstate
(setf (palindromeloopstate m) 0)
(with-cc :loopstate
(setf (palindromeloopstate m) 1)
(tk-format `(:fini ,m) "~a play" (path m)))))