
# Copyright (c) 2001 Pacific Marketing and Consulting
# Author:  Wayne A. Christopher, wayne@pmac.com
#          Pacific Marketing and Consulting, Berkeley, California
#
# Library stuff.

set tar_delim |

proc tarfile_open {fname} {
    set fp [open $fname]
    fconfigure $fp -translation binary -blocking 0
    return $fp
}

proc tarfile_header {fp} {
    set offset [expr [tell $fp] % 512]
    if {$offset} {seek $fp [expr 512 - $offset] current}
    set hdr [read $fp 512]
    if {[eof $fp] ||
        [binary scan $hdr "A100 A8 A8 A8 A12" name mode uid gid size] != 5 ||
        $name == "" || $size == ""} {return ""}
    scan $size "%o" bytes
    return [list [string trim $name] $bytes]
}

proc tarfile_locate {tarfile name} {
    global tar_delim tar_files tar_index
    set index "$tarfile$tar_delim$name"
    if {[info exists tar_files($tarfile)] &&
        [info exists tar_index($index)]} {
        seek $tar_files($tarfile) [lindex $tar_index($index) 0]
        return [lindex $tar_index($index) 1]
    }
    return ""
}

proc tarfile_extract {tarfile mask {outdir ""}} {
    global tar_delim tar_files tar_index
    if {![info exists tar_files($tarfile)]} {return 0}
    set fp $tar_files($tarfile)
    if {$outdir == ""} {set outdir [file dirname $tarfile]}
    set cnt 0
    foreach i [array names tar_index "$tarfile$tar_delim$mask"] {
        set name [lindex [split $i $tar_delim] 1]
        set offset [lindex $tar_index($i) 0]
        set size [lindex $tar_index($i) 1]
        set dir $outdir
        set path [split $name /]
        set len [expr [llength $path] - 1]
        for {set n 0} {$n < $len} {incr n} {
            set d [lindex $path $n]
            if {$d != "" && $d != "."} {
                append dir "/$d"
                cmd_mkdir $dir
            }
        }
        set file [lindex $path $len]
        if {$file != ""} {
            set f [open "$dir/$file" w+]
            fconfigure $f -translation binary
            if {$size} {
                seek $fp $offset
                puts $f [read $fp $size]
            }
            close $f
        }
        incr cnt
    }
    return $cnt
}

proc tarfile_read {tarfile name} {
    global tar_delim tar_files tar_index
    set index "$tarfile$tar_delim$name"
    if {[info exists tar_files($tarfile)] &&
        [info exists tar_index($index)]} {
        set size [lindex $tar_index($index) 1]
        if {$size} {
            set fp $tar_files($tarfile)
            seek $fp [lindex $tar_index($index) 0]
            return [read $fp $size]
        }
    }
    return ""
}

proc library_read_tarfile {dir f} {
    global tar_delim tar_files tar_index
    catch {close $tar_files($f)}
    catch {unset tar_files($f)}
    if [catch {tarfile_open $f} fp] return ""
    #mess "    [backslashify $f]\n"
    set ret ""
    set root ""
    while 1 {
        set hdr [tarfile_header $fp]
        if {$hdr == ""} break
        set ent [lindex $hdr 0]
        set size [lindex $hdr 1]
        if {[string match "*/" $ent] || [file exists "$dir/$ent"]} {
            if {$size} {seek $fp $size current}
            continue
        }
        set offset [tell $fp]
        set index "$f$tar_delim$ent"
        set tar_index($index) [list $offset $size]
        if {[string match "*/model" $ent]} {
            set data [read $fp $size]
            if {$data != ""} {
                set name [file dirname $ent]
                set inf [library_project_info [file tail $name] $index $data]
                if {$inf != ""} {
                    if {[file dirname $name] == "."} {
                        set root .
                    } else {
                        set path [split [file dirname $name] /]
                        if {$root == ""} {set root [lindex $path 0]}
                        set n [expr [llength $path] - 1]
                        while {$n > 0} {
                          set inf [list directory [lindex $path $n] [list $inf]]
                          incr n -1
                        }
                    }
                    lappend ret $inf
                }
            }
        } else {
            if {$size} {seek $fp $size current}
        }
    }
    if {$ret != ""} {
        set tar_files($f) $fp
        if {$root == "" || $root == "."} {
            set root [file rootname [file tail $f]]
        }
        return [list directory $root $ret]
    }
    close $fp
    return ""
}

proc library_dir {lib} {
    global is_airpak env

    foreach p {AIRPAK_ROOT ICEPAK_ROOT} {
	if [info exists env($p)] {
	    regsub \\\$$p $lib $env($p) lib
	}
    }

    return $lib
}

proc library_load_all {} {
    global library_path
    
    foreach dir $library_path {
	set dir [library_dir $dir]
	library_list $dir
    }
}

proc library_list {lib} {
    global tar_files tar_index
    if {[info exists tar_files]} {
        foreach f [array names tar_files] {
            catch {close $tar_files($f)}
        }
        unset tar_files
        unset tar_index
    }
    set lib [library_dir $lib]
    if [file exists $lib/object_library] { set lib $lib/object_library }
    #mess "reading object libraries ...\n"
    busy 1
    set list [library_list_sub $lib]
    #mess "Done.\n"
    busy 0
    return $list
}

proc library_is_ok {dir} {
    return [expr {[file exists $dir/object_library] ||
		  [file exists $dir/macros] ||
		  [file exists $dir/browsers] ||
		  [file exists $dir/materials]}]
}

proc library_name_and_info {dir} {
    set dir1 [library_dir $dir]

    set name ""; set info ""
    set nfile $dir1/library_name
    if ![file exists $nfile] { set nfile $dir1/object_library/library_name }

    set ifile $dir1/library_info
    if ![file exists $ifile] { set ifile $dir1/object_library/library_info }

    if [file exists $nfile] {
	set fp [open $nfile r]
	set name [string trim [gets $fp]]
	close $fp
    }

    if [file exists $ifile] {
	set fp [open $ifile r]
	set info [string trim [read $fp]]
	close $fp
    }
    set can_copy [file exists $dir1/library_read_only]
    return [list $name $info $can_copy]
}

proc library_set_name_and_info {dir name info} {
    set dir1 [library_dir $dir]
    if [file exists $dir1/object_library] { set dir1 $dir1/object_library }

    if [catch {open $dir1/library_name w} fp] {
	user_error $fp
	return
    }
    puts $fp $name
    close $fp

    if [catch {open $dir1/library_info w} fp] {
	user_error $fp
	return
    }
    puts $fp $info
    close $fp
}

proc unused__library_get_browser {dir} {
    set dir [library_dir $dir]
    if [file exists $dir/object_library] { set dir $dir/object_library }
    if [file exists $dir/browser.tcl] {
	set fp [open $dir/browser.tcl r]
	set text [read $fp]
	close $fp
	return $text
    } else {
	return ""
    }
}

proc library_list_sub {dir} {
    set files [lsort [glob -nocomplain $dir/*]]
    set ret ""
    foreach f $files {
	set name [file tail $f]
	switch -- $name {
	    materials - browsers - macros continue
	}
        if {[file isfile $f] && [file extension $name] == ".tar"} {
            set inf [library_read_tarfile $dir $f]
            if {$inf != ""} {
                lappend ret $inf
            }
            continue
        }
	if [file exists $f/model] { set f $f/model }
	switch [file type $f] {
	    directory {
		set sub [library_list_sub $f]
		if {$sub != ""} {
		    lappend ret [list directory $name $sub]
		}
	    }
	    file {
		set inf [library_project_info $name $f]
		if {$inf != ""} {
		    lappend ret $inf
		}
	    }
	}
    }
    return $ret
}

proc library_project_info {name f {data ""}} {
    if {$data == ""} {
        if [catch {open $f r} fp] {return ""}
        set data [read $fp]
        close $fp
    }
    if {[string range $data 0 1] != "\#@"} {return ""}
    set type ""
    foreach line [split $data "\n"] {
        if [string match "object *" $line] {
            set t1 [lindex $line 1]
            if {($t1 != "domain") && ($t1 != "material")
                && ($t1 != "profile")} {
                if {$type == ""} {
                    set type $t1
                } else {
                    set type part
                    break
                }
            }
        }
    }
    if {$type == ""} { set type part }
    return [list object $name $type $f]
}

proc library_object_info {dir file} {
    global tar_delim
    set job_title ""
    set job_notes ""
    set image ""
    if {[string first $tar_delim $file] > 0} {
        set tar [split $file $tar_delim]
        set jdir [file dirname [lindex $tar 1]]
        set data [tarfile_read [lindex $tar 0] "$jdir/job"]
        if {$data != ""} { eval $data }
    } else {
        set jdir [file dirname $file]
        if [file exists $jdir/job] {
            source $jdir/job
        }
        if [file exists $jdir/image.ppm] {
            set image $jdir/image.ppm
        }
    }
    return [list $job_title $job_notes $image]
}

proc library_load_object {dir file part obtype {name ""}} {
    global model_container model_container_root model_read_extra_container
    global tar_delim

    #puts "library_load_object $dir $file $part $obtype"

    set inpfile $file
    if {[string first $tar_delim $file] > 0} {
        set tar [split $file $tar_delim]
        set data [tarfile_read [lindex $tar 0] [lindex $tar 1]]
        puts [list tarfile_read [lindex $tar 0] [lindex $tar 1]]
	puts $data
        if {$data == ""} return
	set base [directory]/tmp_model; set n 0
	while {[file exists $base.$n]} { incr n }
        set inpfile $base.$n
        set fp [open $inpfile w+]
        fconfigure $fp -translation binary
        puts $fp $data
        close $fp
        set file [lindex $tar 1]
    }
    if {$part != ""} {
	set omc $model_container
	set model_container $part
    }
    if {$obtype == "part"} {
	if {$name == ""} {
	    set name [$model_container_root new_name [file tail [file dirname $file]]]
	}
	set np [edit_new part $name]
	$np setval part_type external
	$np setval part_job [file dirname $file]
        $np setval part_file $inpfile
	part_load $np
	$np setval part_type internal
        $np unset part_file

	# Just check to see if this part contains just one sub-part.  If so
	# then move it up.  This happens when you make a library object out
	# of a part.
	set cont [$np list_contents]
	if {([llength $cont] == 1) && ([[lindex $cont 0] getval obtype] == "part")} {
	    set np2 [lindex $cont 0]
	    set new_objects [$np2 list_contents]
	    part_move_object_into $np $new_objects 0
	    edit_delete 0 $np2
	} else {
	    set new_objects $np
	}
    } else {
	set model_read_extra_container [model_container]
	set oldbb [[$model_container getval body_shape] get_bbox]
	if {$oldbb == ""} {
	    set oldbb [[$model_container_root getval body_shape] get_bbox]
	}

	if ![model_read $inpfile 1 1] { return "" }

	set new_objects [$model_read_extra_container list_contents]
	$model_read_extra_container delete
	unset model_read_extra_container

	set newbb [bbox_of_objects $new_objects]
	if {$newbb != ""} {
	    # Center the objects in the part.
	    set omin [lindex $oldbb 0]; set omax [lindex $oldbb 1]
	    set nmin [lindex $newbb 0]; set nmax [lindex $newbb 1]
	    foreach i {0 1 2} {
		set off$i [expr {([lindex $omin $i] + [lindex $omax $i]) / 2.0 -
				 ([lindex $nmin $i] + [lindex $nmax $i]) / 2.0}]
	    }
	    edit_move_apply "" 0 [list do_trans 1 objects $new_objects \
				      xoff $off0 yoff $off1 zoff $off2 \
				      xoff_units m yoff_units m zoff_units m]
	}
    }

    if {$part != ""} {
	set model_container $omc
    }
    if {$inpfile != $file} {
        file delete $inpfile
    }
    return $new_objects
}

proc library_load_part {jobdir bbstart name} {
    if ![file exists $jobdir] { return "" }
    set part [lindex [library_load_object [file dirname $jobdir] \
			  $jobdir/model "" part $name] 0]
    set newbb [bbox_of_objects $part]
    if {$newbb != ""} {
	set nmin [lindex $newbb 0]
	foreach i {0 1 2} {
	    set off$i [expr {[lindex $bbstart $i] - [lindex $nmin $i]}]
	}
	edit_move_apply "" 0 [list do_trans 1 objects $part \
				  xoff $off0 yoff $off1 zoff $off2 \
				  xoff_units m yoff_units m zoff_units m]
    }
    return $part
}

proc library_save_objects {objects lib {parent_node ""}} {
    global file_save domain

    set dir [library_dir $lib]/object_library
    if ![file exists $dir] { set dir [library_dir $lib] }

    set temp_part [model_container]
    set one_name ""
    foreach obj $objects {
	$temp_part add [$obj getval name] $obj
	if {($one_name == "") && ($obj != $domain)} {
	    set one_name [$obj getval name]
	    regsub -all / $one_name _ one_name
	}
    }
    file_save 1 "" $temp_part 0 $dir/$one_name 0 0

    $temp_part delete

    if {$parent_node != ""} {
	tree_fill_library $dir $parent_node
	return

	set inf [library_project_info [file tail $file_save(name)] \
		     $file_save(name)/model]
	set stuff [library_list $dir]
	tree_fill_library_node $parent_node $inf $dir
    }
}

proc library_copy_library_objects {objects lib parent_node} {
    set dir [library_dir $lib]/object_library
    if ![file exists $dir] { set dir [library_dir $lib] }

    foreach {sdir file} $objects {
	set sdir [library_dir $sdir]
	if [file exists $sdir/object_library] { append sdir /object_library/ }

	set tail [string range $file [string length $sdir] end]
	set subdir $dir/[file dirname $tail]
	cmd_mkdir $subdir
	cmd_cp $file $subdir

	# Need these for searching
	foreach f2 {job problem} {
	    set f3 [file dirname $file]/$f2
	    if [file exists $f3] { cmd_cp $f3 $subdir }
	}
    }
    if {$parent_node != ""} {
	tree_fill_library $dir $parent_node
    }
}

# --------------------------------

proc file_libraries {create_new} {
    global library_path library_path_edit

    set buttons ""
    if {$create_new == 2} {
	lappend buttons [list "Select" {form_accept_hack .library_path_select}]
	lappend buttons cancel help
	set form .library_path_select
    } else {
	lappend buttons [list "All projects" {file_libraries_edit_accept .library_path 1}]
	lappend buttons [list "This project" {file_libraries_edit_accept .library_path 0}]
	lappend buttons {New file_libraries_new}
	lappend buttons nl
	lappend buttons {Delete file_libraries_delete}
	lappend buttons cancel help
	set form .library_path
    }
    set d [form_init $form "Library path" "" $buttons]
    if {$d != ""} {
	file_libraries_setup_form 0 $d
	form_finish +300+300
    }
    file_libraries_init_form
    if {$create_new == 1} { file_libraries_new }
    
    if {$create_new == 2} {
	if [form_wait .library_path_select] {
	    return $library_path_edit(path)
	} else {
	    return ""
	}
    }
}

proc file_libraries_setup_form {inc_buts d} {
    global library_path_edit
    
    form_listbox $d.libs "" "" file_libraries_select "" 20x8 {0 0 -cols 2 -rows 2}
    set library_path_edit(listbox) $d.libs
    
    form_label $d.namel "Library name" {10 0}
    form_label $d.pathl "Location" {11 0}
    form_label $d.notesl "Notes" {12 0}
    
    set library_path_edit(notes) ""
    form_entry $d.name library_path_edit(name) string {10 1 -cols 2}
    file_select_entry $d.path library_path_edit(path) 1 1 \
	"Select the library location" {11 1 -cols 2} "" library_is_ok \
	"" "" "" "" "file_libraries_edit_lookup_info" 0 "" Library
    form_text $d.notes "" library_path_edit(notes) {13 0 -cols 3}
    set library_path_edit(notesbox) $d.notes
    
    bind $d.name <Return> { file_libraries_update }
    bind $d.path <Return> { file_libraries_update }
    
    if $inc_buts {
	form_frame $d.buts flat 0 {0 2}
	form_button $d.buts.n "New library" file_libraries_new {0 0 -sticky ew -padx 2 -pady 2}
	form_button $d.buts.d "Delete library" file_libraries_delete {1 0 -sticky ew -padx 2 -pady 2}
    }
}

proc file_libraries_init_form {} {
    global library_path_edit library_path
    
    form_listbox_clear $library_path_edit(listbox)
    set library_path_edit(cur) ""
    set first ""
    foreach dir $library_path {
	if ![file exists [library_dir $dir]] continue
	set inf [library_name_and_info $dir]
	set name [lindex $inf 0]
	set library_path_edit($name,name) $name
	set library_path_edit($name,notes) [lindex $inf 1]
	set library_path_edit($name,path) [library_dir $dir]
	form_listbox_add $library_path_edit(listbox) $name
	if {$first == ""} { set first $name }
    }
    if {$first != ""} { file_libraries_select $first }
}

proc file_libraries_edit_accept {d all} {
    global library_path library_path_edit
    
    if {$d == ".library_path"} { form_accept_hack .library_path }
    
    file_libraries_update
    set names [form_listbox_get $library_path_edit(listbox)]
    set olp ""
    foreach l $library_path { lappend olp [library_dir $l] }
    set library_path ""
    foreach name $names {
	if {$library_path_edit($name,path) == ""} {
	    mess "Skipping library $name - no path given\n" red
	    continue
	}
	lappend library_path $library_path_edit($name,path)
	library_set_name_and_info $library_path_edit($name,path) \
	    $library_path_edit($name,name) $library_path_edit($name,notes)
    }
    if {$olp != $library_path} {
	busy 1
	add_macro_commands
	add_browser_commands
	tree_make_library_subtree
	reload_materials
	busy 0
    }
    
    if {$d == ".library_path"} {
	options_edit_auto_done $d $all
    }
}

proc file_libraries_edit_lookup_info {args} {
    global library_path_edit
    set inf [library_name_and_info $library_path_edit(path)]
    if {[lindex $inf 0] == ""} {
	if {$library_path_edit(name) == ""} { 
	    set library_path_edit(name) $library_path_edit(path)
	}
    } else {
	set library_path_edit(name) [lindex $inf 0]
    }
    set library_path_edit(notes) [lindex $inf 1]
    form_text_set $library_path_edit(notesbox) $library_path_edit(notes)
}

proc file_libraries_select {name} {
    global library_path_edit
    
    file_libraries_update
    
    set library_path_edit(cur) $name
    if {$name == ""} {
	set library_path_edit(name) ""
	set library_path_edit(path) ""
	set library_path_edit(notes) ""
    } else {
	set library_path_edit(name) $library_path_edit($name,name)
	set library_path_edit(path) $library_path_edit($name,path)
	set library_path_edit(notes) $library_path_edit($name,notes)
    }
    form_text_set $library_path_edit(notesbox) $library_path_edit($name,notes)
    form_listbox_select $library_path_edit(listbox) $name
}

proc file_libraries_update {} {
    global library_path_edit
    
    if {$library_path_edit(cur) == ""} return
    
    set cur $library_path_edit(cur)
    set new $library_path_edit(name)
    set library_path_edit($new,name) $library_path_edit(name)
    set library_path_edit($new,path) $library_path_edit(path)
    set library_path_edit($new,notes) \
	[form_text_get $library_path_edit(notesbox)]
    form_listbox_change $library_path_edit(listbox) \
	$library_path_edit(cur) $new
    form_listbox_select $library_path_edit(listbox) $new
    set library_path_edit(cur) $new
}

proc file_libraries_new {} {
    global library_path_edit

    for {set i 1} {[info exists "library_path_edit(Library $i,name)"]} \
	{incr i} {}
    set name "Library $i"
    set library_path_edit($name,name) $name
    set library_path_edit($name,path) ""
    set library_path_edit($name,notes) ""
    form_listbox_add $library_path_edit(listbox) $name
    file_libraries_select $name
}

proc file_libraries_delete {} {
    global library_path_edit icepak_root
    
    #if {$library_path_edit(path) == ""} { user_error "No library is selected" }
    if {$library_path_edit(path) == "$icepak_root/icepak_lib"} {
	if [tk_dialog .main_lib "Main library" "That is the main library.  If you remove it from your library path you may have problems." "" -1 Delete Cancel] return
    }
    set new [form_listbox_delete $library_path_edit(listbox) \
		 $library_path_edit(cur)]
    if {$new != ""} { file_libraries_select $new }
}
