[jdc] 15-jul-2008 This code can be used to create '''ar''' archives, show the table of contents of an archive and extract files from an archive.

======
# Usage: ar.tcl <opts> <archive> ?<files>?
#
#   <opts> : -c   create archive of specified files
#            -t   show table of contents
#            -x   extract specified files of all if non are specified

set aropt [lindex $argv 0]
set arfnm [lindex $argv 1]
set archs [lrange $argv 2 end]

if {$aropt eq "-c"} {

    set arf [open $arfnm w]
    fconfigure $arf -encoding binary -translation binary
    
    puts -nonewline $arf "!<arch>\n"
    
    set strtable ""
    
    foreach fnm $archs {
	file stat $fnm fstat
	set nm [file tail $fnm]
	if {[string length $nm] > 15} {
	    set stroffset($fnm) [string length $strtable]
	    append strtable $nm/\n
	}
    }
    
    if {[string length $strtable]} {
	puts -nonewline $arf [format %-16s //]
	puts -nonewline $arf [format %-12s ""]
	puts -nonewline $arf [format %-6s ""]
	puts -nonewline $arf [format %-6s ""]
	puts -nonewline $arf [format %-8s ""]
	set sl [string length $strtable]
	if {[string length $strtable] % 2} {
	    incr sl
	}
	puts -nonewline $arf [format %-10s $sl]
	puts -nonewline $arf "`\n"
	puts -nonewline $arf $strtable
	if {[tell $arf] % 2} {
	    puts -nonewline $arf "\n"
	}
    }
    
    foreach fnm $archs {
	file stat $fnm fstat
	set nm [file tail $fnm]
	if {[string length $nm] > 15} {
	    puts -nonewline $arf [format %-16s /$stroffset($fnm)]
	} else {    
	    puts -nonewline $arf [format %-16s $nm/]
	}
	puts -nonewline $arf [format %-12s $fstat(mtime)]
	puts -nonewline $arf [format %-6s $fstat(uid)]
	puts -nonewline $arf [format %-6s $fstat(gid)]
	puts -nonewline $arf [format %-8o $fstat(mode)]
	puts -nonewline $arf [format %-10s $fstat(size)]
	puts -nonewline $arf "`\n"
	set df [open $fnm r]
	fconfigure $df -encoding binary -translation binary
	fcopy $df $arf
	close $df
	if {$fstat(size) % 2} {
	    puts -nonewline $arf "\n"
	}
    }

    close $arf

} elseif {$aropt eq "-t" || $aropt eq "-x"} {

    set strtable ""

    set arf [open $arfnm r]
    fconfigure $arf -encoding binary -translation binary
    
    set magic [read $arf 8]
    if {$magic != "!<arch>\n"} {
	return -code error "This is not an archive. Invalid magic number."
    }

    while { 1 } { 
	set ar_name [string trim [read $arf 16] " "]
	if {[eof $arf]} {
	    break
	}
	set ar_date [read $arf 12]
	set ar_uid  [read $arf 6]
	set ar_gid  [read $arf 6]
	set ar_mode [read $arf 8]
	set ar_size [read $arf 10]
	set ar_fmag [read $arf 2]
	if {$aropt eq "-t"} {
	    if {$ar_name ne "//"} {
		if {[string match "/*" $ar_name]} {
		    set sidx [string range $ar_name 1 end]
		    set eidx [string first "/" $strtable $sidx]
		    puts [string range $strtable $sidx $eidx-1]
		} else {
		    puts [string trim $ar_name "/"]
		}
	    }
	}
	set dta [read $arf $ar_size]
	if {$ar_name eq "//"} {
	    set strtable $dta
	}
	if {$aropt eq "-x" && ([llength $archs] == 0 || [lsearch -exact $archs [string trim $ar_name "/"]] >= 0)} {
	    set df [open $ar_name w]
	    fconfigure $df -encoding binary -translation binary
	    puts -nonewline $df $dta
	    close $df
	}
	if {$ar_size % 2} {
	    read $arf 1
	}
    }

    close $arf
}
======

----
!!!!!!
%| enter categories here |%
!!!!!!