Check-in [c629207a79]

Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fix to scanning of files. Do not scan beyond a ^Z eof marker. I.e. do not scan the assets a file may have attached to their end.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:c629207a799ae785736020c82bdc3a8238e071b8
User & Date: aku 2017-10-04 19:12:40
Context
2017-10-04
23:28
Added `kt::local*`, a variant of `kt::local` which does not forget the package and force a re-load. check-in: c0f0b90c04 user: aku tags: trunk
19:12
Fix to scanning of files. Do not scan beyond a ^Z eof marker. I.e. do not scan the assets a file may have attached to their end. check-in: c629207a79 user: aku tags: trunk
03:23
Fix handling of @owns when scanning file in a subdirectory of the sources. check-in: 8bd2dcddb1 user: aku tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to path.tcl.

176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
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
...
492
493
494
495
496
497
498




499
500
501
502
503
504
505
	lappend r $line
	set done yes
    }
    join $r \n
}

proc ::kettle::path::tcl-package-file {file} {
    set contents   [cat $file]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

................................................................................
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::critcl3-package-file {file} {
    set contents   [cat $file]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

................................................................................
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::doctools-file {path} {
    set test [cathead $path 1024 -translation binary]
    # anti marker
    if {[regexp -- {--- !doctools ---}            $test]} { return 0 }
    if {[regexp -- "!tcl\.tk//DSL doctools//EN//" $test]} { return 0 }
    # marker
    if {[regexp "\\\[manpage_begin "             $test]} { return 1 }
    if {[regexp -- {--- doctools ---}            $test]} { return 1 }
    if {[regexp -- "tcl\.tk//DSL doctools//EN//" $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::diagram-file {path} {
    set test [cathead $path 1024 -translation binary]
    # marker
    if {[regexp {tcl.tk//DSL diagram//EN//1.0} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::tcltest-file {path} {
    set test [cathead $path 1024 -translation binary]
    # marker
    if {[regexp {tcl.tk//DSL tcltest//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::teapot-file {path} {
    set test [cathead $path 1024 -translation binary]
    # marker
    if {[regexp {tcl.tk//DSL teapot//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::bench-file {path} {
    set test [cathead $path 1024 -translation binary]
    # marker
    if {[regexp {tcl.tk//DSL tclbench//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::kettle-build-file {path} {
    set test [cathead $path 100 -translation binary]
    # marker (no anti-markers)
    if {[regexp {kettle -f} $test]} { return 1 }
    return 0
}

proc ::kettle::path::foreach-file {path pv script} {
    upvar 1 $pv thepath
................................................................................
}

proc ::kettle::path::ensure-cleanup {path} {
    ::atexit [lambda {path} {
	file delete -force $path
    } [norm $path]]
}





proc ::kettle::path::cat {path args} {
    set c [open $path r]
    if {[llength $args]} { fconfigure $c {*}$args }
    set contents [read $c]
    close $c
    return $contents







|







 







|







 







|












|







|







|







|







|







 







>
>
>
>







176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
...
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
...
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
...
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
	lappend r $line
	set done yes
    }
    join $r \n
}

proc ::kettle::path::tcl-package-file {file} {
    set contents   [c/z [cat $file]]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

................................................................................
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::critcl3-package-file {file} {
    set contents   [c/z [cat $file]]
    set provisions [grep {*package provide *} $contents]
    if {![llength $provisions]} {
	return 0
    }

    io trace {    Testing: [relativesrc $file]}

................................................................................
    }

    # No candidate satisfactory.
    return 0
}

proc ::kettle::path::doctools-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # anti marker
    if {[regexp -- {--- !doctools ---}            $test]} { return 0 }
    if {[regexp -- "!tcl\.tk//DSL doctools//EN//" $test]} { return 0 }
    # marker
    if {[regexp "\\\[manpage_begin "             $test]} { return 1 }
    if {[regexp -- {--- doctools ---}            $test]} { return 1 }
    if {[regexp -- "tcl\.tk//DSL doctools//EN//" $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::diagram-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL diagram//EN//1.0} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::tcltest-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL tcltest//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::teapot-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL teapot//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::bench-file {path} {
    set test [c/z [cathead $path 1024 -translation binary]]
    # marker
    if {[regexp {tcl.tk//DSL tclbench//EN//} $test]} { return 1 }
    # no usable marker
    return 0
}

proc ::kettle::path::kettle-build-file {path} {
    set test [c/z [cathead $path 100 -translation binary]]
    # marker (no anti-markers)
    if {[regexp {kettle -f} $test]} { return 1 }
    return 0
}

proc ::kettle::path::foreach-file {path pv script} {
    upvar 1 $pv thepath
................................................................................
}

proc ::kettle::path::ensure-cleanup {path} {
    ::atexit [lambda {path} {
	file delete -force $path
    } [norm $path]]
}

proc ::kettle::path::c/z {content} {
    return [lindex [split $content \x1A] 0]
}

proc ::kettle::path::cat {path args} {
    set c [open $path r]
    if {[llength $args]} { fconfigure $c {*}$args }
    set contents [read $c]
    close $c
    return $contents