/usr/share/tcltk/stubs/gen_slot.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 | # -*- tcl -*-
# STUBS handling -- Code generation: Writing SLOT code.
#
# (c) 2011 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
# # ## ### ##### ######## #############
## Requisites
package require Tcl 8.4
package require stubs::gen
package require lassign84
# lassign84, ditto
namespace eval ::stubs::gen::slot::g {
namespace import ::stubs::gen::*
}
# # ## ### ##### ######## #############
## Implementation.
proc ::stubs::gen::slot::gen {table name} {
return [g::forall $table $name [namespace current]::Make 1 \
" void (*reserved@@)(void);\n"]
}
# # ## ### #####
## Internal helpers.
proc ::stubs::gen::slot::Make {name decl index} {
#puts "SLOT($name $index) = |$decl|"
lassign $decl rtype fname args
set capName [g::uncap $fname]
set text " "
if {![llength $args]} {
append text $rtype " *" $capName "; /* $index */\n"
return $text
}
if {[string range $rtype end-7 end] eq "CALLBACK"} {
append text \
[string trim [string range $rtype 0 end-8]] \
" (CALLBACK *" $capName ") "
} else {
append text $rtype " (*" $capName ") "
}
set arg1 [lindex $args 0]
switch -exact -- $arg1 {
void {
append text "(void)"
}
TCL_VARARGS {
append text [MakeArgs [lrange $args 1 end] ", ..."]
}
default {
append text [MakeArgs $args]
}
}
append text "; /* $index */\n"
return $text
}
proc ::stubs::gen::slot::MakeArgs {arguments {suffix {}}} {
set text ""
set sep "("
foreach arg $arguments {
lassign $arg atype aname aind
append text $sep $atype
if {[string index $text end] ne "*"} {
append text " "
}
append text $aname $aind
set sep ", "
}
append text "$suffix)"
if {[lindex $arguments end] eq "\{const char *\} format"} {
# TCL_VARARGS case... arguments list already shrunken.
set n [llength $arguments]
append text " TCL_FORMAT_PRINTF(" $n ", " [expr {$n + 1}] ")"
}
return $text
}
# # ## ### #####
namespace eval ::stubs::gen::slot {
namespace export gen
}
# # ## ### #####
package provide stubs::gen::slot 1
return
|