[jdc] 15-jul-2008 This code can be used to create '''ar''' archives (a file format used on Unix for link libraries as well as other purposes), 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
}
======

----
!!!!!!
%| [Category Dev. Tools] |%
!!!!!!