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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
|
# cfront.tcl --
#
# Generator frontend for compiler of magic(5) files into recognizers
# based on the 'rtcore'. Parses magic(5) into a basic 'script'.
#
# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cfront.tcl,v 1.7 2008/03/22 01:10:32 andreas_kupries Exp $
#####
#
# "mime type recognition in pure tcl"
# http://wiki.tcl.tk/12526
#
# Tcl code harvested on: 10 Feb 2005, 04:06 GMT
# Wiki page last updated: ???
#
#####
# ### ### ### ######### ######### #########
## Requirements
package require Tcl 8.4
# file to compile the magic file from magic(5) into a tcl program
package require fileutil ; # File processing (input)
package require fileutil::magic::cgen ; # Code generator.
package require fileutil::magic::rt ; # Runtime (typemap)
package require struct::list ; # lrepeat.
package provide fileutil::magic::cfront 1.0
# ### ### ### ######### ######### #########
## Implementation
namespace eval ::fileutil::magic::cfront {
# Configuration flag. (De)activate debugging output.
# This is done during initialization.
# Changes at runtime have no effect.
variable debug 0
# Constants
variable hashprotection [list "\#" "\\#" \" \\\" \{ \\\{ \} \\\}] ;#"
variable hashprotectionB [list "\#" "\\\#" \" \\\" \} \\\} ( \\( ) \\)] ;#"
# Make backend functionality accessible
namespace import ::fileutil::magic::cgen::*
namespace export compile procdef install
}
# parse an individual line
proc ::fileutil::magic::cfront::parseline {line {maxlevel 10000}} {
# calculate the line's level
set unlevel [string trimleft $line >]
set level [expr {[string length $line] - [string length $unlevel]}]
if {$level > $maxlevel} {
return -code continue "Skip - too high a level"
}
# regexp parse line into (offset, type, value, command)
set parse [regexp -expanded -inline {^(\S+)\s+(\S+)\s*((\S|(\B\s))*)\s*(.*)$} $unlevel]
if {$parse == {}} {
error "Can't parse: '$unlevel'"
}
# unpack parsed line
set value ""
set command ""
foreach {junk offset type value junk1 junk2 command} $parse break
# handle trailing spaces
if {[string index $value end] eq "\\"} {
append value " "
}
if {[string index $command end] eq "\\"} {
append command " "
}
if {$value eq ""} {
# badly formatted line
return -code error "no value"
}
::fileutil::magic::cfront::Debug {
puts "level:$level offset:$offset type:$type value:'$value' command:'$command'"
}
# return the line's fields
return [list $level $offset $type $value $command]
}
# process a magic file
proc ::fileutil::magic::cfront::process {file {maxlevel 10000}} {
variable hashprotection
variable hashprotectionB
variable level ;# level of line
variable linenum ;# line number
set level 0
set script {}
set linenum 0
::fileutil::foreachLine line $file {
incr linenum
set line [string trim $line " "]
if {[string index $line 0] eq "#"} {
continue ;# skip comments
} elseif {$line == ""} {
continue ;# skip blank lines
} else {
# parse line
if {[catch {parseline $line $maxlevel} parsed]} {
continue ;# skip erroring lines
}
# got a valid line
foreach {level offset type value message} $parsed break
# strip comparator out of value field,
# (they are combined)
set compare [string index $value 0]
switch -glob -- $value {
[<>]=* {
set compare [string range $value 0 1]
set value [string range $value 2 end]
}
<* - >* - &* - ^* {
set value [string range $value 1 end]
}
=* {
set compare "=="
set value [string range $value 1 end]
}
!* {
set compare "!="
set value [string range $value 1 end]
}
x {
# this is the 'don't care' match
# used for collecting values
set value ""
}
default {
# the default comparator is equals
set compare "=="
if {[string match {\\[<!>=]*} $value]} {
set value [string range $value 1 end]
}
}
}
# process type field
set qual ""
switch -glob -- $type {
pstring* - string* {
# String or Pascal string type
# extract string match qualifiers
foreach {type qual} [split $type /] break
# convert pstring to string + qualifier
if {$type eq "pstring"} {
append qual "p"
set type "string"
}
# protect hashes in output script value
set value [string map $hashprotection $value]
if {($value eq "\\0") && ($compare eq ">")} {
# record 'any string' match
set value ""
set compare x
} elseif {$compare eq "!="} {
# string doesn't allow !match
set value !$value
set compare "=="
}
if {$type ne "string"} {
# don't let any odd string types sneak in
puts stderr "Reject String: ${file}:$linenum $type - $line"
continue
}
}
regex {
# I am *not* going to handle regex
puts stderr "Reject Regex: ${file}:$linenum $type - $line"
continue
}
*byte* - *short* - *long* - *date* {
# Numeric types
# extract numeric match &qualifiers
set type [split $type &]
set qual [lindex $type 1]
if {$qual ne ""} {
# this is an &-qualifier
set qual &$qual
} else {
# extract -qualifier from type
set type [split $type -]
set qual [lindex $type 1]
if {$qual ne ""} {
set qual -$qual
}
}
set type [lindex $type 0]
# perform value adjustments
if {$compare ne "x"} {
# trim redundant Long value qualifier
set value [string trimright $value L]
if {[catch {set value [expr $value]} x]} {
upvar #0 errorInfo eo
# check that value is representable in tcl
puts stderr "Reject Value Error: ${file}:$linenum '$value' '$line' - $eo"
continue;
}
# coerce numeric value into hex
set value [format "0x%x" $value]
}
}
default {
# this is not a type we can handle
puts stderr "Reject Unknown Type: ${file}:$linenum $type - $line"
continue
}
}
}
# collect some summaries
::fileutil::magic::cfront::Debug {
variable types
set types($type) $type
variable quals
set quals($qual) $qual
}
#puts $linenum level:$level offset:$offset type:$type
#puts qual:$qual compare:$compare value:'$value' message:'$message'
# protect hashes in output script message
set message [string map $hashprotectionB $message]
if {![string match "(*)" $offset]} {
catch {set offset [expr $offset]}
}
# record is the complete match command,
# encoded for tcl code generation
set record [list $linenum $type $qual $compare $offset $value $message]
if {$script == {}} {
# the original script has level 0,
# regardless of what the script says
set level 0
}
if {$level == 0} {
# add a new 0-level record
lappend script $record
} else {
# find the growing edge of the script
set depth [::struct::list repeat [expr $level] end]
while {[catch {
# get the insertion point
set insertion [eval [linsert $depth 0 lindex $script]]
# 8.5 # set insertion [lindex $script {*}$depth]
}]} {
# handle scripts which jump levels,
# reduce depth to current-depth+1
set depth [lreplace $depth end end]
}
# add the record at the insertion point
lappend insertion $record
# re-insert the record into its correct position
eval [linsert [linsert $depth 0 lset script] end $insertion]
# 8.5 # lset script {*}$depth $insertion
}
}
#puts "Script: $script"
return $script
}
# compile up magic files or directories of magic files into a single recognizer.
proc ::fileutil::magic::cfront::compile {args} {
set tcl ""
set script {}
foreach arg $args {
if {[file type $arg] == "directory"} {
foreach file [glob [file join $arg *]] {
set script1 [process $file]
eval [linsert $script1 0 lappend script [list file $file]]
# 8.5 # lappend script [list file $file] {*}$script1
#append tcl "magic::file_start $file" \n
#append tcl [run $script1] \n
}
} else {
set file $arg
set script1 [process $file]
eval [linsert $script1 0 lappend script [list file $file]]
# 8.5 # lappend script [list file $file] {*}$script1
#append tcl "magic::file_start $file" \n
#append tcl [run $script1] \n
}
}
#puts stderr $script
::fileutil::magic::cfront::Debug {puts "\# $args"}
set t [2tree $script]
set tcl [treegen $t root]
append tcl "\nreturn \{\}"
::fileutil::magic::cfront::Debug {puts [treedump $t]}
#set tcl [run $script]
return $tcl
}
proc ::fileutil::magic::cfront::procdef {procname args} {
set pspace [namespace qualifiers $procname]
if {$pspace eq ""} {
return -code error "Cannot generate recognizer in the global namespace"
}
set script {}
lappend script "package require fileutil::magic::rt"
lappend script "namespace eval [list ${pspace}] \{"
lappend script " namespace import ::fileutil::magic::rt::*"
lappend script "\}"
lappend script ""
lappend script [list proc ${procname} {} \n[eval [linsert $args 0 compile]]\n]
return [join $script \n]
}
proc ::fileutil::magic::cfront::install {args} {
foreach arg $args {
set path [file tail $arg]
eval [procdef ::fileutil::magic::/${path}::run $arg]
}
return
}
# ### ### ### ######### ######### #########
## Internal, debugging.
if {!$::fileutil::magic::cfront::debug} {
# This procedure definition is optimized out of using code by the
# core bcc. It knows that neither argument checks are required,
# nor is anything done. So neither results, nor errors are
# possible, a true no-operation.
proc ::fileutil::magic::cfront::Debug {args} {}
} else {
proc ::fileutil::magic::cfront::Debug {script} {
# Run the commands in the debug script. This usually generates
# some output. The uplevel is required to ensure the proper
# resolution of all variables found in the script.
uplevel 1 $script
return
}
}
#set script [magic::compile {} /usr/share/misc/file/magic]
#puts "\# types:[array names magic::types]"
#puts "\# quals:[array names magic::quals]"
#puts "Script: $script"
# ### ### ### ######### ######### #########
## Ready for use.
# EOF
|