/* * 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 * * 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 #else #include #endif #ifdef _WIN32 #define WIN32_LEAN_AND_MEAN #include #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; }