· 7 years ago · Feb 27, 2019, 01:14 AM
1diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/Makefile
2--- a/otherlibs/labltk/Makefile Fri Mar 26 16:28:27 2010 +0900
3+++ b/otherlibs/labltk/Makefile Fri Mar 26 17:30:59 2010 +0900
4@@ -1,6 +1,6 @@
5 # Top Makefile for mlTk
6
7-SUBDIRS=compiler support lib jpf frx tkanim examples_labltk \
8+SUBDIRS=compiler support lib jpf frx examples_labltk \
9 examples_camltk browser
10 SUBDIRS_GENERATED=camltk labltk
11
12@@ -15,7 +15,6 @@
13 cd lib; $(MAKE)
14 cd jpf; $(MAKE)
15 cd frx; $(MAKE)
16- cd tkanim; $(MAKE)
17 cd browser; $(MAKE)
18
19 allopt:
20@@ -27,7 +26,6 @@
21 cd lib; $(MAKE) opt
22 cd jpf; $(MAKE) opt
23 cd frx; $(MAKE) opt
24- cd tkanim; $(MAKE) opt
25
26 byte: all
27 opt: allopt
28@@ -60,7 +58,6 @@
29 cd compiler; $(MAKE) install
30 cd jpf; $(MAKE) install
31 cd frx; $(MAKE) install
32- cd tkanim; $(MAKE) install
33 cd browser; $(MAKE) install
34
35 installopt:
36@@ -70,7 +67,6 @@
37 cd camltk; $(MAKE) installopt
38 cd jpf; $(MAKE) installopt
39 cd frx; $(MAKE) installopt
40- cd tkanim; $(MAKE) installopt
41
42 partialclean clean:
43 for d in $(SUBDIRS); do \
44diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/examples_camltk/eyes.ml
45--- a/otherlibs/labltk/examples_camltk/eyes.ml Fri Mar 26 16:28:27 2010 +0900
46+++ b/otherlibs/labltk/examples_camltk/eyes.ml Fri Mar 26 17:30:59 2010 +0900
47@@ -25,7 +25,7 @@
48 pack [fw] [];
49 let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
50 let create_eye cx cy wx wy ewx ewy bnd =
51- let o2 =
52+ let _o2 =
53 Canvas.create_oval c
54 (Pixels (cx - wx)) (Pixels (cy - wy))
55 (Pixels (cx + wx)) (Pixels (cy + wy))
56diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/examples_camltk/tetris.ml
57--- a/otherlibs/labltk/examples_camltk/tetris.ml Fri Mar 26 16:28:27 2010 +0900
58+++ b/otherlibs/labltk/examples_camltk/tetris.ml Fri Mar 26 17:30:59 2010 +0900
59@@ -215,7 +215,6 @@
60 let scorev = Textvariable.create ()
61 and linev = Textvariable.create ()
62 and levv = Textvariable.create ()
63- and namev = Textvariable.create ()
64 in
65 let f = Frame.create fw [BorderWidth (Pixels 2)] in
66 let c = Canvas.create f [Width (Pixels (block_size * 10));
67diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/camltk.h
68--- a/otherlibs/labltk/support/camltk.h Fri Mar 26 16:28:27 2010 +0900
69+++ b/otherlibs/labltk/support/camltk.h Fri Mar 26 17:30:59 2010 +0900
70@@ -25,6 +25,11 @@
71 /* compatibility with earlier versions of Tcl/Tk */
72 #ifndef CONST84
73 #define CONST84
74+#endif
75+
76+/* if Tcl_GetStringResult is not defined, we use interp->result */
77+#ifndef Tcl_GetStringResult
78+# define Tcl_GetStringResult(interp) (interp->result)
79 #endif
80
81 /* cltkMisc.c */
82diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkDMain.c
83--- a/otherlibs/labltk/support/cltkDMain.c Fri Mar 26 16:28:27 2010 +0900
84+++ b/otherlibs/labltk/support/cltkDMain.c Fri Mar 26 17:30:59 2010 +0900
85@@ -223,7 +223,7 @@
86 if (0 == access(f,R_OK))
87 if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
88 stat_free(f);
89- tk_error(cltclinterp->result);
90+ tk_error(Tcl_GetStringResult(cltclinterp));
91 };
92 stat_free(f);
93 }
94diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkEval.c
95--- a/otherlibs/labltk/support/cltkEval.c Fri Mar 26 16:28:27 2010 +0900
96+++ b/otherlibs/labltk/support/cltkEval.c Fri Mar 26 17:30:59 2010 +0900
97@@ -75,9 +75,9 @@
98
99 switch (code) {
100 case TCL_OK:
101- return tcl_string_to_caml(cltclinterp->result);
102+ return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp));
103 case TCL_ERROR:
104- tk_error(cltclinterp->result);
105+ tk_error(Tcl_GetStringResult(cltclinterp));
106 default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
107 tk_error("bad tcl result");
108 }
109@@ -234,9 +234,9 @@
110
111 switch (result) {
112 case TCL_OK:
113- return tcl_string_to_caml (cltclinterp->result);
114+ return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp));
115 case TCL_ERROR:
116- tk_error(cltclinterp->result);
117+ tk_error(Tcl_GetStringResult(cltclinterp));
118 default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
119 tk_error("bad tcl result");
120 }
121diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkMain.c
122--- a/otherlibs/labltk/support/cltkMain.c Fri Mar 26 16:28:27 2010 +0900
123+++ b/otherlibs/labltk/support/cltkMain.c Fri Mar 26 17:30:59 2010 +0900
124@@ -95,7 +95,7 @@
125 }
126
127 if (Tcl_Init(cltclinterp) != TCL_OK)
128- tk_error(cltclinterp->result);
129+ tk_error(Tcl_GetStringResult(cltclinterp));
130 Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
131
132 { /* Sets argv */
133@@ -132,13 +132,13 @@
134 }
135 }
136 if (Tk_Init(cltclinterp) != TCL_OK)
137- tk_error(cltclinterp->result);
138+ tk_error(Tcl_GetStringResult(cltclinterp));
139
140 /* Retrieve the main window */
141 cltk_mainWindow = Tk_MainWindow(cltclinterp);
142
143 if (NULL == cltk_mainWindow)
144- tk_error(cltclinterp->result);
145+ tk_error(Tcl_GetStringResult(cltclinterp));
146
147 Tk_GeometryRequest(cltk_mainWindow,200,200);
148 }
149@@ -165,7 +165,7 @@
150 if (0 == access(f,R_OK))
151 if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
152 stat_free(f);
153- tk_error(cltclinterp->result);
154+ tk_error(Tcl_GetStringResult(cltclinterp));
155 };
156 stat_free(f);
157 }
158diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkMisc.c
159--- a/otherlibs/labltk/support/cltkMisc.c Fri Mar 26 16:28:27 2010 +0900
160+++ b/otherlibs/labltk/support/cltkMisc.c Fri Mar 26 17:30:59 2010 +0900
161@@ -47,7 +47,7 @@
162 case TCL_ERROR:
163 default:
164 stat_free( utf );
165- tk_error(cltclinterp->result);
166+ tk_error(Tcl_GetStringResult(cltclinterp));
167 }
168 }
169
170diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkVar.c
171--- a/otherlibs/labltk/support/cltkVar.c Fri Mar 26 16:28:27 2010 +0900
172+++ b/otherlibs/labltk/support/cltkVar.c Fri Mar 26 17:30:59 2010 +0900
173@@ -38,7 +38,7 @@
174 stat_free(stable_var);
175
176 if (s == NULL)
177- tk_error(cltclinterp->result);
178+ tk_error(Tcl_GetStringResult(cltclinterp));
179 else
180 return(tcl_string_to_caml(s));
181 }
182@@ -64,7 +64,7 @@
183 stat_free(utf_contents);
184
185 if (s == NULL)
186- tk_error(cltclinterp->result);
187+ tk_error(Tcl_GetStringResult(cltclinterp));
188 else
189 return(Val_unit);
190 }
191@@ -104,7 +104,7 @@
192 (ClientData) (Long_val(cbid)))
193 != TCL_OK) {
194 stat_free(cvar);
195- tk_error(cltclinterp->result);
196+ tk_error(Tcl_GetStringResult(cltclinterp));
197 };
198 stat_free(cvar);
199 return Val_unit;
200diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/support/cltkWait.c
201--- a/otherlibs/labltk/support/cltkWait.c Fri Mar 26 16:28:27 2010 +0900
202+++ b/otherlibs/labltk/support/cltkWait.c Fri Mar 26 17:30:59 2010 +0900
203@@ -66,7 +66,7 @@
204 vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
205 if (vis -> win == NULL) {
206 stat_free((char *)vis);
207- tk_error(cltclinterp->result);
208+ tk_error(Tcl_GetStringResult(cltclinterp));
209 };
210 vis->cbid = Int_val(cbid);
211 Tk_CreateEventHandler(vis->win, VisibilityChangeMask,
212@@ -93,7 +93,7 @@
213 vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
214 if (vis -> win == NULL) {
215 stat_free((char *)vis);
216- tk_error(cltclinterp->result);
217+ tk_error(Tcl_GetStringResult(cltclinterp));
218 };
219 vis->cbid = Int_val(cbid);
220 Tk_CreateEventHandler(vis->win, StructureNotifyMask,
221diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/.cvsignore
222--- a/otherlibs/labltk/tkanim/.cvsignore Fri Mar 26 16:28:27 2010 +0900
223+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
224@@ -1,4 +0,0 @@
225-gifanimtest
226-gifanimtest-static
227-*.so
228-*.a
229diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/.depend
230--- a/otherlibs/labltk/tkanim/.depend Fri Mar 26 16:28:27 2010 +0900
231+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
232@@ -1,2 +0,0 @@
233-tkanim.cmo: tkanim.cmi
234-tkanim.cmx: tkanim.cmi
235diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/Makefile
236--- a/otherlibs/labltk/tkanim/Makefile Fri Mar 26 16:28:27 2010 +0900
237+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
238@@ -1,71 +0,0 @@
239-# tkAnimGIF.c used the function Tk_ImageObjCmd, which is not available
240-# in a plain Tk installation. Should we disable this subdirectory ?
241-
242-include ../support/Makefile.common
243-
244-COMPFLAGS=-I ../support -I ../camltk -I ../../unix -I ../../win32unix
245-CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS)
246-
247-all: tkanim.cma libtkanim.$(A)
248-opt: tkanim.cmxa libtkanim.$(A)
249-example: gifanimtest$(EXE)
250-
251-OBJS=tkanim.cmo
252-COBJS= cltkaniminit.$(O) tkAnimGIF.$(O)
253-
254-tkanim.cma: $(OBJS)
255- $(MKLIB) -ocamlc '$(CAMLCB)' -o tkanim $(OBJS)
256-
257-tkanim.cmxa: $(OBJS:.cmo=.cmx)
258- $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o tkanim $(OBJS:.cmo=.cmx)
259-
260-libtkanim.$(A): $(COBJS)
261- $(MKLIB) -o tkanim $(COBJS)
262-
263-gifanimtest-static$(EXE): all gifanimtest.cmo
264- $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo
265-
266-# dynamic loading
267-gifanimtest$(EXE): all gifanimtest.cmo
268- $(CAMLC) -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo
269-
270-#animwish: $(TKANIM_LIB) tkAppInit.o
271-# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \
272-# -L. -ltkanim $(LIBS)
273-
274-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
275-
276-$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa
277-
278-clean:
279- rm -f *.cm* *.$(O) *.$(A) dlltkanim$(EXT_DLL) gifanimtest$(EXE) gifanimtest-static$(EXE)
280-
281-.SUFFIXES :
282-.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(O)
283-
284-.mli.cmi:
285- $(CAMLCOMP) $(COMPFLAGS) $<
286-
287-.ml.cmo:
288- $(CAMLCOMP) $(COMPFLAGS) $<
289-
290-.ml.cmx:
291- $(CAMLOPT) -c $(COMPFLAGS) $<
292-
293-.c.$(O):
294- $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
295-
296-
297-install:
298- cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR)
299- if [ -f dlltkanim$(EXT_DLL) ]; then \
300- cp dlltkanim$(EXT_DLL) $(STUBLIBDIR)/; \
301- fi
302-
303-installopt:
304- cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR)
305-
306-depend: tkanim.ml
307- $(CAMLDEP) *.mli *.ml > .depend
308-
309-include .depend
310diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/Makefile.nt
311--- a/otherlibs/labltk/tkanim/Makefile.nt Fri Mar 26 16:28:27 2010 +0900
312+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
313@@ -1,1 +0,0 @@
314-include Makefile
315diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/README
316--- a/otherlibs/labltk/tkanim/README Fri Mar 26 16:28:27 2010 +0900
317+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
318@@ -1,5 +0,0 @@
319-This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately
320-it is still test implementation. Look example directory for an example.
321-
322-The codes under this directory are mainly written by Jun Furuse
323-(Jun.Furuse@inria.fr).
324diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/cltkaniminit.c
325--- a/otherlibs/labltk/tkanim/cltkaniminit.c Fri Mar 26 16:28:27 2010 +0900
326+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
327@@ -1,28 +0,0 @@
328-/***********************************************************************/
329-/* */
330-/* MLTk, Tcl/Tk interface of Objective Caml */
331-/* */
332-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
333-/* projet Cristal, INRIA Rocquencourt */
334-/* Jacques Garrigue, Kyoto University RIMS */
335-/* */
336-/* Copyright 2002 Institut National de Recherche en Informatique et */
337-/* en Automatique and Kyoto University. All rights reserved. */
338-/* This file is distributed under the terms of the GNU Library */
339-/* General Public License, with the special exception on linking */
340-/* described in file LICENSE found in the Objective Caml source tree. */
341-/* */
342-/***********************************************************************/
343-#include <tk.h>
344-#include <mlvalues.h>
345-#include "camltk.h"
346-
347-extern int Tkanim_Init(Tcl_Interp *);
348-
349-CAMLprim value tkanim_init (rien) /* ML */
350- value rien;
351-{
352- if (Tkanim_Init(cltclinterp) != TCL_OK)
353- tk_error ("Can't initialize TkAnim");
354- return Val_unit;
355-}
356diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/gifanimtest.ml
357--- a/otherlibs/labltk/tkanim/gifanimtest.ml Fri Mar 26 16:28:27 2010 +0900
358+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
359@@ -1,71 +0,0 @@
360-(***********************************************************************)
361-(* *)
362-(* MLTk, Tcl/Tk interface of Objective Caml *)
363-(* *)
364-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
365-(* projet Cristal, INRIA Rocquencourt *)
366-(* Jacques Garrigue, Kyoto University RIMS *)
367-(* *)
368-(* Copyright 2002 Institut National de Recherche en Informatique et *)
369-(* en Automatique and Kyoto University. All rights reserved. *)
370-(* This file is distributed under the terms of the GNU Library *)
371-(* General Public License, with the special exception on linking *)
372-(* described in file LICENSE found in the Objective Caml source tree. *)
373-(* *)
374-(***********************************************************************)
375-open Camltk
376-open Widget
377-open Tkanim
378-open Tk
379-
380-let main () =
381- let file = ref "" in
382- Arg.parse [] (fun s -> file := s)
383- "usage: gifanimtest file (animated gif)\n\
384- \tbutton 1 toggles the animation,\n\
385- \tbutton 2 displays the next frame,\n\
386- \tbutton 3 quits.";
387- let t = openTk () in
388-
389- (* First of all, you must initialize the extension. *)
390- Tkanim.init ();
391-
392- prerr_endline !file;
393-
394- (* Then load the animated gif. *)
395- let anim = Tkanim.create !file in
396- prerr_endline "load done";
397-
398- (* Check it is really animated or not. *)
399- match anim with
400- | Still x ->
401- (* Use whatever you want in CamlTk with this ImagePhoto. *)
402- prerr_endline "Sorry, it is not an animated GIF."
403-
404- | Animated x ->
405- (* OK, let's animate it. *)
406- let l = Label.create t [] in
407- pack [l] [];
408-
409- (* animate returns an interface function. *)
410- let f = animate l x in
411-
412- (* Button1 toggles the animation *)
413- bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ ->
414- f false)));
415-
416- (* Button2 displays the next frame. *)
417- bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ ->
418- f true)));
419-
420- (* Button3 quits. *)
421- bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ ->
422- closeTk ())));
423-
424- (* start the animation *)
425- f false;
426-
427- (* Go to the main loop. *)
428- mainLoop ()
429-
430-let _ = Printexc.print main ()
431diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/libtkanim.clib
432--- a/otherlibs/labltk/tkanim/libtkanim.clib Fri Mar 26 16:28:27 2010 +0900
433+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
434@@ -1,1 +0,0 @@
435-cltkaniminit.o tkAnimGIF.o
436diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/mmm.anim.gif
437Binary file otherlibs/labltk/tkanim/mmm.anim.gif has changed
438diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/tkAnimGIF.c
439--- a/otherlibs/labltk/tkanim/tkAnimGIF.c Fri Mar 26 16:28:27 2010 +0900
440+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
441@@ -1,914 +0,0 @@
442-/***********************************************************************/
443-/* */
444-/* MLTk, Tcl/Tk interface of Objective Caml */
445-/* */
446-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
447-/* projet Cristal, INRIA Rocquencourt */
448-/* Jacques Garrigue, Kyoto University RIMS */
449-/* */
450-/* Copyright 2002 Institut National de Recherche en Informatique et */
451-/* en Automatique and Kyoto University. All rights reserved. */
452-/* This file is distributed under the terms of the GNU Library */
453-/* General Public License, with the special exception on linking */
454-/* described in file LICENSE found in the Objective Caml source tree. */
455-/* */
456-/***********************************************************************/
457-#define TKANIM_VERSION "1.0"
458-/* #define TKANIM_DEBUG */
459-
460-#include <tk.h>
461-#include <string.h>
462-
463-/*
464- * The format record for the Animated GIF file format:
465- */
466-
467-static int FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName,
468- char *formatString, int *widthPtr, int *heightPtr));
469-static int FileReadGIF _ANSI_ARGS_((Tcl_Interp *interp,
470- FILE *f, char *fileName, char *formatString));
471-
472-#define INTERLACE 0x40
473-#define LOCALCOLORMAP 0x80
474-#define BitSet(byte, bit) (((byte) & (bit)) == (bit))
475-#define MAXCOLORMAPSIZE 256
476-#define CM_RED 0
477-#define CM_GREEN 1
478-#define CM_BLUE 2
479-#define MAX_LWZ_BITS 12
480-#define LM_to_uint(a,b) (((b)<<8)|(a))
481-#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0)
482-
483-/*
484- * Prototypes for local procedures defined in this file:
485- */
486-
487-static int DoExtension _ANSI_ARGS_((FILE *fd, int label,
488- int *transparent, int *delay, int *loop));
489-static int GetCode _ANSI_ARGS_((FILE *fd, int code_size,
490- int flag));
491-static int GetDataBlock _ANSI_ARGS_((FILE *fd,
492- unsigned char *buf));
493-static int LWZReadByte _ANSI_ARGS_((FILE *fd, int flag,
494- int input_code_size));
495-static int ReadColorMap _ANSI_ARGS_((FILE *fd, int number,
496- unsigned char buffer[3][MAXCOLORMAPSIZE]));
497-static int ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr,
498- int *heightPtr));
499-static int ReadImage _ANSI_ARGS_((Tcl_Interp *interp,
500- char *imagePtr, FILE *fd, int len, int height,
501- unsigned char cmap[3][MAXCOLORMAPSIZE],
502- int interlace, int transparent));
503-
504-static int
505-FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr)
506- FILE *f; /* The image file, open for reading. */
507- char *fileName; /* The name of the image file. */
508- char *formatString; /* User-specified format string, or NULL. */
509- int *widthPtr, *heightPtr; /* The dimensions of the image are
510- * returned here if the file is a valid
511- * raw GIF file. */
512-{
513- return ReadGIFHeader(f, widthPtr, heightPtr);
514-}
515-
516-static int
517-FileReadGIF(interp, f, fileName, formatString)
518- Tcl_Interp *interp; /* Interpreter to use for reporting errors. */
519- FILE *f; /* The image file, open for reading. */
520- char *fileName; /* The name of the image file. */
521- char *formatString; /* User-specified format string, or NULL. */
522-{
523- int logicalWidth, logicalHeight;
524- int nBytes;
525- Tk_PhotoImageBlock block;
526- unsigned char buf[100];
527- int bitPixel;
528- unsigned int colorResolution;
529- unsigned int background;
530- unsigned int aspectRatio;
531- unsigned char localColorMap[3][MAXCOLORMAPSIZE];
532- unsigned char colorMap[3][MAXCOLORMAPSIZE];
533- int useGlobalColormap;
534- int transparent = -1;
535- int delay = 0;
536- Tk_Window winPtr;
537- int imageLeftPos, imageTopPos, imageWidth, imageHeight;
538- Tk_PhotoHandle photoHandle;
539-
540- char widthbuf[32], heightbuf[32];
541- Tcl_DString resultbuf;
542-
543- char newresbuf[640];
544- char *imageName;
545- char *resultptr;
546- int loop = -1;
547-
548- if((winPtr = Tk_MainWindow(interp)) == NULL){
549- return TCL_ERROR;
550- }
551-
552-#ifdef TKANIM_DEBUG
553- fprintf(stderr, "\n\t\tHeader check...");
554-#endif
555- if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) {
556- Tcl_AppendResult(interp, "couldn't read GIF header from file \"",
557- fileName, "\"", NULL);
558- return TCL_ERROR;
559- }
560-#ifdef TKANIM_DEBUG
561- fprintf(stderr, "done ");
562-#endif
563- if ((logicalWidth <= 0) || (logicalHeight <= 0)) {
564- Tcl_AppendResult(interp, "GIF image file \"", fileName,
565- "\" has dimension(s) <= 0", (char *) NULL);
566- return TCL_ERROR;
567- }
568-
569- if (fread(buf, 1, 3, f) != 3) {
570- return TCL_OK;
571- }
572- bitPixel = 2<<(buf[0]&0x07);
573- colorResolution = (((buf[0]&0x70)>>3)+1);
574- background = buf[1];
575- aspectRatio = buf[2];
576-
577- if (BitSet(buf[0], LOCALCOLORMAP)) { /* Global Colormap */
578- if (!ReadColorMap(f, bitPixel, colorMap)) {
579- Tcl_AppendResult(interp, "error reading color map",
580- (char *) NULL);
581- return TCL_ERROR;
582- }
583- }
584-
585-#ifdef TKANIM_DEBUG
586- fprintf(stderr, "\n\t\tReading frames ");
587- prevpos = ftell(f);
588-#endif
589- sprintf( widthbuf, "%d ", logicalWidth);
590- sprintf( heightbuf, "%d ", logicalHeight);
591-
592- Tcl_DStringInit(&resultbuf);
593- Tcl_DStringAppend(&resultbuf, widthbuf, -1);
594- Tcl_DStringAppend(&resultbuf, " ", -1);
595- Tcl_DStringAppend(&resultbuf, heightbuf, -1);
596- Tcl_DStringAppend(&resultbuf, " ", -1);
597- Tcl_DStringAppend(&resultbuf, "{", -1);
598-
599- while (1) {
600- if (fread(buf, 1, 1, f) != 1) {
601- /*
602- * Premature end of image. We should really notify
603- * the user, but for now just show garbage.
604- */
605-#ifdef TKANIM_DEBUG
606- fprintf(stderr, "Premature end of image");
607-#endif
608-
609- break;
610- }
611-
612- if (buf[0] == ';') {
613- /*
614- * GIF terminator.
615- */
616-#ifdef TKANIM_DEBUG
617- fprintf(stderr, ";");
618- prevpos = ftell(f);
619-#endif
620-
621- break;
622- }
623-
624- if (buf[0] == '!') {
625- /*
626- * This is a GIF extension.
627- */
628-#ifdef TKANIM_DEBUG
629- fprintf(stderr, "!");
630- prevpos = ftell(f);
631-#endif
632-
633- if (fread(buf, 1, 1, f) != 1) {
634- Tcl_AppendResult( interp,
635- "error reading extension function code in GIF image", NULL );
636-/*
637- interp->result =
638- "error reading extension function code in GIF image";
639-*/
640- goto error;
641- }
642- if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) {
643- Tcl_AppendResult( interp,
644- "error reading extension in GIF image", NULL );
645-/*
646- interp->result = "error reading extension in GIF image";
647-*/ goto error;
648- }
649- continue;
650- }
651-
652- if (buf[0] == '\0') {
653- /*
654- * Not a valid start character; ignore it.
655- */
656-#ifdef TKANIM_DEBUG
657- fprintf(stderr, "0", buf[0]);
658- prevpos = ftell(f);
659-#endif
660- continue;
661- }
662-
663- if (buf[0] != ',') {
664- /*
665- * Not a valid start character; ignore it.
666- */
667-#ifdef TKANIM_DEBUG
668- fprintf(stderr, "?(%c)", buf[0]);
669- prevpos = ftell(f);
670-#endif
671- continue;
672- }
673-
674- if (fread(buf, 1, 9, f) != 9) {
675- Tcl_AppendResult( interp,
676- "couldn't read left/top/width/height in GIF image", NULL );
677-/*
678- interp->result = "couldn't read left/top/width/height in GIF image";
679-*/
680- goto error;
681- }
682-
683- useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP);
684-
685- bitPixel = 1<<((buf[8]&0x07)+1);
686-
687- imageLeftPos= LM_to_uint(buf[0], buf[1]);
688- imageTopPos= LM_to_uint(buf[2], buf[3]);
689- imageWidth= LM_to_uint(buf[4], buf[5]);
690- imageHeight= LM_to_uint(buf[6], buf[7]);
691-
692- block.width = imageWidth;
693- block.height = imageHeight;
694- block.pixelSize = 3;
695- block.pitch = 3 * imageWidth;
696- block.offset[0] = 0;
697- block.offset[1] = 1;
698- block.offset[2] = 2;
699- block.offset[3] = 3;
700- nBytes = imageHeight * block.pitch;
701- block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes);
702-
703- sprintf(widthbuf, "%d", imageWidth);
704- sprintf(heightbuf, "%d", imageHeight);
705-
706- /* save result */
707-
708- {
709-#if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1)
710- Tcl_Obj *argv[7];
711- int i;
712-
713- argv[0] = Tcl_NewStringObj("image", -1);
714- argv[1] = Tcl_NewStringObj("create", -1);
715- argv[2] = Tcl_NewStringObj("photo", -1);
716- argv[3] = Tcl_NewStringObj("-width", -1);
717- argv[4] = Tcl_NewStringObj(widthbuf, -1);
718- argv[5] = Tcl_NewStringObj("-height", -1);
719- argv[6] = Tcl_NewStringObj(heightbuf, -1);
720-
721- for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); }
722-
723- if( Tk_ImageObjCmd((ClientData) winPtr, interp,
724- /* "image create photo -width <imageWidth>
725- -height <imageHeight>" */
726- 7, argv) == TCL_ERROR ){
727- return TCL_ERROR;
728- }
729-
730- for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); }
731-
732-#else
733- char *argv[7] = {"image", "create", "photo", "-width", NULL,
734- "-height", NULL};
735- argv[4] = widthbuf;
736- argv[6] = heightbuf;
737-#ifdef TKANIM_DEBUG
738- fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)",
739- argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]);
740-#endif
741- if( Tk_ImageCmd((ClientData) winPtr, interp,
742- /* "image create photo -width <imageWidth>
743- -height <imageHeight>" */
744- 7, argv) == TCL_ERROR ){
745- return TCL_ERROR;
746- }
747-#endif
748-
749-#ifdef TKANIM_DEBUG
750- fprintf(stderr, " done ");
751-#endif
752- }
753-
754- imageName = interp->result;
755-#if (TK_MAJOR_VERSION < 8)
756- photoHandle = Tk_FindPhoto(interp->result);
757-#else
758- photoHandle = Tk_FindPhoto(interp, interp->result);
759-#endif
760- if (!useGlobalColormap) {
761- if (!ReadColorMap(f, bitPixel, localColorMap)) {
762- Tcl_AppendResult(interp, "error reading color map",
763- (char *) NULL);
764- goto error;
765- }
766- if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
767- imageHeight, localColorMap, BitSet(buf[8], INTERLACE),
768- transparent) != TCL_OK) {
769- goto error;
770- }
771- } else {
772- if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
773- imageHeight, colorMap, BitSet(buf[8], INTERLACE),
774- transparent) != TCL_OK) {
775- goto error;
776- }
777- }
778- Tk_PhotoPutBlock(
779-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8)
780- NULL,
781-#endif
782-photoHandle, &block, 0, 0, imageWidth, imageHeight
783-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8)
784- , TK_PHOTO_COMPOSITE_SET
785-#endif
786- );
787-#ifdef TKANIM_DEBUG
788- fprintf(stderr, " Retrieving result\n");
789-#endif
790- /* retrieve result */
791- sprintf(newresbuf, "{%s %d %d %d %d %d} ",
792- imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos,
793- delay);
794-#ifdef TKANIM_DEBUG
795- fprintf(stderr, " newresbuf = %s\n", newresbuf);
796-#endif
797- ckfree((char *) block.pixelPtr);
798-#ifdef TKANIM_DEBUG
799- fprintf(stderr, " free done (now append result)");
800-#endif
801- Tcl_DStringAppend( &resultbuf, newresbuf, -1 );
802-#ifdef TKANIM_DEBUG
803- fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos);
804- prevpos = ftell(f);
805-#endif
806- }
807- sprintf( widthbuf, "%d", loop );
808- Tcl_DStringAppend( &resultbuf, "} ", -1 );
809- resultptr = Tcl_DStringAppend( &resultbuf, widthbuf, -1 );
810-#ifdef TKANIM_DEBUG
811- fprintf(stderr, "\nResult = %s\n", resultptr);
812-#endif
813- Tcl_ResetResult(interp);
814- Tcl_AppendResult(interp, resultptr, NULL);
815- Tcl_DStringFree(&resultbuf);
816- return TCL_OK;
817-
818- error:
819- Tcl_DStringFree(&resultbuf);
820- ckfree((char *) block.pixelPtr);
821- return TCL_ERROR;
822-
823-}
824-
825-static int
826-DoExtension(fd, label, transparent, delay, loop)
827-FILE *fd;
828-int label;
829-int *transparent;
830-int *delay;
831-int *loop;
832-{
833- static unsigned char buf[256];
834- int count = 0;
835-
836- switch (label) {
837- case 0x01: /* Plain Text Extension */
838- break;
839-
840- case 0xff: /* Application Extension */
841- count = GetDataBlock(fd, (unsigned char*) buf);
842- if( count < 0){
843- return 1;
844- }
845- if( !strncmp (buf, "NETSCAPE", 8) ) {
846- /* we ignore check of "2.0" */
847- count = GetDataBlock (fd, (unsigned char*) buf);
848- if( count < 0){
849- return 1;
850- }
851- if( buf[0] != 1 ){
852- fprintf(stderr, "??? %d", buf[0]);
853- }
854- *loop = LM_to_uint(buf[1], buf[2]);
855- }
856- do {
857- count = GetDataBlock(fd, (unsigned char*) buf);
858- } while (count > 0);
859- return count;
860- break;
861-
862- case 0xfe: /* Comment Extension */
863- do {
864- count = GetDataBlock(fd, (unsigned char*) buf);
865- } while (count > 0);
866- return count;
867-
868- case 0xf9: /* Graphic Control Extension */
869- count = GetDataBlock(fd, (unsigned char*) buf);
870- if (count < 0) {
871- return 1;
872- }
873- if ((buf[0] & 0x1) != 0) {
874- *transparent = buf[3];
875- }
876-
877- /* Delay time */
878- *delay = LM_to_uint(buf[1],buf[2]);
879-
880- do {
881- count = GetDataBlock(fd, (unsigned char*) buf);
882- } while (count > 0);
883- return count;
884- }
885-
886- do {
887- count = GetDataBlock(fd, (unsigned char*) buf);
888- } while (count > 0);
889- return count;
890-}
891-
892-/*
893- *----------------------------------------------------------------------
894- *
895- * ReadGIFHeader --
896- *
897- * This procedure reads the GIF header from the beginning of a
898- * GIF file and returns the dimensions of the image.
899- *
900- * Results:
901- * The return value is 1 if file "f" appears to start with
902- * a valid GIF header, 0 otherwise. If the header is valid,
903- * then *widthPtr and *heightPtr are modified to hold the
904- * dimensions of the image.
905- *
906- * Side effects:
907- * The access position in f advances.
908- *
909- *----------------------------------------------------------------------
910- */
911-
912-static int
913-ReadGIFHeader(f, widthPtr, heightPtr)
914- FILE *f; /* Image file to read the header from */
915- int *widthPtr, *heightPtr; /* The dimensions of the image are
916- * returned here. */
917-{
918- unsigned char buf[7];
919-
920- if ((fread(buf, 1, 6, f) != 6)
921- || ((strncmp("GIF87a", (char *) buf, 6) != 0)
922- && (strncmp("GIF89a", (char *) buf, 6) != 0))) {
923- return 0;
924- }
925-
926- if (fread(buf, 1, 4, f) != 4) {
927- return 0;
928- }
929-
930- *widthPtr = LM_to_uint(buf[0],buf[1]);
931- *heightPtr = LM_to_uint(buf[2],buf[3]);
932- return 1;
933-}
934-
935-/*
936- *-----------------------------------------------------------------
937- * The code below is copied from the giftoppm program and modified
938- * just slightly.
939- *-----------------------------------------------------------------
940- */
941-
942-static int
943-ReadColorMap(fd,number,buffer)
944-FILE *fd;
945-int number;
946-unsigned char buffer[3][MAXCOLORMAPSIZE];
947-{
948- int i;
949- unsigned char rgb[3];
950-
951- for (i = 0; i < number; ++i) {
952- if (! ReadOK(fd, rgb, sizeof(rgb)))
953- return 0;
954-
955- buffer[CM_RED][i] = rgb[0] ;
956- buffer[CM_GREEN][i] = rgb[1] ;
957- buffer[CM_BLUE][i] = rgb[2] ;
958- }
959- return 1;
960-}
961-
962-
963-
964-static int ZeroDataBlock = 0;
965-
966-static int
967-GetDataBlock(fd, buf)
968-FILE *fd;
969-unsigned char *buf;
970-{
971- unsigned char count;
972-
973- if (! ReadOK(fd,&count,1)) {
974- return -1;
975- }
976-
977- ZeroDataBlock = count == 0;
978-
979- if ((count != 0) && (! ReadOK(fd, buf, count))) {
980- return -1;
981- }
982-
983- return count;
984-}
985-
986-
987-static int
988-ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent)
989-Tcl_Interp *interp;
990-char *imagePtr;
991-FILE *fd;
992-int len, height;
993-unsigned char cmap[3][MAXCOLORMAPSIZE];
994-int interlace;
995-int transparent;
996-{
997- unsigned char c;
998- int v;
999- int xpos = 0, ypos = 0, pass = 0;
1000- char *colStr;
1001-
1002-
1003- /*
1004- * Initialize the Compression routines
1005- */
1006- if (! ReadOK(fd,&c,1)) {
1007- Tcl_AppendResult(interp, "error reading GIF image: ",
1008- Tcl_PosixError(interp), (char *) NULL);
1009- return TCL_ERROR;
1010- }
1011-
1012- if (LWZReadByte(fd, 1, c) < 0) {
1013- interp->result = "format error in GIF image";
1014- return TCL_ERROR;
1015- }
1016-
1017- if (transparent!=-1 &&
1018- (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) {
1019- XColor *colorPtr;
1020- colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp),
1021- Tk_GetUid(colStr));
1022- if (colorPtr) {
1023-/*
1024- printf("color is %d %d %d\n",
1025- colorPtr->red >> 8,
1026- colorPtr->green >> 8,
1027- colorPtr->blue >> 8);
1028-*/
1029- cmap[CM_RED][transparent] = colorPtr->red >> 8;
1030- cmap[CM_GREEN][transparent] = colorPtr->green >> 8;
1031- cmap[CM_BLUE][transparent] = colorPtr->blue >> 8;
1032- Tk_FreeColor(colorPtr);
1033- }
1034- }
1035-
1036- while ((v = LWZReadByte(fd,0,c)) >= 0 ) {
1037-
1038- imagePtr[ (xpos*3) + (ypos *len*3)] = cmap[CM_RED][v];
1039- imagePtr[ (xpos*3) + (ypos *len*3) +1] = cmap[CM_GREEN][v];
1040- imagePtr[ (xpos*3) + (ypos *len*3) +2] = cmap[CM_BLUE][v];
1041-
1042- ++xpos;
1043- if (xpos == len) {
1044- xpos = 0;
1045- if (interlace) {
1046- switch (pass) {
1047- case 0:
1048- case 1:
1049- ypos += 8; break;
1050- case 2:
1051- ypos += 4; break;
1052- case 3:
1053- ypos += 2; break;
1054- }
1055-
1056- if (ypos >= height) {
1057- ++pass;
1058- switch (pass) {
1059- case 1:
1060- ypos = 4; break;
1061- case 2:
1062- ypos = 2; break;
1063- case 3:
1064- ypos = 1; break;
1065- default:
1066- return TCL_OK;
1067- }
1068- }
1069- } else {
1070- ++ypos;
1071- }
1072- }
1073- if (ypos >= height)
1074- break;
1075- }
1076- return TCL_OK;
1077-}
1078-
1079-static int
1080-LWZReadByte(fd, flag, input_code_size)
1081-FILE *fd;
1082-int flag;
1083-int input_code_size;
1084-{
1085- static int fresh = 0;
1086- int code, incode;
1087- static int code_size, set_code_size;
1088- static int max_code, max_code_size;
1089- static int firstcode, oldcode;
1090- static int clear_code, end_code;
1091- static int table[2][(1<< MAX_LWZ_BITS)];
1092- static int stack[(1<<(MAX_LWZ_BITS))*2], *sp;
1093- register int i;
1094-
1095-
1096- if (flag) {
1097-
1098- set_code_size = input_code_size;
1099- code_size = set_code_size+1;
1100- clear_code = 1 << set_code_size ;
1101- end_code = clear_code + 1;
1102- max_code_size = 2*clear_code;
1103- max_code = clear_code+2;
1104-
1105- GetCode(fd, 0, 1);
1106-
1107- fresh = 1;
1108-
1109- for (i = 0; i < clear_code; ++i) {
1110- table[0][i] = 0;
1111- table[1][i] = i;
1112- }
1113- for (; i < (1<<MAX_LWZ_BITS); ++i) {
1114- table[0][i] = table[1][0] = 0;
1115- }
1116-
1117- sp = stack;
1118-
1119- return 0;
1120-
1121- } else if (fresh) {
1122-
1123- fresh = 0;
1124- do {
1125- firstcode = oldcode = GetCode(fd, code_size, 0);
1126- } while (firstcode == clear_code);
1127- return firstcode;
1128- }
1129-
1130- if (sp > stack)
1131- return *--sp;
1132-
1133- while ((code = GetCode(fd, code_size, 0)) >= 0) {
1134- if (code == clear_code) {
1135- for (i = 0; i < clear_code; ++i) {
1136- table[0][i] = 0;
1137- table[1][i] = i;
1138- }
1139-
1140- for (; i < (1<<MAX_LWZ_BITS); ++i) {
1141- table[0][i] = table[1][i] = 0;
1142- }
1143-
1144- code_size = set_code_size+1;
1145- max_code_size = 2*clear_code;
1146- max_code = clear_code+2;
1147- sp = stack;
1148- firstcode = oldcode = GetCode(fd, code_size, 0);
1149- return firstcode;
1150-
1151- } else if (code == end_code) {
1152- int count;
1153- unsigned char buf[260];
1154-
1155- if (ZeroDataBlock)
1156- return -2;
1157-
1158- while ((count = GetDataBlock(fd, buf)) > 0)
1159- ;
1160-
1161- if (count != 0)
1162- return -2;
1163- }
1164-
1165- incode = code;
1166-
1167- if (code >= max_code) {
1168- *sp++ = firstcode;
1169- code = oldcode;
1170- }
1171-
1172- while (code >= clear_code) {
1173- *sp++ = table[1][code];
1174- if (code == table[0][code]) {
1175- return -2;
1176-
1177- fprintf(stderr, "circular table entry BIG ERROR\n");
1178- /*
1179- * Used to be this instead, Steve Ball suggested
1180- * the change to just return.
1181-
1182- printf("circular table entry BIG ERROR\n");
1183- */
1184- }
1185- code = table[0][code];
1186- }
1187-
1188- *sp++ = firstcode = table[1][code];
1189-
1190- if ((code = max_code) <(1<<MAX_LWZ_BITS)) {
1191-
1192- table[0][code] = oldcode;
1193- table[1][code] = firstcode;
1194- ++max_code;
1195- if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) {
1196- max_code_size *= 2;
1197- ++code_size;
1198- }
1199- }
1200-
1201- oldcode = incode;
1202-
1203- if (sp > stack)
1204- return *--sp;
1205- }
1206- return code;
1207-}
1208-
1209-
1210-static int
1211-GetCode(fd, code_size, flag)
1212-FILE *fd;
1213-int code_size;
1214-int flag;
1215-{
1216- static unsigned char buf[280];
1217- static int curbit, lastbit, done, last_byte;
1218- int i, j, ret;
1219- unsigned char count;
1220-
1221- if (flag) {
1222- curbit = 0;
1223- lastbit = 0;
1224- done = 0;
1225- return 0;
1226- }
1227-
1228-
1229- if ( (curbit+code_size) >= lastbit) {
1230- if (done) {
1231- /* ran off the end of my bits */
1232- return -1;
1233- }
1234- buf[0] = buf[last_byte-2];
1235- buf[1] = buf[last_byte-1];
1236-
1237- if ((count = GetDataBlock(fd, &buf[2])) == 0)
1238- done = 1;
1239-
1240- last_byte = 2 + count;
1241- curbit = (curbit - lastbit) + 16;
1242- lastbit = (2+count)*8 ;
1243- }
1244-
1245- ret = 0;
1246- for (i = curbit, j = 0; j < code_size; ++i, ++j)
1247- ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j;
1248-
1249-
1250- curbit += code_size;
1251-
1252- return ret;
1253-}
1254-
1255-int Tk_AnimationCmd(clientData, interp, argc, argv)
1256- ClientData clientData; /* Main window associated with interpreter. */
1257- Tcl_Interp *interp; /* Current interpreter. */
1258- int argc; /* Number of arguments. */
1259- char **argv; /* Argument strings. */
1260-{
1261- char c;
1262- int length;
1263-
1264- if (argc < 2) {
1265- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1266- " option ?arg arg ...?\"", (char *) NULL);
1267- return TCL_ERROR;
1268- }
1269- c = argv[1][0];
1270- length = strlen(argv[1]);
1271- if((c == 'c') && (length >= 2)
1272- && (strncmp(argv[1], "create", length) == 0)) {
1273-
1274- char * realFileName;
1275- Tcl_DString buffer;
1276- FILE *f;
1277-
1278-#ifdef TKANIM_DEBUG
1279- fprintf(stderr, "AnimationCmd => create ");
1280-#endif
1281-
1282- if ( argc != 3 ){
1283- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1284- " create GifFile\"", (char *) NULL);
1285- return TCL_ERROR;
1286- }
1287-#ifdef TKANIM_DEBUG
1288- fprintf(stderr, "\n\tRealFileName = ");
1289-#endif
1290- realFileName = Tcl_TranslateFileName(interp, argv[2],
1291- &buffer);
1292- if(realFileName == NULL) {
1293- Tcl_DStringFree(&buffer);
1294- return TCL_ERROR;
1295- }
1296-#ifdef TKANIM_DEBUG
1297- fprintf(stderr, "%s ", realFileName);
1298-#endif
1299-#ifdef TKANIM_DEBUG
1300- fprintf(stderr, "\n\tOpen ", realFileName);
1301-#endif
1302- f = fopen(realFileName, "rb");
1303- Tcl_DStringFree(&buffer);
1304- if (f == NULL ){
1305- Tcl_AppendResult(interp, "couldn't read image file \"",
1306- argv[2], "\": ", Tcl_PosixError(interp),
1307- (char *) NULL);
1308- return TCL_ERROR;
1309- }
1310-#ifdef TKANIM_DEBUG
1311- fprintf(stderr, "success ", realFileName);
1312-#endif
1313-#ifdef TKANIM_DEBUG
1314- fprintf(stderr, "\n\tRead ", realFileName);
1315-#endif
1316- if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){
1317-#ifdef TKANIM_DEBUG
1318- fprintf(stderr, "\n\tRead failed", realFileName);
1319-#endif
1320- return TCL_ERROR;
1321- }
1322- fclose(f);
1323-#ifdef TKANIM_DEBUG
1324- fprintf(stderr, "\n\tRead done", realFileName);
1325-#endif
1326-#ifdef TKANIM_DEBUG
1327- fprintf(stderr, "done\n");
1328-#endif
1329- }
1330- return TCL_OK;
1331-}
1332-
1333-void
1334-TkDeleteTkAnim(clientData)
1335- ClientData clientData;
1336-{
1337-#ifdef TKANIM_DEBUG
1338- fprintf(stderr, "TkDeleteTkAnim\n");
1339-#endif
1340-}
1341-
1342-int Tkanim_Init(interp)
1343- Tcl_Interp *interp;
1344-{
1345-#ifdef TKANIM_DEBUG
1346- fprintf(stderr, "Tkanim initialize...");
1347-#endif
1348- Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd,
1349- (ClientData) NULL,
1350- (Tcl_CmdDeleteProc *) TkDeleteTkAnim);
1351-#ifdef TKANIM_DEBUG
1352- fprintf(stderr, "done\n");
1353-#endif
1354- return Tcl_PkgProvide(interp, "Tkanim", TKANIM_VERSION );
1355-}
1356diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/tkAppInit.c
1357--- a/otherlibs/labltk/tkanim/tkAppInit.c Fri Mar 26 16:28:27 2010 +0900
1358+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
1359@@ -1,141 +0,0 @@
1360-/***********************************************************************/
1361-/* */
1362-/* MLTk, Tcl/Tk interface of Objective Caml */
1363-/* */
1364-/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
1365-/* projet Cristal, INRIA Rocquencourt */
1366-/* Jacques Garrigue, Kyoto University RIMS */
1367-/* */
1368-/* Copyright 2002 Institut National de Recherche en Informatique et */
1369-/* en Automatique and Kyoto University. All rights reserved. */
1370-/* This file is distributed under the terms of the GNU Library */
1371-/* General Public License, with the special exception on linking */
1372-/* described in file LICENSE found in the Objective Caml source tree. */
1373-/* */
1374-/***********************************************************************/
1375-/*
1376- * tkAppInit.c --
1377- *
1378- * Provides a default version of the Tcl_AppInit procedure for
1379- * use in wish and similar Tk-based applications.
1380- *
1381- * Copyright (c) 1993 The Regents of the University of California.
1382- * Copyright (c) 1994 Sun Microsystems, Inc.
1383- *
1384- * See the file "license.terms" for information on usage and redistribution
1385- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1386- */
1387-
1388-#ifndef lint
1389-static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24";
1390-#endif /* not lint */
1391-
1392-#include "tk.h"
1393-
1394-int Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp));
1395-
1396-/*
1397- * The following variable is a special hack that is needed in order for
1398- * Sun shared libraries to be used for Tcl.
1399- */
1400-
1401-extern int matherr();
1402-int *tclDummyMathPtr = (int *) matherr;
1403-
1404-#ifdef TK_TEST
1405-EXTERN int Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
1406-#endif /* TK_TEST */
1407-
1408-/*
1409- *----------------------------------------------------------------------
1410- *
1411- * main --
1412- *
1413- * This is the main program for the application.
1414- *
1415- * Results:
1416- * None: Tk_Main never returns here, so this procedure never
1417- * returns either.
1418- *
1419- * Side effects:
1420- * Whatever the application does.
1421- *
1422- *----------------------------------------------------------------------
1423- */
1424-
1425-int
1426-main(argc, argv)
1427- int argc; /* Number of command-line arguments. */
1428- char **argv; /* Values of command-line arguments. */
1429-{
1430- Tk_Main(argc, argv, Tcl_AppInit);
1431- return 0; /* Needed only to prevent compiler warning. */
1432-}
1433-
1434-/*
1435- *----------------------------------------------------------------------
1436- *
1437- * Tcl_AppInit --
1438- *
1439- * This procedure performs application-specific initialization.
1440- * Most applications, especially those that incorporate additional
1441- * packages, will have their own version of this procedure.
1442- *
1443- * Results:
1444- * Returns a standard Tcl completion code, and leaves an error
1445- * message in interp->result if an error occurs.
1446- *
1447- * Side effects:
1448- * Depends on the startup script.
1449- *
1450- *----------------------------------------------------------------------
1451- */
1452-
1453-int
1454-Tcl_AppInit(interp)
1455- Tcl_Interp *interp; /* Interpreter for application. */
1456-{
1457- if (Tcl_Init(interp) == TCL_ERROR) {
1458- return TCL_ERROR;
1459- }
1460- if (Tk_Init(interp) == TCL_ERROR) {
1461- return TCL_ERROR;
1462- }
1463- Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL);
1464-#ifdef TK_TEST
1465- if (Tktest_Init(interp) == TCL_ERROR) {
1466- return TCL_ERROR;
1467- }
1468-#endif /* TK_TEST */
1469-
1470-
1471- /*
1472- * Call the init procedures for included packages. Each call should
1473- * look like this:
1474- *
1475- * if (Mod_Init(interp) == TCL_ERROR) {
1476- * return TCL_ERROR;
1477- * }
1478- *
1479- * where "Mod" is the name of the module.
1480- */
1481-
1482- if (Tkanim_Init(interp) == TCL_ERROR) {
1483- return TCL_ERROR;
1484- }
1485-
1486- /*
1487- * Call Tcl_CreateCommand for application-specific commands, if
1488- * they weren't already created by the init procedures called above.
1489- */
1490-
1491- /*
1492- * Specify a user-specific startup file to invoke if the application
1493- * is run interactively. Typically the startup file is "~/.apprc"
1494- * where "app" is the name of the application. If this line is deleted
1495- * then no user-specific startup file will be run under any conditions.
1496- */
1497-
1498- Tcl_SetVar(interp, "tcl_rcFileName", "~/.tkanimationrc", TCL_GLOBAL_ONLY);
1499- return TCL_OK;
1500-}
1501diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/tkanim.ml
1502--- a/otherlibs/labltk/tkanim/tkanim.ml Fri Mar 26 16:28:27 2010 +0900
1503+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
1504@@ -1,230 +0,0 @@
1505-(***********************************************************************)
1506-(* *)
1507-(* MLTk, Tcl/Tk interface of Objective Caml *)
1508-(* *)
1509-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
1510-(* projet Cristal, INRIA Rocquencourt *)
1511-(* Jacques Garrigue, Kyoto University RIMS *)
1512-(* *)
1513-(* Copyright 2002 Institut National de Recherche en Informatique et *)
1514-(* en Automatique and Kyoto University. All rights reserved. *)
1515-(* This file is distributed under the terms of the GNU Library *)
1516-(* General Public License, with the special exception on linking *)
1517-(* described in file LICENSE found in the Objective Caml source tree. *)
1518-(* *)
1519-(***********************************************************************)
1520-open Camltk
1521-open Widget
1522-open Support
1523-open Protocol
1524-open Tkintf
1525-
1526-external init : unit -> unit = "tkanim_init"
1527-
1528-type gifFrame = {
1529- imagephoto : imagePhoto;
1530- frameWidth : int;
1531- frameHeight : int;
1532- left : int;
1533- top : int;
1534- delay : int
1535- }
1536-
1537-type animatedGif = {
1538- frames : gifFrame list;
1539- animWidth : int;
1540- animHeight : int;
1541- loop : int
1542-}
1543-
1544-type imageType =
1545- | Still of Tk.options
1546- | Animated of animatedGif
1547-
1548-let debug = ref false
1549-
1550-let cTKtoCAMLgifFrame s =
1551- match splitlist s with
1552- | [photo; width; height; left; top; delay] ->
1553- {imagephoto = cTKtoCAMLimagePhoto photo;
1554- frameWidth = int_of_string width;
1555- frameHeight = int_of_string height;
1556- left = int_of_string left;
1557- top = int_of_string top;
1558- delay = int_of_string delay}
1559- | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
1560-
1561-let cTKtoCAMLanimatedGif s =
1562- match splitlist s with
1563- | [width; height; frames; loop] ->
1564- {frames = List.map cTKtoCAMLgifFrame (splitlist frames);
1565- animWidth = int_of_string width;
1566- animHeight = int_of_string height;
1567- loop = int_of_string loop}
1568- | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
1569-
1570-(* check Tkanim package is in the interpreter *)
1571-let available () =
1572- let packages =
1573- splitlist (Protocol.tkEval [| TkToken "package";
1574- TkToken "names" |])
1575- in
1576- List.mem "Tkanim" packages
1577-
1578-let create file =
1579- let s =
1580- Protocol.tkEval [| TkToken "animation";
1581- TkToken "create";
1582- TkToken file |]
1583- in
1584- let anmgif = cTKtoCAMLanimatedGif s in
1585- match anmgif.frames with
1586- | [] -> raise (TkError "Null frame in a gif ?")
1587- | [x] -> Still (ImagePhoto x.imagephoto)
1588- | _ -> Animated anmgif
1589-
1590-let delete anim =
1591- List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames
1592-
1593-let width anm = anm.animWidth
1594-let height anm = anm.animHeight
1595-let images anm = List.map (fun x -> x.imagephoto) anm.frames
1596-
1597-let image_existence_check img =
1598- (* I found there is a bug in Tk (even v8.0a2). *)
1599- (* We can copy from deleted images, Tk never says "it doesn't exist", *)
1600- (* But just do some operation. And sometimes it causes Seg-fault. *)
1601- (* So, before using Imagephoto.copy, I should check the source image *)
1602- (* really exists. *)
1603- try ignore (Imagephoto.height img) with
1604- TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
1605-
1606-let imagephoto_copy dst src opts =
1607- image_existence_check src;
1608- Imagephoto.copy dst src opts
1609-
1610-let animate_gen w i anim =
1611- let length = List.length anim.frames in
1612- let frames = Array.of_list anim.frames in
1613- let current = ref 0 in
1614- let loop = ref anim.loop in
1615- let f = frames.(!current) in
1616- imagephoto_copy i f.imagephoto
1617- [ImgTo (f.left, f.top, f.left + f.frameWidth,
1618- f.top + f.frameHeight)];
1619- let visible = ref true in
1620- let animated = ref false in
1621- let timer = ref None in
1622- (* Loop *)
1623- let display_current () =
1624- let f = frames.(!current) in
1625- imagephoto_copy i f.imagephoto
1626- [ImgTo (f.left, f.top,
1627- f.left + f.frameWidth, f.top + f.frameHeight)]
1628- in
1629- let rec tick () =
1630- if not (Winfo.exists w && Winfo.viewable w) then begin
1631- (* the widget is invisible. stop animation for efficiency *)
1632- if !debug then prerr_endline "Stopped (Visibility)";
1633- visible := false;
1634- end else
1635- begin
1636- display_current ();
1637- let t =
1638- Timer.add (if f.delay = 0 then 100 else f.delay * 10)
1639- (fun () ->
1640- incr current;
1641- if !current = length then begin
1642- current := 0;
1643- (* loop check *)
1644- if !loop > 1 then begin
1645- decr loop;
1646- if !loop = 0 then begin
1647- if !debug then prerr_endline "Loop end";
1648- (* stop *)
1649- loop := anim.loop;
1650- timer := None
1651- end
1652- end
1653- end;
1654- tick ())
1655- in
1656- timer := Some t
1657- end
1658- in
1659- let start () =
1660- animated := true;
1661- tick ()
1662- in
1663- let stop () =
1664- match !timer with
1665- | Some t ->
1666- Timer.remove t;
1667- timer := None;
1668- animated := false
1669- | None -> ()
1670- in
1671- let next () =
1672- if !timer = None then begin
1673- incr current;
1674- if !current = length then current := 0;
1675- display_current ()
1676- end
1677- in
1678- (* We shouldn't delete the animation here. *)
1679-(*
1680- bind w [[], Destroy]
1681- (BindSet ([], (fun _ -> Imagephoto.delete i)));
1682-*)
1683- bind w [[], Visibility]
1684- (BindSet ([], (fun _ ->
1685- if not !visible then begin
1686- visible := true;
1687- if !animated then start ()
1688- end)));
1689- (function
1690- | false ->
1691- if !animated then stop () else start ()
1692- | true -> next ())
1693-
1694-let animate label anim =
1695- (* prerr_endline "animate"; *)
1696- let i = Imagephoto.create [Width (Pixels anim.animWidth);
1697- Height (Pixels anim.animHeight)]
1698- in
1699- bind label [[], Destroy] (BindExtend ([], (fun _ ->
1700- Imagephoto.delete i)));
1701- Label.configure label [ImagePhoto i];
1702- animate_gen label i anim
1703-
1704-let animate_canvas_item canvas tag anim =
1705-(* prerr_endline "animate"; *)
1706- let i = Imagephoto.create [Width (Pixels anim.animWidth);
1707- Height (Pixels anim.animHeight)]
1708- in
1709- bind canvas [[], Destroy] (BindExtend ([], (fun _ ->
1710- Imagephoto.delete i)));
1711- Canvas.configure_image canvas tag [ImagePhoto i];
1712- animate_gen canvas i anim
1713-
1714-let gifdata s =
1715- let tmp_dir = ref Filename.temp_dir_name in
1716- let mktemp =
1717- let cnter = ref 0
1718- and pid = Unix.getpid() in
1719- (function prefx ->
1720- incr cnter;
1721- (Filename.concat !tmp_dir
1722- (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter)))
1723- in
1724- let fname = mktemp "gifdata" in
1725- let oc = open_out_bin fname in
1726- try
1727- output_string oc s;
1728- close_out oc;
1729- let anim = create fname in
1730- Unix.unlink fname;
1731- anim
1732- with
1733- e -> begin Unix.unlink fname; raise e end
1734-
1735diff -r 524b3b7c53ef -r 3deca3fd8e88 otherlibs/labltk/tkanim/tkanim.mli
1736--- a/otherlibs/labltk/tkanim/tkanim.mli Fri Mar 26 16:28:27 2010 +0900
1737+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
1738@@ -1,95 +0,0 @@
1739-(***********************************************************************)
1740-(* *)
1741-(* MLTk, Tcl/Tk interface of Objective Caml *)
1742-(* *)
1743-(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
1744-(* projet Cristal, INRIA Rocquencourt *)
1745-(* Jacques Garrigue, Kyoto University RIMS *)
1746-(* *)
1747-(* Copyright 2002 Institut National de Recherche en Informatique et *)
1748-(* en Automatique and Kyoto University. All rights reserved. *)
1749-(* This file is distributed under the terms of the GNU Library *)
1750-(* General Public License, with the special exception on linking *)
1751-(* described in file LICENSE found in the Objective Caml source tree. *)
1752-(* *)
1753-(***********************************************************************)
1754-open Camltk
1755-open Widget
1756-open Support
1757-
1758-(*** Data types ***)
1759-
1760-type animatedGif
1761-
1762- (* This data type contains all the information of an animation of
1763- gif89a format. It is still test implementation, so I should
1764- keep it abstract. --- JPF *)
1765-
1766-type imageType =
1767- | Still of Tk.options
1768- | Animated of animatedGif
1769-
1770- (* This data type is required to distinguish normal still images
1771- and animated gifs. Usually objects typed imagePhoto or
1772- imageBitmap are used for Still. *)
1773-
1774-(*** Flags ***)
1775-
1776-val debug : bool ref
1777-
1778-(*** Library availability check ***)
1779-
1780-val init : unit -> unit
1781-
1782- (* This function calls the initialization function for Tkanim
1783- Tcl/Tk extension. *)
1784-
1785-val available : unit -> bool
1786-
1787- (* [available ()] returns true if there is Tkanim Tcl/Tk
1788- extension linked statically/dynamically in Tcl/Tk
1789- interpreter. Otherwise, return false. *)
1790-
1791-(*** User interface ***)
1792-
1793-(* create is unsafe *)
1794-val create : string -> imageType
1795-
1796- (* [create file] loads a gif87 or gif89 image file and parse it,
1797- and returns [Animated animated_gif] if the image file has
1798- more than one images. Otherwise, it returns
1799- [Still (ImagePhoto image_photo)] *)
1800-
1801-val delete : animatedGif -> unit
1802-
1803- (* [delete anim] deletes all the images in anim. Usually
1804- animatedGifs contain many images, so you must not forget to
1805- use this function to free the memory. *)
1806-
1807-val width : animatedGif -> int
1808-val height : animatedGif -> int
1809- (* [width anim] and [height anim] return the width and height of
1810- given animated gif. *)
1811-
1812-val images : animatedGif -> imagePhoto list
1813- (* [images anim] returns the list of still images used in the
1814- animation *)
1815-
1816-val animate : widget -> animatedGif -> bool -> unit
1817-val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit
1818- (* The display functions for animated gifs. Since [animatedGif] is
1819- an abstract type, you must use those functions to display
1820- [animatedGif] images.
1821- [animate label anim] and [animate_canvas_item canvas tag anim]
1822- display animation [anim] on a label widget [label] or an
1823- image tag [tag] on a canvas widget [canvas] respectively.
1824-
1825- Note that animation is stopped by default.
1826- These functions return interface functions, say, [inter :
1827- bool -> unit]. Currently, [inter false] toggles start/stop of
1828- the animation, and [inter true] displays the next frame of
1829- the animation if the animation is stopped. *)
1830-
1831-val gifdata : string -> imageType
1832- (* [gifdata data] reads [data] as a row data of a gif file and
1833- decodes it. *)