rendered paste body/*
* tclAppInit.c --
*
* Provides a default version of the main program and Tcl_AppInit
* procedure for Tcl applications (without Tk). Note that this
* program must be built in Win32 console mode to work properly.
*
* Copyright (c) 1996-1997 by Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2000-2002 Jean-Claude Wippler <jcw@equi4.com>
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: kitInit.c 1629 2007-06-09 13:59:31Z jcw $
*/
#ifdef KIT_INCLUDES_TK
#include <tk.h>
#else
#include <tcl.h>
#endif
#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#endif
#ifndef MB_TASKMODAL
#define MB_TASKMODAL 0
#endif
#include "tclInt.h"
Tcl_AppInitProc Mk4tcl_Init, Vfs_Init, Rechan_Init, Zlib_Init;
#ifdef _WIN32
Tcl_AppInitProc Registry_Init;
#endif
char *tclExecutableName;
/*
* Attempt to load a "boot.tcl" entry from the embedded MetaKit file.
* If there isn't one, try to open a regular "setup.tcl" file instead.
* If that fails, this code will throw an error, using a message box.
*/
static char *preInitCmd =
"continue\n"
;
static const char initScript[] =
"package ifneeded registry 1.1.5 {load {} registry}\n"
"catch {load {} zlib}\n"
"set tcl_interactive 0\n"
"incr argc\n"
"set argv [linsert $argv 0 $argv0]\n"
"proc funpack {f begin sfxswitch} {\n"
" set in [open $f r]\n"
" fconfigure $in -blocking false -buffering none -translation binary\n"
" set f [string range $f 0 [expr [string last \".\" $f]-1]]\n"
" if {$sfxswitch == 0} {\n"
" seek $in -7 end\n"
" } else {\n"
" seek $in [expr $sfxswitch-7]\n"
" }\n"
" set tmp [read $in 4]\n"
" binary scan $tmp I off\n"
" set off [expr $off & 0xffffffff]\n"
" set tmp [read $in 3]\n"
" binary scan \"\\x00$tmp\" I count\n"
" set count [expr $count & 0xffffffff]\n"
" if {$sfxswitch == 0} {\n"
" seek $in -$off end\n"
" } else {\n"
" seek $in $sfxswitch\n"
" seek $in -$off current\n"
" }\n"
" set buff [zlib inflate [read $in [expr $off-7]]]\n"
" seek $in $begin\n"
" while {$count > 0} {\n"
" set fn [string range $buff 0 [expr [string first \"\\x00\" $buff]-1]]\n"
" set buff [string range $buff [expr [string first \"\\x00\" $buff]+1] end]\n"
" set tmp [string range $buff 0 3]\n"
" set buff [string range $buff 4 end]\n"
" binary scan $tmp I len\n"
" set len [expr $len & 0xffffffff]\n"
" file mkdir \"$f/[string range $fn 0 [string last \"/\" $fn]]\"\n"
" set out [open \"$f/$fn\" w]\n"
" fconfigure $out -blocking false -buffering none -translation binary\n"
" puts -nonewline $out [zlib inflate [read $in $len]]\n"
" close $out\n"
" set count [expr $count-1]\n"
" }\n"
" close $in\n"
"}\n"
"proc fpack {f afn} {\n"
" cd $f/..\n"
" set f [string range $f [expr [string last \"/\" $f]+1] end]\n"
" set out [open $afn a]\n"
" fconfigure $out -blocking false -buffering full -buffersize 512000 -translation binary\n"
" set files2 [list]\n"
" lappend files2 [glob -nocomplain -types f $f/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*/*/*/*/*]\n"
" lappend files2 [glob -nocomplain -types f $f/*/*/*/*/*/*/*/*/*/*/*/*]\n"
" set files [list]\n"
" foreach f2 $files2 {\n"
" foreach f0 $f2 {\n"
" lappend files $f0\n"
" }\n"
" }\n"
" set files2 $files\n"
" set buff \"\"\n"
" set count 0\n"
" foreach f2 $files2 {\n"
" if {$f2 ne \"\"} {\n"
" set in [open $f2 r]\n"
" fconfigure $in -blocking false -buffering none -translation binary\n"
" set tmp [zlib deflate [read $in [file size $f2]]]\n"
" puts -nonewline $out $tmp\n"
" close $in\n"
" append buff \"[string range $f2 [expr [string first \"/\" $f2]+1] end]\\x00[binary format I [string length $tmp]]\"\n"
" incr count\n"
" }\n"
" }\n"
" set buff [zlib deflate $buff]\n"
" puts -nonewline $out $buff\n"
" puts -nonewline $out [binary format I [expr [string length $buff]+7]]\n"
" puts -nonewline $out [string range [binary format I $count] 1 3]\n"
" close $out\n"
"}\n"
"set fpfn [string range $argv0 0 [expr [string last \"/\" $argv0]-1]]\n"
"set sfxlen [file size $fpfn]\n"
"set fpaoffset 292864\n"
"set in [open $fpfn r]\n"
"fconfigure $in -blocking false -buffering none -translation binary\n"
"seek $in 2\n"
"set tmp [read $in 4]\n"
"close $in\n"
"binary scan $tmp I tmpoff\n"
"if {$tmp ne \"\\xFF\\xFF\\xFF\\xFF\"} {\n"
" funpack $fpfn $fpaoffset $tmpoff\n"
"} else {\n"
" if {$argc != 2} {\n"
" puts \"usage:\\n\\tfp unpack file.fpa\\n\\tfp pack directory\\n\\tfp sfxpack directory\\n\"\n"
" puts \"idea and algorithm by Misioslaw\\nlame coded by unic0rn\\n(c) 2007\"\n"
" } else {\n"
" if {[lindex $argv 0] eq \"unpack\"} {\n"
" funpack [lindex $argv 1] 0 0\n"
" } elseif {[lindex $argv 0] eq \"pack\"} {\n"
" fpack [lindex $argv 1] \"[lindex $argv 1].fpa\"\n"
" } elseif {[lindex $argv 0] eq \"sfxpack\"} {\n"
" set in [open $fpfn r]\n"
" fconfigure $in -blocking false -buffering none -translation binary\n"
" set out [open \"[lindex $argv 1].exe\" w]\n"
" fconfigure $out -blocking false -buffering full -buffersize 512000 -translation binary\n"
" puts -nonewline $out [read $in $fpaoffset]\n"
" close $out\n"
" fpack [lindex $argv 1] \"[lindex $argv 1].exe\"\n"
" set out [open \"[lindex $argv 1].exe\" r+]\n"
" fconfigure $out -blocking false -buffering full -buffersize 512000 -translation binary\n"
" seek $out 0 end\n"
" set tmpoff [tell $out]\n"
" seek $out 2\n"
" puts -nonewline $out [binary format I $tmpoff]\n"
" seek $out 104\n"
" puts -nonewline $out \"\\x02\"\n"
" close $in\n"
" close $out\n"
" } else {\n"
" puts \"usage:\\n\\tfp unpack file.fpa\\n\\tfp pack directory\\n\\tfp sfxpack directory\\n\"\n"
" puts \"idea and algorithm by Misioslaw\\nlame coded by unic0rn\\n(c) 2007\"\n"
" }\n"
" }\n"
"}\n"
;
/* SetExecName --
Hack to get around Tcl bug 1224888.
*/
void SetExecName(Tcl_Interp *interp) {
if (tclExecutableName == NULL) {
int len = 0;
Tcl_Obj *execNameObj;
Tcl_Obj *lobjv[1];
lobjv[0] = Tcl_GetVar2Ex(interp, "argv0", NULL, TCL_GLOBAL_ONLY);
execNameObj = Tcl_FSJoinToPath(Tcl_FSGetCwd(interp), 1, lobjv);
tclExecutableName = strdup(Tcl_GetStringFromObj(execNameObj, &len));
}
}
int
TclKit_AppInit(Tcl_Interp *interp)
{
Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL);
Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL);
Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL);
Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL);
Tcl_StaticPackage(0, "registry", Registry_Init, NULL);
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY);
/* Hack to get around Tcl bug 1224888. This must be run here and
* in LibraryPathObjCmd because this information is needed both
* before and after that command is run. */
SetExecName(interp);
TclSetPreInitScript(preInitCmd);
if (Tcl_Init(interp) == TCL_ERROR)
goto error;
#ifdef KIT_INCLUDES_TK
#ifdef _WIN32
if (Tk_Init(interp) == TCL_ERROR)
goto error;
if (Tk_CreateConsoleWindow(interp) == TCL_ERROR)
goto error;
#endif
#endif
if (Tcl_Eval(interp, initScript) == TCL_OK) {
Tcl_Obj* path = TclGetStartupScriptPath();
TclSetStartupScriptPath(Tcl_GetObjResult(interp));
if (path == NULL)
Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]");
}
Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY);
Tcl_ResetResult(interp);
return TCL_OK;
error:
#ifdef KIT_INCLUDES_TK
#ifdef _WIN32
MessageBeep(MB_ICONEXCLAMATION);
#ifndef _WIN32_WCE
MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
ExitProcess(1);
#endif
/* we won't reach this, but we need the return */
#endif
#endif
return TCL_ERROR;
}