Commits

camlspotter committed 3deca3f

labltk interp->result => Tcl_GetStringResult(interp)

  • Participants
  • Parent commits 524b3b7
  • Branches tcltk86

Comments (0)

Files changed (23)

File otherlibs/labltk/Makefile

 # Top Makefile for mlTk
 
-SUBDIRS=compiler support lib jpf frx tkanim examples_labltk \
+SUBDIRS=compiler support lib jpf frx examples_labltk \
 	examples_camltk browser
 SUBDIRS_GENERATED=camltk labltk
 
 	cd lib; $(MAKE)
 	cd jpf; $(MAKE)
 	cd frx; $(MAKE)
-	cd tkanim; $(MAKE)
 	cd browser; $(MAKE)
 
 allopt:
 	cd lib; $(MAKE) opt
 	cd jpf; $(MAKE) opt
 	cd frx; $(MAKE) opt
-	cd tkanim; $(MAKE) opt
 
 byte: all
 opt: allopt
 	cd compiler; $(MAKE) install
 	cd jpf; $(MAKE) install
 	cd frx; $(MAKE) install
-	cd tkanim; $(MAKE) install
 	cd browser; $(MAKE) install
 
 installopt:
 	cd camltk; $(MAKE) installopt
 	cd jpf; $(MAKE) installopt
 	cd frx; $(MAKE) installopt
-	cd tkanim; $(MAKE) installopt
 
 partialclean clean: 
 	for d in $(SUBDIRS); do \

File otherlibs/labltk/examples_camltk/eyes.ml

   pack [fw] [];
   let c = Canvas.create fw [Width (Pixels 200); Height (Pixels 200)] in
   let create_eye cx cy wx wy ewx ewy bnd =
-    let o2 =
+    let _o2 =
        Canvas.create_oval c
         (Pixels (cx - wx)) (Pixels (cy - wy))
         (Pixels (cx + wx)) (Pixels (cy + wy))

File otherlibs/labltk/examples_camltk/tetris.ml

   let scorev = Textvariable.create ()
   and linev = Textvariable.create ()
   and levv = Textvariable.create ()
-  and namev = Textvariable.create ()
   in
   let f = Frame.create fw [BorderWidth (Pixels 2)] in
   let c = Canvas.create f [Width (Pixels (block_size * 10));

File otherlibs/labltk/support/camltk.h

 #define CONST84
 #endif
 
+/* if Tcl_GetStringResult is not defined, we use interp->result */
+#ifndef Tcl_GetStringResult
+#  define Tcl_GetStringResult(interp) (interp->result)
+#endif
+
 /* cltkMisc.c */
 /* copy a Caml string to the C heap. Must be deallocated with stat_free */
 extern char *string_to_c(value s);

File otherlibs/labltk/support/cltkDMain.c

       if (0 == access(f,R_OK))
         if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
           stat_free(f);
-          tk_error(cltclinterp->result);
+          tk_error(Tcl_GetStringResult(cltclinterp));
         };
       stat_free(f);
     }

File otherlibs/labltk/support/cltkEval.c

 
   switch (code) {
   case TCL_OK:
-    return tcl_string_to_caml(cltclinterp->result);
+    return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp));
   case TCL_ERROR:
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
     tk_error("bad tcl result");
   }
 
   switch (result) {
   case TCL_OK:
-    return tcl_string_to_caml (cltclinterp->result);
+    return tcl_string_to_caml (Tcl_GetStringResult(cltclinterp));
   case TCL_ERROR:
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
     tk_error("bad tcl result");
   }

File otherlibs/labltk/support/cltkMain.c

     }
 
     if (Tcl_Init(cltclinterp) != TCL_OK)
-      tk_error(cltclinterp->result);
+      tk_error(Tcl_GetStringResult(cltclinterp));
     Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
 
     { /* Sets argv */
       }
     }
     if (Tk_Init(cltclinterp) != TCL_OK)
-      tk_error(cltclinterp->result);
+      tk_error(Tcl_GetStringResult(cltclinterp));
 
     /* Retrieve the main window */
     cltk_mainWindow = Tk_MainWindow(cltclinterp);
 
     if (NULL == cltk_mainWindow)
-      tk_error(cltclinterp->result);
+      tk_error(Tcl_GetStringResult(cltclinterp));
 
     Tk_GeometryRequest(cltk_mainWindow,200,200);
   }
       if (0 == access(f,R_OK))
         if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
           stat_free(f);
-          tk_error(cltclinterp->result);
+          tk_error(Tcl_GetStringResult(cltclinterp));
         };
       stat_free(f);
     }

File otherlibs/labltk/support/cltkMisc.c

   case TCL_ERROR:
   default:
     stat_free( utf );
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   }
 }
 

File otherlibs/labltk/support/cltkVar.c

   stat_free(stable_var);
 
   if (s == NULL)
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   else 
     return(tcl_string_to_caml(s));
 }
   stat_free(utf_contents);
 
   if (s == NULL)
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   else 
     return(Val_unit);
 }
                    (ClientData) (Long_val(cbid)))
                    != TCL_OK) {
     stat_free(cvar);
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   };
   stat_free(cvar);
   return Val_unit;

File otherlibs/labltk/support/cltkWait.c

   vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
   if (vis -> win == NULL) {
     stat_free((char *)vis);
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   };
   vis->cbid = Int_val(cbid);
   Tk_CreateEventHandler(vis->win, VisibilityChangeMask,
   vis->win = Tk_NameToWindow(cltclinterp, String_val(win), cltk_mainWindow);
   if (vis -> win == NULL) {
     stat_free((char *)vis);
-    tk_error(cltclinterp->result);
+    tk_error(Tcl_GetStringResult(cltclinterp));
   };
   vis->cbid = Int_val(cbid);
   Tk_CreateEventHandler(vis->win, StructureNotifyMask,

File otherlibs/labltk/tkanim/.cvsignore

-gifanimtest
-gifanimtest-static
-*.so
-*.a

File otherlibs/labltk/tkanim/.depend

-tkanim.cmo: tkanim.cmi 
-tkanim.cmx: tkanim.cmi 

File otherlibs/labltk/tkanim/Makefile

-# tkAnimGIF.c used the function Tk_ImageObjCmd, which is not available
-# in a plain Tk installation. Should we disable this subdirectory ?
-
-include ../support/Makefile.common
-
-COMPFLAGS=-I ../support -I ../camltk -I ../../unix -I ../../win32unix
-CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS)
-
-all: tkanim.cma libtkanim.$(A)
-opt: tkanim.cmxa libtkanim.$(A)
-example: gifanimtest$(EXE)
-
-OBJS=tkanim.cmo
-COBJS= cltkaniminit.$(O) tkAnimGIF.$(O)
-
-tkanim.cma: $(OBJS)
-	$(MKLIB) -ocamlc '$(CAMLCB)' -o tkanim $(OBJS)
-
-tkanim.cmxa: $(OBJS:.cmo=.cmx)
-	$(MKLIB) -ocamlopt '$(CAMLOPTB)' -o tkanim $(OBJS:.cmo=.cmx)
-
-libtkanim.$(A): $(COBJS)
-	$(MKLIB) -o tkanim $(COBJS)
-
-gifanimtest-static$(EXE): all gifanimtest.cmo
-	$(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo
-
-# dynamic loading
-gifanimtest$(EXE): all gifanimtest.cmo
-	$(CAMLC) -o $@ -I ../lib -I ../support  -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo
-
-#animwish: $(TKANIM_LIB) tkAppInit.o
-#	$(CC) -o $@  tkAppInit.o $(TK_LINK) $(X11_LINK) \
-#		-L. -ltkanim $(LIBS)
-
-$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma
-
-$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa
-
-clean:
-	rm -f *.cm* *.$(O) *.$(A) dlltkanim$(EXT_DLL) gifanimtest$(EXE) gifanimtest-static$(EXE)
-
-.SUFFIXES :
-.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(O)
-
-.mli.cmi:
-	$(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmo:
-	$(CAMLCOMP) $(COMPFLAGS) $<
-
-.ml.cmx:
-	$(CAMLOPT) -c $(COMPFLAGS) $<
-
-.c.$(O):
-	$(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
-
-
-install:
-	cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR)
-	if [ -f dlltkanim$(EXT_DLL) ]; then \
-		cp dlltkanim$(EXT_DLL) $(STUBLIBDIR)/; \
-	fi
-
-installopt:
-	cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR)
-
-depend: tkanim.ml
-	$(CAMLDEP) *.mli *.ml > .depend
-
-include .depend

File otherlibs/labltk/tkanim/Makefile.nt

-include Makefile

File otherlibs/labltk/tkanim/README

-This ML code is an interface for Tkanim Tcl/Tk extension. Unfortunately
-it is still test implementation. Look example directory for an example.
-
-The codes under this directory are mainly written by Jun Furuse 
-(Jun.Furuse@inria.fr).

File otherlibs/labltk/tkanim/cltkaniminit.c

-/***********************************************************************/
-/*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
-/*                                                                     */
-/*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
-/*               projet Cristal, INRIA Rocquencourt                    */
-/*            Jacques Garrigue, Kyoto University RIMS                  */
-/*                                                                     */
-/*  Copyright 2002 Institut National de Recherche en Informatique et   */
-/*  en Automatique and Kyoto University.  All rights reserved.         */
-/*  This file is distributed under the terms of the GNU Library        */
-/*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
-/*                                                                     */
-/***********************************************************************/
-#include <tk.h>
-#include <mlvalues.h>
-#include "camltk.h"
-
-extern int Tkanim_Init(Tcl_Interp *);
-
-CAMLprim value tkanim_init (rien) /* ML */
-     value rien;
-{
-  if (Tkanim_Init(cltclinterp) != TCL_OK)
-    tk_error ("Can't initialize TkAnim");
-  return Val_unit;
-}

File otherlibs/labltk/tkanim/gifanimtest.ml

-(***********************************************************************)
-(*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
-(*                                                                     *)
-(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
-(*               projet Cristal, INRIA Rocquencourt                    *)
-(*            Jacques Garrigue, Kyoto University RIMS                  *)
-(*                                                                     *)
-(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
-(*  en Automatique and Kyoto University.  All rights reserved.         *)
-(*  This file is distributed under the terms of the GNU Library        *)
-(*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
-(*                                                                     *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Tkanim
-open Tk
-
-let main () =
-  let file = ref "" in
-    Arg.parse [] (fun s -> file := s)
-      "usage: gifanimtest file (animated gif)\n\
-       \tbutton 1 toggles the animation,\n\
-       \tbutton 2 displays the next frame,\n\
-       \tbutton 3 quits.";
-    let t = openTk () in
-
-      (* First of all, you must initialize the extension. *) 
-      Tkanim.init ();
-
-      prerr_endline !file;
-
-      (* Then load the animated gif. *)
-      let anim = Tkanim.create !file in  
-      prerr_endline "load done";
-
-      (* Check it is really animated or not. *)
-      match anim with
-      | Still x -> 
-          (* Use whatever you want in CamlTk with this ImagePhoto. *)
-          prerr_endline "Sorry, it is not an animated GIF."
-
-      | Animated x ->
-          (* OK, let's animate it. *)
-          let l = Label.create t [] in
-            pack [l] [];
-          
-            (* animate returns an interface function. *)
-            let f = animate l x in
-
-              (* Button1 toggles the animation *)
-              bind l [[], ButtonPressDetail 1] (BindSet ([], (fun _ ->
-                f false)));
-
-              (* Button2 displays the next frame. *)
-              bind l [[], ButtonPressDetail 2] (BindSet ([], (fun _ ->
-                f true)));
-
-              (* Button3 quits. *)
-              bind l [[], ButtonPressDetail 3] (BindSet ([], (fun _ ->
-                closeTk ())));
-
-              (* start the animation *)
-              f false;
-
-              (* Go to the main loop. *)
-              mainLoop ()
-    
-let _ = Printexc.print main ()

File otherlibs/labltk/tkanim/libtkanim.clib

-cltkaniminit.o tkAnimGIF.o

File otherlibs/labltk/tkanim/mmm.anim.gif

Removed
Old image

File otherlibs/labltk/tkanim/tkAnimGIF.c

-/***********************************************************************/
-/*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
-/*                                                                     */
-/*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
-/*               projet Cristal, INRIA Rocquencourt                    */
-/*            Jacques Garrigue, Kyoto University RIMS                  */
-/*                                                                     */
-/*  Copyright 2002 Institut National de Recherche en Informatique et   */
-/*  en Automatique and Kyoto University.  All rights reserved.         */
-/*  This file is distributed under the terms of the GNU Library        */
-/*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
-/*                                                                     */
-/***********************************************************************/
-#define TKANIM_VERSION "1.0"
-/* #define TKANIM_DEBUG */
-
-#include <tk.h>
-#include <string.h>
-
-/*
- * The format record for the Animated GIF file format:
- */
-
-static int      FileMatchGIF _ANSI_ARGS_((FILE *f, char *fileName,
-                    char *formatString, int *widthPtr, int *heightPtr));
-static int      FileReadGIF  _ANSI_ARGS_((Tcl_Interp *interp,
-                    FILE *f, char *fileName, char *formatString));
-
-#define INTERLACE               0x40
-#define LOCALCOLORMAP           0x80
-#define BitSet(byte, bit)       (((byte) & (bit)) == (bit))
-#define MAXCOLORMAPSIZE         256
-#define CM_RED                  0
-#define CM_GREEN                1
-#define CM_BLUE                 2
-#define MAX_LWZ_BITS            12
-#define LM_to_uint(a,b)         (((b)<<8)|(a))
-#define ReadOK(file,buffer,len) (fread(buffer, len, 1, file) != 0)
-
-/*
- * Prototypes for local procedures defined in this file:
- */
-
-static int              DoExtension _ANSI_ARGS_((FILE *fd, int label,
-                            int *transparent, int *delay, int *loop));
-static int              GetCode _ANSI_ARGS_((FILE *fd, int code_size,
-                            int flag));
-static int              GetDataBlock _ANSI_ARGS_((FILE *fd,
-                            unsigned char *buf));
-static int              LWZReadByte _ANSI_ARGS_((FILE *fd, int flag,
-                            int input_code_size));
-static int              ReadColorMap _ANSI_ARGS_((FILE *fd, int number,
-                            unsigned char buffer[3][MAXCOLORMAPSIZE]));
-static int              ReadGIFHeader _ANSI_ARGS_((FILE *f, int *widthPtr,
-                            int *heightPtr));
-static int              ReadImage _ANSI_ARGS_((Tcl_Interp *interp,
-                            char *imagePtr, FILE *fd, int len, int height,
-                            unsigned char cmap[3][MAXCOLORMAPSIZE],
-                            int interlace, int transparent));
-
-static int
-FileMatchGIF(f, fileName, formatString, widthPtr, heightPtr)
-    FILE *f;                    /* The image file, open for reading. */
-    char *fileName;             /* The name of the image file. */
-    char *formatString;         /* User-specified format string, or NULL. */
-    int *widthPtr, *heightPtr;  /* The dimensions of the image are
-                                 * returned here if the file is a valid
-                                 * raw GIF file. */
-{
-        return ReadGIFHeader(f, widthPtr, heightPtr);
-}
-
-static int
-FileReadGIF(interp, f, fileName, formatString)
-    Tcl_Interp *interp;         /* Interpreter to use for reporting errors. */
-    FILE *f;                    /* The image file, open for reading. */
-    char *fileName;             /* The name of the image file. */
-    char *formatString;         /* User-specified format string, or NULL. */
-{
-    int logicalWidth, logicalHeight;
-    int nBytes;
-    Tk_PhotoImageBlock block;
-    unsigned char buf[100];
-    int bitPixel;
-    unsigned int colorResolution;
-    unsigned int background;
-    unsigned int aspectRatio;
-    unsigned char localColorMap[3][MAXCOLORMAPSIZE];
-    unsigned char colorMap[3][MAXCOLORMAPSIZE];
-    int useGlobalColormap;
-    int transparent = -1;
-    int delay = 0;
-    Tk_Window winPtr;
-    int imageLeftPos, imageTopPos, imageWidth, imageHeight;
-    Tk_PhotoHandle photoHandle;
-
-    char widthbuf[32], heightbuf[32];
-    Tcl_DString resultbuf;
-
-    char newresbuf[640];
-    char *imageName;
-    char *resultptr;
-    int loop = -1;
-
-    if((winPtr = Tk_MainWindow(interp)) == NULL){
-        return TCL_ERROR;
-    }
-
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\t\tHeader check...");
-#endif
-    if (!ReadGIFHeader(f, &logicalWidth, &logicalHeight)) {
-        Tcl_AppendResult(interp, "couldn't read GIF header from file \"",
-                fileName, "\"", NULL);
-        return TCL_ERROR;
-    }
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "done ");
-#endif
-    if ((logicalWidth <= 0) || (logicalHeight <= 0)) {
-        Tcl_AppendResult(interp, "GIF image file \"", fileName,
-                "\" has dimension(s) <= 0", (char *) NULL);
-        return TCL_ERROR;
-    }
-
-    if (fread(buf, 1, 3, f) != 3) {
-        return TCL_OK;
-    }
-    bitPixel = 2<<(buf[0]&0x07);
-    colorResolution = (((buf[0]&0x70)>>3)+1);
-    background = buf[1];
-    aspectRatio = buf[2];
-
-    if (BitSet(buf[0], LOCALCOLORMAP)) {    /* Global Colormap */
-        if (!ReadColorMap(f, bitPixel, colorMap)) {
-            Tcl_AppendResult(interp, "error reading color map",
-                    (char *) NULL);
-            return TCL_ERROR;
-        }
-    }
-
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\t\tReading frames ");
-    prevpos = ftell(f);
-#endif
-    sprintf( widthbuf, "%d ", logicalWidth);
-    sprintf( heightbuf, "%d ", logicalHeight);
-
-    Tcl_DStringInit(&resultbuf);
-    Tcl_DStringAppend(&resultbuf, widthbuf, -1);
-    Tcl_DStringAppend(&resultbuf, " ", -1);
-    Tcl_DStringAppend(&resultbuf, heightbuf, -1);
-    Tcl_DStringAppend(&resultbuf, " ", -1);
-    Tcl_DStringAppend(&resultbuf, "{", -1);
-    
-    while (1) {
-        if (fread(buf, 1, 1, f) != 1) {
-            /*
-             * Premature end of image.  We should really notify
-             * the user, but for now just show garbage.
-             */
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "Premature end of image");
-#endif
-
-            break;
-        }
-
-        if (buf[0] == ';') {
-            /*
-             * GIF terminator.
-             */
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, ";");
-    prevpos = ftell(f);
-#endif
-
-            break;
-        }
-
-        if (buf[0] == '!') {
-            /*
-             * This is a GIF extension.
-             */
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "!");
-    prevpos = ftell(f);
-#endif
-
-            if (fread(buf, 1, 1, f) != 1) {
-                Tcl_AppendResult( interp,
-                 "error reading extension function code in GIF image", NULL );
-/*
-                interp->result =
-                        "error reading extension function code in GIF image";
-*/
-                goto error;
-            }
-            if (DoExtension(f, buf[0], &transparent, &delay, &loop) < 0) {
-                Tcl_AppendResult( interp,
-                 "error reading extension in GIF image", NULL );
-/*
-                interp->result = "error reading extension in GIF image";
-*/              goto error;
-            }
-            continue;
-        }
-
-        if (buf[0] == '\0') {
-            /*
-             * Not a valid start character; ignore it.
-             */
-#ifdef TKANIM_DEBUG
-            fprintf(stderr, "0", buf[0]);
-            prevpos = ftell(f);
-#endif
-            continue;
-        }
-
-        if (buf[0] != ',') {
-            /*
-             * Not a valid start character; ignore it.
-             */
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "?(%c)", buf[0]);
-    prevpos = ftell(f);
-#endif
-            continue;
-        }
-
-        if (fread(buf, 1, 9, f) != 9) {
-            Tcl_AppendResult( interp,
-                "couldn't read left/top/width/height in GIF image", NULL );
-/*
-            interp->result = "couldn't read left/top/width/height in GIF image";
-*/
-            goto error;
-        }
-
-        useGlobalColormap = ! BitSet(buf[8], LOCALCOLORMAP);
-
-        bitPixel = 1<<((buf[8]&0x07)+1);
-
-        imageLeftPos= LM_to_uint(buf[0], buf[1]);
-        imageTopPos=  LM_to_uint(buf[2], buf[3]);
-        imageWidth=   LM_to_uint(buf[4], buf[5]); 
-        imageHeight=  LM_to_uint(buf[6], buf[7]);
-
-        block.width = imageWidth;
-        block.height = imageHeight;
-        block.pixelSize = 3;
-        block.pitch = 3 * imageWidth;
-        block.offset[0] = 0;
-        block.offset[1] = 1;
-        block.offset[2] = 2;
-        block.offset[3] = 3;
-        nBytes = imageHeight * block.pitch;
-        block.pixelPtr = (unsigned char *) ckalloc((unsigned) nBytes);
-
-        sprintf(widthbuf, "%d", imageWidth);
-        sprintf(heightbuf, "%d", imageHeight);
-
-        /* save result */
-
-        {
-#if (TK_MAJOR_VERSION >= 8 && TK_MINOR_VERSION >= 1)
-          Tcl_Obj *argv[7];
-          int i;
-
-          argv[0] = Tcl_NewStringObj("image", -1);
-          argv[1] = Tcl_NewStringObj("create", -1);
-          argv[2] = Tcl_NewStringObj("photo", -1);
-          argv[3] = Tcl_NewStringObj("-width", -1);
-          argv[4] = Tcl_NewStringObj(widthbuf, -1);
-          argv[5] = Tcl_NewStringObj("-height", -1);
-          argv[6] = Tcl_NewStringObj(heightbuf, -1);
-      
-          for(i=0; i<7; i++){ Tcl_IncrRefCount(argv[i]); }
-
-          if( Tk_ImageObjCmd((ClientData) winPtr, interp, 
-                        /* "image create photo -width <imageWidth> 
-                           -height <imageHeight>" */
-                             7, argv) == TCL_ERROR ){
-            return TCL_ERROR;
-          }
-        
-        for(i=0; i<7; i++){ Tcl_DecrRefCount(argv[i]); }
-
-#else
-        char *argv[7] = {"image", "create", "photo", "-width", NULL,
-                         "-height", NULL};
-        argv[4] = widthbuf;
-        argv[6] = heightbuf;
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\t\timage creation (%s %s %s %s %s %s %s)", 
-            argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], argv[6]);
-#endif
-        if( Tk_ImageCmd((ClientData) winPtr, interp, 
-                        /* "image create photo -width <imageWidth> 
-                           -height <imageHeight>" */
-                        7, argv) == TCL_ERROR ){
-            return TCL_ERROR;
-        }
-#endif
-
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, " done ");
-#endif
-        }
-
-        imageName = interp->result;
-#if (TK_MAJOR_VERSION < 8)
-        photoHandle = Tk_FindPhoto(interp->result);
-#else
-        photoHandle = Tk_FindPhoto(interp, interp->result);
-#endif
-        if (!useGlobalColormap) {
-            if (!ReadColorMap(f, bitPixel, localColorMap)) {
-                    Tcl_AppendResult(interp, "error reading color map", 
-                            (char *) NULL);
-                    goto error;
-            }
-            if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
-                    imageHeight, localColorMap, BitSet(buf[8], INTERLACE),
-                    transparent) != TCL_OK) {
-                goto error;
-            }
-        } else {
-            if (ReadImage(interp, (char *) block.pixelPtr, f, imageWidth,
-                    imageHeight, colorMap, BitSet(buf[8], INTERLACE),
-                    transparent) != TCL_OK) {
-                goto error;
-            }
-        }
-        Tk_PhotoPutBlock(
-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8)
-	NULL,
-#endif
-photoHandle, &block, 0, 0, imageWidth, imageHeight
-#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8)
-                   , TK_PHOTO_COMPOSITE_SET
-#endif
-          );
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, " Retrieving result\n");
-#endif
-        /* retrieve result */
-        sprintf(newresbuf, "{%s %d %d %d %d %d} ", 
-                imageName, imageWidth, imageHeight, imageLeftPos, imageTopPos, 
-                delay); 
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, " newresbuf = %s\n", newresbuf);
-#endif
-        ckfree((char *) block.pixelPtr);
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, " free done (now append result)");
-#endif
-        Tcl_DStringAppend( &resultbuf, newresbuf, -1 );
-#ifdef TKANIM_DEBUG
-        fprintf(stderr, "\n\t\tFrame done (%d)", ftell(f) - prevpos);
-        prevpos = ftell(f);
-#endif
-    }
-    sprintf( widthbuf, "%d", loop );
-    Tcl_DStringAppend( &resultbuf, "} ", -1 );
-    resultptr = Tcl_DStringAppend( &resultbuf, widthbuf, -1 );
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\nResult = %s\n", resultptr);
-#endif
-    Tcl_ResetResult(interp);
-    Tcl_AppendResult(interp, resultptr, NULL);
-    Tcl_DStringFree(&resultbuf);
-    return TCL_OK;
-
-    error:
-    Tcl_DStringFree(&resultbuf);
-    ckfree((char *) block.pixelPtr);
-    return TCL_ERROR;
-
-}
-
-static int
-DoExtension(fd, label, transparent, delay, loop)
-FILE    *fd;
-int label;
-int     *transparent;
-int     *delay;
-int     *loop;
-{
-        static unsigned char buf[256];
-        int count = 0;
-
-        switch (label) {
-                case 0x01:      /* Plain Text Extension */
-                        break;
-
-                case 0xff:      /* Application Extension */
-                        count = GetDataBlock(fd, (unsigned char*) buf);
-                        if( count < 0){
-                            return 1;
-                        }
-                        if( !strncmp (buf, "NETSCAPE", 8) ) {
-                            /* we ignore check of "2.0" */
-                            count = GetDataBlock (fd, (unsigned char*) buf);
-                            if( count < 0){
-                                return 1;
-                            }
-                            if( buf[0] != 1 ){
-                                fprintf(stderr, "??? %d", buf[0]);
-                            }
-                            *loop = LM_to_uint(buf[1], buf[2]);
-                        }
-                        do {
-                                count = GetDataBlock(fd, (unsigned char*) buf);
-                        } while (count > 0);
-                        return count;
-                        break;
-
-                case 0xfe:      /* Comment Extension */
-                        do {
-                                count = GetDataBlock(fd, (unsigned char*) buf);
-                        } while (count > 0);
-                        return count;
-
-                case 0xf9:      /* Graphic Control Extension */
-                        count = GetDataBlock(fd, (unsigned char*) buf);
-                        if (count < 0) {
-                                return 1;
-                        }
-                        if ((buf[0] & 0x1) != 0) {
-                                *transparent = buf[3];
-                        }
-
-                        /* Delay time */
-                        *delay = LM_to_uint(buf[1],buf[2]);
-
-                        do {
-                            count = GetDataBlock(fd, (unsigned char*) buf);
-                        } while (count > 0);
-                        return count;
-        }
-
-        do {
-            count = GetDataBlock(fd, (unsigned char*) buf);
-        } while (count > 0);
-        return count;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ReadGIFHeader --
- *
- *      This procedure reads the GIF header from the beginning of a
- *      GIF file and returns the dimensions of the image.
- *
- * Results:
- *      The return value is 1 if file "f" appears to start with
- *      a valid GIF header, 0 otherwise.  If the header is valid,
- *      then *widthPtr and *heightPtr are modified to hold the
- *      dimensions of the image.
- *
- * Side effects:
- *      The access position in f advances.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ReadGIFHeader(f, widthPtr, heightPtr)
-    FILE *f;                    /* Image file to read the header from */
-    int *widthPtr, *heightPtr;  /* The dimensions of the image are
-                                 * returned here. */
-{
-    unsigned char buf[7];
-
-    if ((fread(buf, 1, 6, f) != 6)
-            || ((strncmp("GIF87a", (char *) buf, 6) != 0)
-            && (strncmp("GIF89a", (char *) buf, 6) != 0))) {
-        return 0;
-    }
-
-    if (fread(buf, 1, 4, f) != 4) {
-        return 0;
-    }
-
-    *widthPtr = LM_to_uint(buf[0],buf[1]);
-    *heightPtr = LM_to_uint(buf[2],buf[3]);
-    return 1;
-}
-
-/*
- *-----------------------------------------------------------------
- * The code below is copied from the giftoppm program and modified
- * just slightly.
- *-----------------------------------------------------------------
- */
-
-static int
-ReadColorMap(fd,number,buffer)
-FILE        *fd;
-int     number;
-unsigned char   buffer[3][MAXCOLORMAPSIZE];
-{
-        int     i;
-        unsigned char   rgb[3];
-
-        for (i = 0; i < number; ++i) {
-                if (! ReadOK(fd, rgb, sizeof(rgb)))
-                        return 0;
-
-                buffer[CM_RED][i] = rgb[0] ;
-                buffer[CM_GREEN][i] = rgb[1] ;
-                buffer[CM_BLUE][i] = rgb[2] ;
-        }
-        return 1;
-}
-
-
-
-static int ZeroDataBlock = 0;
-
-static int
-GetDataBlock(fd, buf)
-FILE        *fd;
-unsigned char   *buf;
-{
-        unsigned char   count;
-
-        if (! ReadOK(fd,&count,1)) {
-                return -1;
-        }
-
-        ZeroDataBlock = count == 0;
-
-        if ((count != 0) && (! ReadOK(fd, buf, count))) {
-                return -1;
-        }
-
-        return count;
-}
-
-
-static int
-ReadImage(interp, imagePtr, fd, len, height, cmap, interlace, transparent)
-Tcl_Interp *interp;
-char    *imagePtr;
-FILE    *fd;
-int len, height;
-unsigned char   cmap[3][MAXCOLORMAPSIZE];
-int interlace;
-int transparent;
-{
-        unsigned char   c;
-        int     v;
-        int     xpos = 0, ypos = 0, pass = 0;
-        char    *colStr;
-
-
-        /*
-         *  Initialize the Compression routines
-         */
-        if (! ReadOK(fd,&c,1))  {
-            Tcl_AppendResult(interp, "error reading GIF image: ",
-                    Tcl_PosixError(interp), (char *) NULL);
-            return TCL_ERROR;
-        }
-
-        if (LWZReadByte(fd, 1, c) < 0) {
-            interp->result = "format error in GIF image";
-            return TCL_ERROR;
-        }
-
-        if (transparent!=-1 && 
-                (colStr = Tcl_GetVar(interp, "TRANSPARENT_GIF_COLOR", 0L))) {
-                XColor *colorPtr;
-                colorPtr = Tk_GetColor(interp, Tk_MainWindow(interp), 
-                                                          Tk_GetUid(colStr));
-                if (colorPtr) {
-/*
-                        printf("color is %d %d %d\n", 
-                                        colorPtr->red >> 8, 
-                                        colorPtr->green >> 8, 
-                                        colorPtr->blue >> 8);
-*/
-                        cmap[CM_RED][transparent] = colorPtr->red >> 8;
-                        cmap[CM_GREEN][transparent] = colorPtr->green >> 8;
-                        cmap[CM_BLUE][transparent] = colorPtr->blue >> 8;
-                        Tk_FreeColor(colorPtr);
-                }
-        }
-
-        while ((v = LWZReadByte(fd,0,c)) >= 0 ) {
-
-                imagePtr[ (xpos*3)  +  (ypos *len*3)] = cmap[CM_RED][v];
-                imagePtr[ (xpos*3)  +  (ypos *len*3) +1] = cmap[CM_GREEN][v];
-                imagePtr[ (xpos*3)  +  (ypos *len*3) +2] = cmap[CM_BLUE][v];
-
-                ++xpos;
-                if (xpos == len) {
-                        xpos = 0;
-                        if (interlace) {
-                                switch (pass) {
-                                        case 0:
-                                        case 1:
-                                                ypos += 8; break;
-                                        case 2:
-                                                ypos += 4; break;
-                                        case 3:
-                                                ypos += 2; break;
-                                }
-
-                                if (ypos >= height) {
-                                        ++pass;
-                                        switch (pass) {
-                                                case 1:
-                                                        ypos = 4; break;
-                                                case 2:
-                                                        ypos = 2; break;
-                                                case 3:
-                                                        ypos = 1; break;
-                                                default:
-                                                        return TCL_OK;
-                                        }
-                                }
-                        } else {
-                                ++ypos;
-                        }
-                }
-                if (ypos >= height)
-                        break;
-        }
-        return TCL_OK;
-}
-
-static int
-LWZReadByte(fd, flag, input_code_size)
-FILE    *fd;
-int flag;
-int input_code_size;
-{
-        static int  fresh = 0;
-        int     code, incode;
-        static int  code_size, set_code_size;
-        static int  max_code, max_code_size;
-        static int  firstcode, oldcode;
-        static int  clear_code, end_code;
-        static int  table[2][(1<< MAX_LWZ_BITS)];
-        static int  stack[(1<<(MAX_LWZ_BITS))*2], *sp;
-        register int    i;
-
-
-        if (flag) {
-
-                set_code_size = input_code_size;
-                code_size = set_code_size+1;
-                clear_code = 1 << set_code_size ;
-                end_code = clear_code + 1;
-                max_code_size = 2*clear_code;
-                max_code = clear_code+2;
-
-                GetCode(fd, 0, 1);
-
-                fresh = 1;
-
-                for (i = 0; i < clear_code; ++i) {
-                        table[0][i] = 0;
-                        table[1][i] = i;
-                }
-                for (; i < (1<<MAX_LWZ_BITS); ++i) {
-                        table[0][i] = table[1][0] = 0;
-                }
-
-                sp = stack;
-
-                return 0;
-
-        } else if (fresh) {
-
-                fresh = 0;
-                do {
-                        firstcode = oldcode = GetCode(fd, code_size, 0);
-                } while (firstcode == clear_code);
-                return firstcode;
-        }
-
-        if (sp > stack)
-                return *--sp;
-
-        while ((code = GetCode(fd, code_size, 0)) >= 0) {
-                if (code == clear_code) {
-                        for (i = 0; i < clear_code; ++i) {
-                                table[0][i] = 0;
-                                table[1][i] = i;
-                        }
-
-                        for (; i < (1<<MAX_LWZ_BITS); ++i) {
-                                table[0][i] = table[1][i] = 0;
-                        }
-
-                        code_size = set_code_size+1;
-                        max_code_size = 2*clear_code;
-                        max_code = clear_code+2;
-                        sp = stack;
-                        firstcode = oldcode = GetCode(fd, code_size, 0);
-                        return firstcode;
-
-        } else if (code == end_code) {
-                int     count;
-                unsigned char   buf[260];
-
-                if (ZeroDataBlock)
-                        return -2;
-
-                while ((count = GetDataBlock(fd, buf)) > 0)
-                        ;
-
-                if (count != 0)
-                        return -2;
-        }
-
-        incode = code;
-
-        if (code >= max_code) {
-                *sp++ = firstcode;
-                code = oldcode;
-        }
-
-        while (code >= clear_code) {
-                *sp++ = table[1][code];
-                if (code == table[0][code]) {
-                        return -2;
-
-                        fprintf(stderr, "circular table entry BIG ERROR\n");
-                        /*
-                         * Used to be this instead, Steve Ball suggested
-                         * the change to just return.
-
-                        printf("circular table entry BIG ERROR\n");
-                        */
-                }
-                code = table[0][code];
-        }
-
-        *sp++ = firstcode = table[1][code];
-
-        if ((code = max_code) <(1<<MAX_LWZ_BITS)) {
-
-                table[0][code] = oldcode;
-                table[1][code] = firstcode;
-                ++max_code;
-                if ((max_code>=max_code_size) && (max_code_size < (1<<MAX_LWZ_BITS))) {
-                        max_code_size *= 2;
-                        ++code_size;
-                }
-        }
-
-        oldcode = incode;
-
-        if (sp > stack)
-                return *--sp;
-        }
-        return code;
-}
-
-
-static int
-GetCode(fd, code_size, flag)
-FILE    *fd;
-int code_size;
-int flag;
-{
-        static unsigned char    buf[280];
-        static int      curbit, lastbit, done, last_byte;
-        int         i, j, ret;
-        unsigned char       count;
-
-        if (flag) {
-                curbit = 0;
-                lastbit = 0;
-                done = 0;
-                return 0;
-        }
-
-
-        if ( (curbit+code_size) >= lastbit) {
-                if (done) {
-                        /* ran off the end of my bits */
-                        return -1;
-                }
-                buf[0] = buf[last_byte-2];
-                buf[1] = buf[last_byte-1];
-
-                if ((count = GetDataBlock(fd, &buf[2])) == 0)
-                        done = 1;
-
-                last_byte = 2 + count;
-                curbit = (curbit - lastbit) + 16;
-                lastbit = (2+count)*8 ;
-        }
-
-        ret = 0;
-        for (i = curbit, j = 0; j < code_size; ++i, ++j)
-                ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j;
-
-
-        curbit += code_size;
-
-        return ret;
-}
-
-int Tk_AnimationCmd(clientData, interp, argc, argv)
-    ClientData clientData;      /* Main window associated with interpreter. */
-    Tcl_Interp *interp;         /* Current interpreter. */
-    int argc;                   /* Number of arguments. */
-    char **argv;                /* Argument strings. */
-{
-    char c;
-    int length;
-
-    if (argc < 2) {
-        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
-                " option ?arg arg ...?\"", (char *) NULL);
-        return TCL_ERROR;
-    }
-    c = argv[1][0];
-    length = strlen(argv[1]);
-    if((c == 'c') && (length >= 2) 
-       && (strncmp(argv[1], "create", length) == 0)) {
-
-        char * realFileName;
-        Tcl_DString buffer;
-        FILE *f;
-
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "AnimationCmd => create ");
-#endif
-
-        if ( argc != 3 ){
-            Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
-                             " create GifFile\"", (char *) NULL);
-            return TCL_ERROR;
-        }
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\tRealFileName = ");
-#endif
-        realFileName = Tcl_TranslateFileName(interp, argv[2],
-                &buffer);
-        if(realFileName == NULL) {
-            Tcl_DStringFree(&buffer);
-            return TCL_ERROR;
-        }
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "%s ", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\tOpen ", realFileName);
-#endif
-        f = fopen(realFileName, "rb");
-        Tcl_DStringFree(&buffer);
-        if (f == NULL ){
-            Tcl_AppendResult(interp, "couldn't read image file \"",
-                    argv[2], "\": ", Tcl_PosixError(interp),
-                    (char *) NULL);
-            return TCL_ERROR;
-        }
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "success ", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\tRead ", realFileName);
-#endif
-        if( FileReadGIF(interp, f, argv[2], "gif") != TCL_OK ){
-#ifdef TKANIM_DEBUG
-            fprintf(stderr, "\n\tRead failed", realFileName);
-#endif
-            return TCL_ERROR;
-        }
-        fclose(f);
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "\n\tRead done", realFileName);
-#endif
-#ifdef TKANIM_DEBUG
-        fprintf(stderr, "done\n");
-#endif
-    }
-    return TCL_OK;
-}
-
-void
-TkDeleteTkAnim(clientData)
-    ClientData clientData;
-{
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "TkDeleteTkAnim\n");
-#endif
-}
-
-int Tkanim_Init(interp)
-    Tcl_Interp *interp;
-{
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "Tkanim initialize...");
-#endif
-    Tcl_CreateCommand(interp, "animation", Tk_AnimationCmd, 
-                      (ClientData) NULL,
-                      (Tcl_CmdDeleteProc *) TkDeleteTkAnim);
-#ifdef TKANIM_DEBUG
-    fprintf(stderr, "done\n");
-#endif
-    return Tcl_PkgProvide(interp, "Tkanim", TKANIM_VERSION );
-}

File otherlibs/labltk/tkanim/tkAppInit.c

-/***********************************************************************/
-/*                                                                     */
-/*                 MLTk, Tcl/Tk interface of Objective Caml            */
-/*                                                                     */
-/*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
-/*               projet Cristal, INRIA Rocquencourt                    */
-/*            Jacques Garrigue, Kyoto University RIMS                  */
-/*                                                                     */
-/*  Copyright 2002 Institut National de Recherche en Informatique et   */
-/*  en Automatique and Kyoto University.  All rights reserved.         */
-/*  This file is distributed under the terms of the GNU Library        */
-/*  General Public License, with the special exception on linking      */
-/*  described in file LICENSE found in the Objective Caml source tree. */
-/*                                                                     */
-/***********************************************************************/
-/* 
- * tkAppInit.c --
- *
- *      Provides a default version of the Tcl_AppInit procedure for
- *      use in wish and similar Tk-based applications.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#ifndef lint
-static char sccsid[] = "@(#) tkAppInit.c 1.19 95/12/23 17:09:24";
-#endif /* not lint */
-
-#include "tk.h"
-
-int     Tkanimation_Init _ANSI_ARGS_ ((Tcl_Interp *interp));
-
-/*
- * The following variable is a special hack that is needed in order for
- * Sun shared libraries to be used for Tcl.
- */
-
-extern int matherr();
-int *tclDummyMathPtr = (int *) matherr;
-
-#ifdef TK_TEST
-EXTERN int              Tktest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#endif /* TK_TEST */
-
-/*
- *----------------------------------------------------------------------
- *
- * main --
- *
- *      This is the main program for the application.
- *
- * Results:
- *      None: Tk_Main never returns here, so this procedure never
- *      returns either.
- *
- * Side effects:
- *      Whatever the application does.
- *
- *----------------------------------------------------------------------
- */
-
-int
-main(argc, argv)
-    int argc;                   /* Number of command-line arguments. */
-    char **argv;                /* Values of command-line arguments. */
-{
-    Tk_Main(argc, argv, Tcl_AppInit);
-    return 0;                   /* Needed only to prevent compiler warning. */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppInit --
- *
- *      This procedure performs application-specific initialization.
- *      Most applications, especially those that incorporate additional
- *      packages, will have their own version of this procedure.
- *
- * Results:
- *      Returns a standard Tcl completion code, and leaves an error
- *      message in interp->result if an error occurs.
- *
- * Side effects:
- *      Depends on the startup script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_AppInit(interp)
-    Tcl_Interp *interp;         /* Interpreter for application. */
-{
-    if (Tcl_Init(interp) == TCL_ERROR) {
-        return TCL_ERROR;
-    }
-    if (Tk_Init(interp) == TCL_ERROR) {
-        return TCL_ERROR;
-    }
-    Tcl_StaticPackage(interp, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL);
-#ifdef TK_TEST
-    if (Tktest_Init(interp) == TCL_ERROR) {
-        return TCL_ERROR;
-    }
-#endif /* TK_TEST */
-
-
-    /*
-     * Call the init procedures for included packages.  Each call should
-     * look like this:
-     *
-     * if (Mod_Init(interp) == TCL_ERROR) {
-     *     return TCL_ERROR;
-     * }
-     *
-     * where "Mod" is the name of the module.
-     */
-
-    if (Tkanim_Init(interp) == TCL_ERROR) {
-        return TCL_ERROR;
-    }
-
-    /*
-     * Call Tcl_CreateCommand for application-specific commands, if
-     * they weren't already created by the init procedures called above.
-     */
-
-    /*
-     * Specify a user-specific startup file to invoke if the application
-     * is run interactively.  Typically the startup file is "~/.apprc"
-     * where "app" is the name of the application.  If this line is deleted
-     * then no user-specific startup file will be run under any conditions.
-     */
-
-    Tcl_SetVar(interp, "tcl_rcFileName", "~/.tkanimationrc", TCL_GLOBAL_ONLY);
-    return TCL_OK;
-}

File otherlibs/labltk/tkanim/tkanim.ml

-(***********************************************************************)
-(*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
-(*                                                                     *)
-(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
-(*               projet Cristal, INRIA Rocquencourt                    *)
-(*            Jacques Garrigue, Kyoto University RIMS                  *)
-(*                                                                     *)
-(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
-(*  en Automatique and Kyoto University.  All rights reserved.         *)
-(*  This file is distributed under the terms of the GNU Library        *)
-(*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
-(*                                                                     *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Support
-open Protocol
-open Tkintf
-
-external init : unit -> unit = "tkanim_init"
-
-type gifFrame = {
-  imagephoto : imagePhoto;
-  frameWidth : int;
-  frameHeight : int;
-  left : int;
-  top : int;
-  delay : int
- }
-
-type animatedGif = {
-  frames : gifFrame list;
-  animWidth : int;
-  animHeight : int;
-  loop : int
-}
-
-type imageType =
-  | Still of Tk.options
-  | Animated of animatedGif
-
-let debug = ref false
-
-let cTKtoCAMLgifFrame s =
-  match splitlist s with
-  | [photo; width; height; left; top; delay] ->
-      {imagephoto = cTKtoCAMLimagePhoto photo;
-       frameWidth = int_of_string width;
-       frameHeight = int_of_string height;
-       left = int_of_string left;
-       top = int_of_string top;
-       delay = int_of_string delay}
-  | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
-
-let cTKtoCAMLanimatedGif s =
-  match splitlist s with
-  | [width; height; frames; loop] ->
-      {frames = List.map cTKtoCAMLgifFrame (splitlist frames);
-       animWidth = int_of_string width;
-       animHeight = int_of_string height;
-       loop = int_of_string loop}
-  | _ -> raise (Invalid_argument ("cTKtoCAMLgifFrame: " ^ s))
-
-(* check Tkanim package is in the interpreter *)
-let available () =
-  let packages =
-    splitlist (Protocol.tkEval [| TkToken "package";
-                                  TkToken "names" |])
-  in
-  List.mem "Tkanim" packages
-
-let create file =
-  let s =
-    Protocol.tkEval [| TkToken "animation";
-                       TkToken "create";
-                       TkToken file |]
-  in
-  let anmgif = cTKtoCAMLanimatedGif s in
-  match anmgif.frames with
-  | [] -> raise (TkError "Null frame in a gif ?")
-  | [x] -> Still (ImagePhoto x.imagephoto)
-  | _ -> Animated anmgif
-
-let delete anim =
-  List.iter (fun {imagephoto = i} -> Imagephoto.delete i) anim.frames
-
-let width anm = anm.animWidth
-let height anm = anm.animHeight
-let images anm = List.map (fun x -> x.imagephoto) anm.frames
-
-let image_existence_check img =
-  (* I found there is a bug in Tk (even v8.0a2).                        *)
-  (* We can copy from deleted images, Tk never says "it doesn't exist", *)
-  (* But just do some operation. And sometimes it causes Seg-fault.     *)
-  (* So, before using Imagephoto.copy, I should check the source image  *)
-  (* really exists. *)
-  try ignore (Imagephoto.height img) with
-    TkError s -> prerr_endline ("tkanim: " ^ s); raise (TkError s)
-
-let imagephoto_copy dst src opts =
-  image_existence_check src;
-  Imagephoto.copy dst src opts
-
-let animate_gen w i anim =
-  let length = List.length anim.frames in
-  let frames = Array.of_list anim.frames in
-  let current = ref 0 in
-  let loop = ref anim.loop in
-  let f = frames.(!current) in
-    imagephoto_copy i f.imagephoto
-      [ImgTo (f.left, f.top, f.left + f.frameWidth,
-                             f.top + f.frameHeight)];
-  let visible = ref true in
-  let animated = ref false in
-  let timer = ref None in
-  (* Loop *)
-  let display_current () =
-    let f = frames.(!current) in
-      imagephoto_copy i f.imagephoto
-        [ImgTo (f.left, f.top,
-                f.left + f.frameWidth, f.top + f.frameHeight)]
-  in
-  let rec tick () =
-    if not (Winfo.exists w && Winfo.viewable w) then begin
-      (* the widget is invisible. stop animation for efficiency *)
-      if !debug then prerr_endline "Stopped (Visibility)";
-      visible := false;
-    end else
-      begin
-        display_current ();
-        let t =
-          Timer.add (if f.delay = 0 then 100 else f.delay * 10)
-            (fun () ->
-               incr current;
-               if !current = length then begin
-                 current := 0;
-                 (* loop check *)
-                 if !loop > 1 then begin
-                   decr loop;
-                   if !loop = 0 then begin
-                     if !debug then prerr_endline "Loop end";
-                     (* stop *)
-                     loop := anim.loop;
-                     timer := None
-                   end
-                 end
-               end;
-               tick ())
-        in
-          timer := Some t
-      end
-  in
-  let start () =
-    animated := true;
-    tick ()
-  in
-  let stop () =
-    match !timer with
-    | Some t ->
-        Timer.remove t;
-        timer := None;
-        animated := false
-    | None -> ()
-  in
-  let next () =
-    if !timer = None then begin
-      incr current;
-      if !current = length then current := 0;
-      display_current ()
-    end
-  in
-    (* We shouldn't delete the animation here. *)
-(*
-    bind w [[], Destroy]
-      (BindSet ([], (fun _ -> Imagephoto.delete i)));
-*)
-    bind w [[], Visibility]
-      (BindSet ([], (fun _ ->
-        if not !visible then begin
-          visible := true;
-          if !animated then start ()
-        end)));
-    (function
-     | false ->
-         if !animated then stop () else start ()
-     | true -> next ())
-
-let animate label anim =
-  (*  prerr_endline "animate"; *)
-  let i = Imagephoto.create [Width (Pixels anim.animWidth);
-                             Height (Pixels anim.animHeight)]
-  in
-    bind label [[], Destroy] (BindExtend ([], (fun _ ->
-      Imagephoto.delete i)));
-    Label.configure label [ImagePhoto i];
-    animate_gen label i anim
-
-let animate_canvas_item canvas tag anim =
-(*  prerr_endline "animate"; *)
-  let i = Imagephoto.create [Width (Pixels anim.animWidth);
-                             Height (Pixels anim.animHeight)]
-  in
-    bind canvas [[], Destroy] (BindExtend ([], (fun _ ->
-      Imagephoto.delete i)));
-    Canvas.configure_image canvas tag [ImagePhoto i];
-    animate_gen canvas i anim
-
-let gifdata s =
-  let tmp_dir = ref Filename.temp_dir_name in
-  let mktemp =
-    let cnter = ref 0
-    and pid = Unix.getpid() in
-      (function prefx ->
-               incr cnter;
-               (Filename.concat !tmp_dir
-               (prefx ^ string_of_int pid ^ "." ^ string_of_int !cnter)))
-  in
-    let fname = mktemp "gifdata" in
-    let oc = open_out_bin fname in
-      try
-        output_string oc s;
-        close_out oc;
-        let anim = create fname in
-          Unix.unlink fname;
-          anim
-      with
-        e -> begin Unix.unlink fname; raise e end
-

File otherlibs/labltk/tkanim/tkanim.mli

-(***********************************************************************)
-(*                                                                     *)
-(*                 MLTk, Tcl/Tk interface of Objective Caml            *)
-(*                                                                     *)
-(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
-(*               projet Cristal, INRIA Rocquencourt                    *)
-(*            Jacques Garrigue, Kyoto University RIMS                  *)
-(*                                                                     *)
-(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
-(*  en Automatique and Kyoto University.  All rights reserved.         *)
-(*  This file is distributed under the terms of the GNU Library        *)
-(*  General Public License, with the special exception on linking      *)
-(*  described in file LICENSE found in the Objective Caml source tree. *)
-(*                                                                     *)
-(***********************************************************************)
-open Camltk
-open Widget
-open Support
-
-(*** Data types ***)
-
-type animatedGif
-
-    (* This data type contains all the information of an animation of
-       gif89a format. It is still test implementation, so I should 
-       keep it abstract. --- JPF *)
-
-type imageType =
-  | Still of Tk.options
-  | Animated of animatedGif
-
-      (* This data type is required to distinguish normal still images
-         and animated gifs. Usually objects typed imagePhoto or
-         imageBitmap are used for Still. *)
-
-(*** Flags ***)
-
-val debug : bool ref 
-
-(*** Library availability check ***)
-
-val init : unit -> unit
-
-    (* This function calls the initialization function for Tkanim
-       Tcl/Tk extension. *)
-
-val available : unit -> bool
-
-      (* [available ()] returns true if there is Tkanim Tcl/Tk
-         extension linked statically/dynamically in Tcl/Tk
-         interpreter. Otherwise, return false. *)
-
-(*** User interface ***)
-
-(* create is unsafe *)
-val create : string -> imageType
-
-      (* [create file] loads a gif87 or gif89 image file and parse it,
-         and returns [Animated animated_gif] if the image file has
-         more than one images. Otherwise, it returns 
-         [Still (ImagePhoto image_photo)] *) 
-
-val delete : animatedGif -> unit
-
-      (* [delete anim] deletes all the images in anim. Usually
-         animatedGifs contain many images, so you must not forget to
-         use this function to free the memory. *)
-
-val width : animatedGif -> int
-val height : animatedGif -> int
-      (* [width anim] and [height anim] return the width and height of
-         given animated gif. *)
-
-val images : animatedGif -> imagePhoto list
-      (* [images anim] returns the list of still images used in the 
-         animation *)
-
-val animate : widget -> animatedGif -> bool -> unit
-val animate_canvas_item : widget -> tagOrId -> animatedGif -> bool -> unit
-      (* The display functions for animated gifs. Since [animatedGif] is
-         an abstract type, you must use those functions to display
-         [animatedGif] images.
-         [animate label anim] and [animate_canvas_item canvas tag anim]
-         display animation [anim] on a label widget [label] or an
-         image tag [tag] on a canvas widget [canvas] respectively.
-
-         Note that animation is stopped by default.
-         These functions return interface functions, say, [inter :
-         bool -> unit]. Currently, [inter false] toggles start/stop of
-         the animation, and [inter true] displays the next frame of
-         the animation if the animation is stopped. *)
-
-val gifdata : string -> imageType
-      (* [gifdata data] reads [data] as a row data of a gif file and
-         decodes it. *)