File: mkpkgidx.tcl

package info (click to toggle)
tcllib 2.0%2Bdfsg-4
  • links: PTS
  • area: main
  • in suites: trixie
  • size: 83,572 kB
  • sloc: tcl: 306,798; ansic: 14,272; sh: 3,035; xml: 1,766; yacc: 1,157; pascal: 881; makefile: 124; perl: 84; f90: 84; python: 33; ruby: 13; php: 11
file content (112 lines) | stat: -rwxr-xr-x 4,797 bytes parent folder | download | duplicates (11)
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