/usr/share/tcltk/stubs/gen_lib.tcl is in critcl 3.1.9-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 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | # -*- tcl -*-
# STUBS handling -- Code generation: Writing the initialization code for IMPORTers.
#
# (c) 2011 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
# A stubs table is represented by a dictionary value.
# A gen is a variable holding a stubs table value.
# # ## ### ##### ######## #############
## Requisites
package require Tcl 8.4
package require stubs::gen
package require stubs::container
package require lassign84
namespace eval ::stubs::gen::lib::g {
namespace import ::stubs::gen::*
}
namespace eval ::stubs::gen::lib::c {
namespace import ::stubs::container::*
}
# # ## ### ##### ######## #############
## Implementation.
proc ::stubs::gen::lib::gen {table} {
# Assuming that dependencies only go one level deep, we need to
# emit all of the leaves first to avoid needing forward
# declarations.
variable template
# Assuming that dependencies only go one level deep, we emit all
# of the leaves first to avoid needing forward declarations.
set leaves {}
set roots {}
foreach name [lsort [c::interfaces $table]] {
if {[c::hooks? $table $name]} {
lappend roots $name
} else {
lappend leaves $name
}
}
set headers {}
set variables {}
set hooks {}
foreach name [concat $leaves $roots] {
set capName [g::cap $name]
# POLISH - format the variables code block aligned using
# maxlength of interface names.
lappend headers "\#include \"${name}Decls.h\""
lappend variables "const ${capName}Stubs* ${name}StubsPtr;"
# Check if this is a hook. If yes it needs additional setup.
set parent [Parent $table $name]
if {$parent eq ""} continue
lappend hooks " ${name}StubsPtr = ${parent}StubsPtr->hooks->${name}Stubs;"
}
set pname [c::library? $table] ; # FUTURE: May be separate from the library
# namespaces!
set name [string map {:: _} [c::library? $table]]
set capName [g::cap $name]
set upName [string toupper $name]
set headers [Block $headers]
set variables [Block $variables]
set hooks [Block $hooks]
return [string map \
[list \
@PKG@ $pname \
@@ $name \
@UP@ $upName \
@CAP@ $capName \
@HEADERS@ $headers \
@VARS@ $variables \
@HOOKS@ $hooks \
] $template]
return $text
}
proc ::stubs::gen::lib::Block {list} {
if {![llength $list]} { return "" }
return \n[join $list \n]\n
}
proc ::stubs::gen::lib::make@ {basedir table} {
make [path $basedir [c::library? $table]] $table
}
proc ::stubs::gen::lib::make {path table} {
set c [open $path w]
puts -nonewline $c [gen $table]
close $c
return
}
proc ::stubs::gen::lib::path {basedir name} {
return [file join $basedir ${name}StubLib.c]
}
# # ## ### #####
## Internal helpers.
proc ::stubs::gen::lib::Parent {table name} {
# Check if this interface is a hook for some other interface.
# TODO: Make this a container API command.
foreach intf [c::interfaces $table] {
if {[c::hooks? $table $intf] &&
([lsearch -exact [c::hooksof $table $intf] $name] >= 0)} {
return $intf
}
}
return ""
}
# # ## ### #####
namespace eval ::stubs::gen::lib {
#checker exclude warnShadowVar
variable template [string map {{
} {
}} {
/*
* @@StubLib.c --
*
* Stub object that will be statically linked into extensions that wish
* to access @@.
*/
/*
* We need to ensure that we use the stub macros so that this file contains
* no references to any of the stub functions. This will make it possible
* to build an extension that references @CAP@_InitStubs but doesn't end up
* including the rest of the stub functions.
*/
#ifndef USE_TCL_STUBS
#define USE_TCL_STUBS
#endif
#undef USE_TCL_STUB_PROCS
#include <tcl.h>
#ifndef USE_@UP@_STUBS
#define USE_@UP@_STUBS
#endif
#undef USE_@UP@_STUB_PROCS
@HEADERS@
/*
* Ensure that @CAP@_InitStubs is built as an exported symbol. The other stub
* functions should be built as non-exported symbols.
*/
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT
@VARS@
/*
*----------------------------------------------------------------------
*
* @CAP@_InitStubs --
*
* Checks that the correct version of @CAP@ is loaded and that it
* supports stubs. It then initialises the stub table pointers.
*
* Results:
* The actual version of @CAP@ that satisfies the request, or
* NULL to indicate that an error occurred.
*
* Side effects:
* Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
#ifdef @CAP@_InitStubs
#undef @CAP@_InitStubs
#endif
char *
@CAP@_InitStubs(Tcl_Interp *interp, CONST char *version, int exact)
{
CONST char *actualVersion;
actualVersion = Tcl_PkgRequireEx(interp, "@PKG@", version,
exact, (ClientData *) &@@StubsPtr);
if (!actualVersion) {
return NULL;
}
if (!@@StubsPtr) {
Tcl_SetResult(interp,
"This implementation of @CAP@ does not support stubs",
TCL_STATIC);
return NULL;
}
@HOOKS@
return (char*) actualVersion;
}
}]
namespace export gen make@ make rewrite@ rewrite path
}
# # ## ### ##### ######## #############
package provide stubs::gen::lib 1
return
|