This file is indexed.

/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