/usr/share/tcltk/stubs/gen_init.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 | # -*- tcl -*-
# STUBS handling -- Code generation: Writing the initialization code for EXPORTers.
#
# (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::init::g {
namespace import ::stubs::gen::*
}
namespace eval ::stubs::gen::init::c {
namespace import ::stubs::container::*
}
# # ## ### ##### ######## #############
## Implementation.
proc ::stubs::gen::init::gen {table} {
# Assuming that dependencies only go one level deep, we need to
# 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 text {}
foreach name $leaves {
append text [Emit $table $name]
}
foreach name $roots {
append text [Emit $table $name]
}
return $text
}
proc ::stubs::gen::init::make@ {basedir table} {
make [path $basedir $table] $table
}
proc ::stubs::gen::init::make {path table} {
variable template
set c [open $path w]
puts -nonewline $c \
[string map \
[list @@ [string map {:: _} [c::library? $table]]] \
$template]
close $c
rewrite $path $table
return
}
proc ::stubs::gen::init::rewrite@ {basedir table} {
rewrite [path $basedir $table] $table
return
}
proc ::stubs::gen::init::rewrite {path table} {
g::rewrite $path [gen $table]
return
}
proc ::stubs::gen::init::path {basedir table} {
return [file join $basedir [c::library? $table]StubInit.c]
}
# # ## ### #####
## Internal helpers.
proc ::stubs::gen::init::Emit {table name} {
# See tcllib/textutil as well.
set capName [g::cap $name]
if {[c::hooks? $table $name]} {
append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n"
set sep " "
foreach sub [c::hooksof $table $name] {
append text $sep "&${sub}Stubs"
set sep ",\n "
}
append text "\n\};\n"
}
# Check if this interface is a hook for some other interface.
# TODO: Make this a container API command.
set root 1
foreach intf [c::interfaces $table] {
if {[c::hooks? $table $intf] &&
([lsearch -exact [c::hooksof $table $intf] $name] >= 0)} {
set root 0
break
}
}
# Hooks are local to the file.
append text "\n"
if {!$root} {
append text "static "
}
append text "const ${capName}Stubs ${name}Stubs = \{\n"
append text " TCL_STUB_MAGIC,\n"
if {[c::epoch? $table] ne ""} {
set CAPName [string toupper $name]
append text " ${CAPName}_STUBS_EPOCH,\n"
append text " ${CAPName}_STUBS_REVISION,\n"
}
if {[c::hooks? $table $name]} {
append text " &${name}StubHooks,\n"
} else {
append text " 0,\n"
}
append text [g::forall $table $name [namespace current]::Make 1 \
" 0, /* @@ */\n"]
append text "\};\n"
return $text
}
# Make --
#
# Generate the prototype for a function.
#
# Arguments:
# name The interface name.
# decl The function declaration.
# index The slot index for this function.
#
# Results:
# Returns the formatted declaration string.
proc ::stubs::gen::init::Make {name decl index} {
#puts "INIT($name $index) = |$decl|"
lassign $decl rtype fname args
if {![llength $args]} {
append text " &$fname, /* $index */\n"
} else {
append text " $fname, /* $index */\n"
}
return $text
}
# # ## ### #####
namespace eval ::stubs::gen::init {
#checker exclude warnShadowVar
variable template [string map {{ } {}} {
/* @@StubsInit.c
*
* The contents of this file are automatically generated
* from the @@.decls file.
*
*/
#include "@@.h"
/* !BEGIN!: Do not edit below this line. */
/* !END!: Do not edit above this line. */
}]
namespace export gen make@ make rewrite@ rewrite path
}
# # ## ### ##### ######## #############
package provide stubs::gen::init 1
return
|