/usr/share/tcltk/tcllib1.17/stooop/mkpkgidx.tcl is in tcllib 1.17-dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | # command line:
# $ interpreter mkpkgidx.tcl -p package1.n.n -p package2 -p package3.n ...
# packageName file1 file2 ...
# use wish as interpreter instead of tclsh in order to handle graphical packages
# Copyright (c) 2001 by Jean-Luc Fontaine <jfontain@free.fr>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: mkpkgidx.tcl,v 1.3 2004/01/15 06:36:14 andreas_kupries Exp $
# this utility must be used to create the package index file for a package that
# uses stooop.
# it differs from the tcl pkg_mkIndex procedure in the way it sources files.
# since base classes can usually be found in files separate from the derived
# class source file, sourcing each file in a different interpreter (as is done
# in the pkg_mkIndex procedure) results in an error for stooop that catches the
# fact that the base class is not defined. the solution is to use a single
# interpreter which will source the class files in order (base classes first at
# the user's responsibility). since stooop is loaded in that single interpreter,
# inheritance problems and others are automatically caught in the process.
# the generated package index file is fully compatible with the tcl generated
# ones.
# the stooop library makes sure that base classes source files are automatically
# sourced when a derived class is defined (see the stooop.tcl source file for
# more information).
# if your software requires one or more packages, you may force their loading
# by using the -p arguments. each package version number is optionally appended
# to the package name and follows the same rules as the Tcl package require
# command
# example: $ tclsh -p switched.1 -p scwoop foo bar.tcl barfoo.tcl foobar.tcl ...
if {[catch {package require stooop 4}]} {
# in case stooop package is not installed
source stooop.tcl
}
namespace import stooop::*
proc indexData {packageName files} {
global auto_index
set index "# Package index file created with stooop version [package provide stooop] for stooop packages\n"
set data {}
foreach command [info commands] {
set defined($command) {}
}
foreach file $files {
# source at global level to avoid variable names collisions:
uplevel #0 source [list $file]
catch {unset newCommands} ;# empty new commands array
foreach command [info commands] {
# check new commands at the global level
# filter out tk widget commands and ignore commands eventually
# loaded from a package required by the new commands
if {
[string match .* $command]||[info exists defined($command)]||
[info exists auto_index($command)]||\
[info exists auto_index(::$command)]
} continue
set newCommands($command) {}
set defined($command) {}
}
# check new classes, which actually are namespaces:
foreach class [array name stooop::declared] {
if {![info exists declared($class)]} {
# check new commands at the class namespace level:
foreach command [info commands ::${class}::*] {
# ignore commands eventually loaded from a package required
# by the new commands
if {\
[info exists defined($command)]||\
[info exists auto_index($command)]||\
[info exists auto_index(::$command)]\
} continue
set newCommands($command) {}
set defined($command) {}
}
set declared($class) {}
}
}
# so far only sourceable file, not shared libraries, are handled
lappend data [list $file source [lsort [array names newCommands]]]
}
set version [package provide $packageName]
append index "\npackage ifneeded $packageName $version \[list tclPkgSetup \$dir $packageName $version [list $data]\]"
return $index
}
proc printUsage {exitCode} {
global argv0
puts stderr "usage: $argv0 \[\[-p package.n.n\] \[-p package.n.n\] ...\] moduleName tclFile tclFile ..."
exit $exitCode
}
# first gather eventual packages:
for {set index 0} {$index<[llength $argv]} {incr index} {
if {[string compare [lindex $argv $index] -p]!=0} break
set version {}
scan [lindex $argv [incr index]] {%[^.].%s} name version
eval package require $name $version
}
set argv [lrange $argv $index end] ;# keep remaining arguments
if {[llength $argv]<2} {
printUsage 1
}
puts [open pkgIndex.tcl w] [indexData [lindex $argv 0] [lrange $argv 1 end]]
exit ;# in case wish is used
|