Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Update Practcl.tcl to the latest
Workaround in tclZipFs for an internal API change in the Tcl Core post 8.6.9 |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | practcl |
Files: | files | file ages | folders |
SHA3-256: |
79972997da53915f7d71b2597f741388 |
User & Date: | hypnotoad 2019-09-09 13:11:05.641 |
Context
2019-09-09
| ||
13:17 | Closing fork Leaf check-in: 832915fb01 user: hypnotoad tags: practcl | |
13:11 |
Update Practcl.tcl to the latest
Workaround in tclZipFs for an internal API change in the Tcl Core post 8.6.9 check-in: 79972997da user: hypnotoad tags: practcl | |
2019-07-26
| ||
13:14 | Updating to the latest practcl check-in: 149b1e1e5f user: hypnotoad tags: practcl | |
Changes
Changes to compat/tclZipfs.c.
︙ | ︙ | |||
939 940 941 942 943 944 945 | if(zf->is_membuf==1) { /* Pointer to memory */ if (zf->tofree != NULL) { Tcl_Free((char *) zf->tofree); zf->tofree = NULL; } zf->data = NULL; | | | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 | if(zf->is_membuf==1) { /* Pointer to memory */ if (zf->tofree != NULL) { Tcl_Free((char *) zf->tofree); zf->tofree = NULL; } zf->data = NULL; return; } #if defined(_WIN32) || defined(_WIN64) if ((zf->data != NULL) && (zf->tofree == NULL)) { UnmapViewOfFile(zf->data); zf->data = NULL; } if (zf->mh != INVALID_HANDLE_VALUE) { CloseHandle(zf->mh); |
︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 | i = q[-5]; if (q - 5 - i > zf->data) { zf->pwbuf[0] = i; memcpy(zf->pwbuf + 1, q - 5 - i, i); zf->baseoffsp -= i ? (5 + i) : 0; } } | | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 | i = q[-5]; if (q - 5 - i > zf->data) { zf->pwbuf[0] = i; memcpy(zf->pwbuf + 1, q - 5 - i, i); zf->baseoffsp -= i ? (5 + i) : 0; } } return TCL_OK; error: ZipFSCloseArchive(interp, zf); return TCL_ERROR; } |
︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | */ static int ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, ZipFile *zf) { int i; ClientData handle; | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 | */ static int ZipFSOpenArchive(Tcl_Interp *interp, const char *zipname, int needZip, ZipFile *zf) { int i; ClientData handle; zf->is_membuf=0; #if defined(_WIN32) || defined(_WIN64) zf->data = NULL; zf->mh = INVALID_HANDLE_VALUE; #else zf->data = MAP_FAILED; #endif |
︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 | Tcl_HashEntry *hPtr; Tcl_DString ds, dsm, fpBuf; unsigned char *q; #if HAS_DRIVES int drive = 0; #endif WriteLock(); | | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 | Tcl_HashEntry *hPtr; Tcl_DString ds, dsm, fpBuf; unsigned char *q; #if HAS_DRIVES int drive = 0; #endif WriteLock(); pwlen = 0; if (passwd != NULL) { pwlen = strlen(passwd); if ((pwlen > 255) || (strchr(passwd, 0xff) != NULL)) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); |
︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | } if (interp == NULL) { ret = (i > 0) ? TCL_OK : TCL_BREAK; } Unlock(); return ret; } | | | 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 | } if (interp == NULL) { ret = (i > 0) ? TCL_OK : TCL_BREAK; } Unlock(); return ret; } if (zipname == NULL) { Tcl_HashEntry *hPtr; if (interp == NULL) { Unlock(); return TCL_OK; } hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); |
︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 | } if (interp == NULL) { ret = (i > 0) ? TCL_OK : TCL_BREAK; } Unlock(); return ret; } | | | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 | } if (interp == NULL) { ret = (i > 0) ? TCL_OK : TCL_BREAK; } Unlock(); return ret; } if (data == NULL) { Tcl_HashEntry *hPtr; if (interp == NULL) { Unlock(); return TCL_OK; } |
︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 | if (!ZipFS.initialized) goto done; /* * Mount point sometimes is a relative or otherwise denormalized path. * But an absolute name is needed as mount point here. */ Tcl_DStringInit(&dsm); mntpt = CanonicalPath("", mntpt, &dsm, 1); | | | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 | if (!ZipFS.initialized) goto done; /* * Mount point sometimes is a relative or otherwise denormalized path. * But an absolute name is needed as mount point here. */ Tcl_DStringInit(&dsm); mntpt = CanonicalPath("", mntpt, &dsm, 1); hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mntpt); /* don't report error */ if (hPtr == NULL) goto done; zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->nopen > 0) { |
︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 | } if(objc<2) { int i; Tcl_HashEntry *hPtr; Tcl_HashSearch search; int ret = TCL_OK; ZipFile *zf; | | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 | } if(objc<2) { int i; Tcl_HashEntry *hPtr; Tcl_HashSearch search; int ret = TCL_OK; ZipFile *zf; ReadLock(); i = 0; hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); while (hPtr != NULL) { if ((zf = (ZipFile *) Tcl_GetHashValue(hPtr)) != NULL) { if (interp != NULL) { Tcl_AppendElement(interp, zf->mntpt); |
︙ | ︙ | |||
2966 2967 2968 2969 2970 2971 2972 | Tcl_Obj *TclZipfs_TclLibrary(void) { if(zipfs_literal_tcl_library) { return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); } else { Tcl_Obj *vfsinitscript; int found=0; | | | 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 | Tcl_Obj *TclZipfs_TclLibrary(void) { if(zipfs_literal_tcl_library) { return Tcl_NewStringObj(zipfs_literal_tcl_library,-1); } else { Tcl_Obj *vfsinitscript; int found=0; /* Look for the library file system within the executable */ vfsinitscript=Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",-1); Tcl_IncrRefCount(vfsinitscript); found=Tcl_FSAccess(vfsinitscript,F_OK); Tcl_DecrRefCount(vfsinitscript); if(found==TCL_OK) { zipfs_literal_tcl_library=ZIPFS_APP_MOUNT "/tcl_library"; |
︙ | ︙ | |||
4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 | } } if (objs[0] == NULL) { objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), TCL_PATH_DIRNAME); } if (objs[0] != NULL) { altPath = TclJoinPath(2, objs); if (altPath != NULL) { Tcl_IncrRefCount(altPath); if (Tcl_FSAccess(altPath, R_OK) == 0) { path = altPath; } } } | > > > > | 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 | } } if (objs[0] == NULL) { objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), TCL_PATH_DIRNAME); } if (objs[0] != NULL) { #if TCL_RELEASE_SERIAL < 9 altPath = TclJoinPath(2, objs); #else altPath = TclJoinPath(2, objs, 0); #endif if (altPath != NULL) { Tcl_IncrRefCount(altPath); if (Tcl_FSAccess(altPath, R_OK) == 0) { path = altPath; } } } |
︙ | ︙ | |||
4566 4567 4568 4569 4570 4571 4572 | * * Dummy version when no ZLIB support available. * *------------------------------------------------------------------------- */ int | | | 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 | * * Dummy version when no ZLIB support available. * *------------------------------------------------------------------------- */ int TclZipfs_Mount(Tcl_Interp *interp, const char *mntpt, const char *zipname, const char *passwd) { return TclZipfs_Init(interp, 1); } int TclZipfs_Unmount(Tcl_Interp *interp, const char *zipname) |
︙ | ︙ |
Changes to practcl.tcl.
︙ | ︙ | |||
3466 3467 3468 3469 3470 3471 3472 | set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} set found 0 set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl] foreach file [glob -nocomplain [file join $path *.tcl]] { if {[file tail $file] ni $mlist} { | | | | 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 | set modfile [file join $path [file tail $path].tcl] set use_pkgindex [file exists $pkgidxfile] set tclfiles {} set found 0 set mlist [list pkgIndex.tcl index.tcl [file tail $modfile] version_info.tcl] foreach file [glob -nocomplain [file join $path *.tcl]] { if {[file tail $file] ni $mlist} { #puts [list NONMODFILE $file] return {} } } foreach file [glob -nocomplain [file join $path *.tcl]] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue set fname [file rootname [file tail $file]] # Look for a package provide statement foreach line [split $dat \n] { set line [string trim $line] if { [string range $line 0 14] != "package provide" } continue set package [lindex $line 2] set version [lindex $line 3] if {[string index $package 0] in "\$ \[ @"} continue if {[string index $version 0] in "\$ \[ @"} continue #puts "PKGLINE $line" append buffer "package ifneeded $package $version \[list source \[file join %DIR% [file tail $file]\]\]" \n break } } return $buffer } proc ::practcl::_pkgindex_directory {path} { |
︙ | ︙ | |||
3766 3767 3768 3769 3770 3771 3772 | set IdxTime [file mtime $pkgIndexFile] if {$latest<$IdxTime} return } ::practcl::dotclexec $buildscript } proc ::practcl::installModule {modpath DEST} { set dpath [file join $DEST modules [file tail $modpath]] | | | 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 | set IdxTime [file mtime $pkgIndexFile] if {$latest<$IdxTime} return } ::practcl::dotclexec $buildscript } proc ::practcl::installModule {modpath DEST} { set dpath [file join $DEST modules [file tail $modpath]] #puts [list ::practcl::installModule $modpath -> $dpath] if {[file exists [file join $modpath index.tcl]]} { # IRM/Tao style modules non-amalgamated ::practcl::installDir $modpath $dpath return } if {[file exists [file join $modpath build build.tcl]]} { buildModule $modpath |
︙ | ︙ | |||
7268 7269 7270 7271 7272 7273 7274 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } | | > < < < < < < < < < < < < < < < < < < < < < < < < < < | 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 | set map {} foreach var { vfsroot mainhook mainfunc vfs_main } { dict set map %${var}% [set $var] } set thread_init_script {namespace eval ::starkit {}} append thread_init_script \n [list set ::starkit::topdir $vfsroot] set preinitscript { set ::odie(boot_vfs) %vfsroot% set ::SRCDIR $::odie(boot_vfs) namespace eval ::starkit {} set ::starkit::topdir %vfsroot% if {[file exists [file join %vfsroot% tcl_library init.tcl]]} { set ::tcl_library [file join %vfsroot% tcl_library] set ::auto_path {} } if {[file exists [file join %vfsroot% tk_library tk.tcl]]} { set ::tk_library [file join %vfsroot% tk_library] } } ; # Preinitscript set zvfsboot { /* * %mainhook% -- * Performs the argument munging for the shell */ } ::practcl::cputs zvfsboot { |
︙ | ︙ | |||
7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } foreach {statpkg info} $statpkglist { set initfunc {} if {[dict exists $info initfunc]} { set initfunc [dict get $info initfunc] } if {$initfunc eq {}} { set initfunc [string totitle ${statpkg}]_Init } if {![dict exists $info version]} { error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" } } | > > > > > > > > > > > > > > > > > > | > > > > > | | 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 | return TCL_ERROR; } } if {![$PROJECT define get tip_430 0]} { ::practcl::cputs appinit { TclZipfs_Init(interp);} } set main_init_script {} foreach {statpkg info} $statpkglist { set initfunc {} if {[dict exists $info initfunc]} { set initfunc [dict get $info initfunc] } if {$initfunc eq {}} { set initfunc [string totitle ${statpkg}]_Init } if {![dict exists $info version]} { error "$statpkg HAS NO VERSION" } # We employ a NULL to prevent the package system from thinking the # package is actually loaded into the interpreter $PROJECT code header "extern Tcl_PackageInitProc $initfunc\;\n" set script [list package ifneeded $statpkg [dict get $info version] [list ::load {} $statpkg]] append main_init_script \n [list set ::starkit::static_packages(${statpkg}) $script] if {[dict get $info autoload]} { ::practcl::cputs appinit " if(${initfunc}(interp)) return TCL_ERROR\;" ::practcl::cputs appinit " Tcl_StaticPackage(interp,\"$statpkg\",$initfunc,NULL)\;" } else { ::practcl::cputs appinit "\n Tcl_StaticPackage(NULL,\"$statpkg\",$initfunc,NULL)\;" append main_init_script \n $script } } append main_init_script \n { if {[file exists [file join $::starkit::topdir pkgIndex.tcl]]} { #In a wrapped exe, we don't go out to the environment set dir $::starkit::topdir source [file join $::starkit::topdir pkgIndex.tcl] }} append thread_init_script $main_init_script append main_init_script \n { # 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. } append thread_init_script \n [list set ::starkit::thread_init $thread_init_script] append main_init_script \n [list set ::starkit::thread_init $thread_init_script] append main_init_script \n [list set tcl_rcFileName [$PROJECT define get tcl_rcFileName ~/.tclshrc]] practcl::cputs appinit " Tcl_Eval(interp,[::practcl::tcl_to_c $thread_init_script]);" practcl::cputs appinit { return TCL_OK;} $PROJECT c_function [string map $map "int %mainfunc%(Tcl_Interp *interp)"] [string map $map $appinit] } method Collate_Source CWD { next $CWD set name [my define get name] # Assume a static shell |
︙ | ︙ |