#! /usr/bin/tclsh
#
# jufdist.tcl -- script for distribution preparations
#
# Copyright (C) 1998 Stefan Hornburg
#
# Author: Stefan Hornburg <racke@gundel.han.de>
# Maintainer: Stefan Hornburg <racke@gundel.han.de>
# Version: 0.0.4
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version.
#
# This file is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY; without even the implied warranty
# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this file; see the file COPYING.  If not, write to the Free
# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

set jufdist_version 0.0.4
set auto_path [concat /usr/lib/jultaf $auto_path]

package require Code
package require Error
package require juf::getopts
package require Sequence
package require Libtool

# Option specifications
set optspecs {
	{"dir|d=s" "Add directory to package search path."}
	{"help|h" "Print this message and exit."}
	{"libdir=s" "Set shared library installation directory to DIR" "DIR"}
	{"libraries|l=s" "Examine Tcl shared libraries LIBS." "LIBS"}
	{"output-file|o=s" "Use FILE as output file instead of pkgIndex.tcl" "FILE"}
	{"strip-directories|p" "Strip directories from file names."}
	{"subdirectory|s=s" "Add DIR to library script location." DIR}
}

# Errors
set errcount 0
# Array with interpreter aliases
array set als {
	package package_filter proc proc_filter
	class class_filter body nop configbody nop
}
array set renames {
	package package_interned proc proc_interned
}
# Array with variables
array set vars [list auto_path $auto_path]

# Dummy function
proc nop {args} {}

# -------------------------
# PROC: usage
#
# Prints usage information.
# -------------------------

proc usage {} {
	global optspecs

	juf_getopts_listspecs $optspecs
}

# -----------------------------------------------------------------
# PROC: main
#
# Main program.
#
# Global variables:
# The elements in `commands are the classes defined by the current
# library file. Classes supplied by packages are stored in the
# array `pkgcmds.
# -----------------------------------------------------------------

proc main {args} {
	global als vars errcount jufdist_version libfile packages optspecs
	global interp renames auto_path
	global commands pkgcmds autocmds

	juf_getopts $optspecs optarr args $args
	if [info exists optarr(help)] {
		usage
		exit 0
	}
	if [info exists optarr(dir)] {
		set vars(auto_path) [concat $optarr(dir) $auto_path]
	}
	if ![info exists optarr(output_file)] {
		set optarr(output_file) pkgIndex.tcl
	}
	#
	# initialize package array with predefined and applicable packages
	#
	foreach package [list Tcl Itcl] {
		if ![catch [list package require $package] excinfo] {
			set packages($package) [package require $package]
		}
	}
	
	foreach libfile $args {
		set commands ""
		if [catch [list juf_safe_source -exit finish_script -interp interp -renames renames\
				-nosafe -aliases als -variables vars $libfile] excinfo] {
			Juf::Error::error $libfile $excinfo
			global errorInfo
			puts $errorInfo
			incr errcount
		}
		# determine packages provided by this library file
		if [llength $commands] {
			foreach package [array names packages] {
				if {[llength $packages($package)] >= 2} {
					if ![string compare [lindex $packages($package) 0] \
							$libfile] {
						set pkgcmds($package) $commands
						set autoentries($package) [array get autocmds]
					}
				}
			}
		}
		if [info exists autocmds] {
			unset autocmds
		}
	}

	if $errcount {exit 1}

	#
	# check for unresolved packages
	#
	foreach package [array names packages] {
		if {[llength $packages($package)] < 2} {
			unset packages($package)
		}
	}
	if [info exists packages(Itcl)] {
		unset packages(Itcl)
	}
	if $errcount {exit 1}

	#
	# handle shared libraries
	#
	if [info exists optarr(libraries)] {
		foreach shlib $optarr(libraries) {
			set shlibarr($shlib) [Juf::Libtool::packagelist $shlib]
		}
	}
	#
	# create pkgIndex.tcl file
	#
	lappend index {# Tcl package index file, version 1.0}
	lappend index {#}
	lappend index "# Automatically generated with jufdist v$jufdist_version"
	lappend index "# [clock format [clock seconds]]"
	lappend index {#}
	#
	# packages provided by shared libraries
	#
	foreach shlib [array names shlibarr] {
		if [info exists optarr(libdir)] {
			set libloc "$optarr(libdir)/[file tail $shlib]"
		} else {
			set libloc $shlib
		}
		foreach pkginfo $shlibarr($shlib) {
			lappend index "package ifneeded [lindex $pkginfo 0] [lindex $pkginfo 1] \"load $libloc\""
		}
	}
	#
	# vanilla Tcl packages
	#
	foreach package [array names packages] {
		Juf::Sequence::assign $packages($package) libfile version
		if [info exists optarr(strip_directories)] {
			set libfile [file tail $libfile]
		}
		if [info exists optarr(subdirectory)] {
			set subdir [list $optarr(subdirectory)]
		} else {
			set subdir ""
		}
		if [info exists pkgcmds($package)] {
			lappend index "package ifneeded $package $version \""
			while {[llength $autoentries($package)]} {
				set cmd [Juf::Sequence::shift autoentries($package)]
				set code [Juf::Sequence::shift autoentries($package)]
				lappend index "\tset auto_index($cmd) {$code}"
			}
			foreach cmd $pkgcmds($package) {
				lappend index "\tset auto_index([string range $cmd 2 end]) {source \[file join \$dir $subdir $libfile\]}"
			}
			lappend index "\tpackage provide $package $version\""
		} else {
			lappend index "package ifneeded $package $version \\"
			lappend index "\t\[list source \[file join \$dir $subdir $libfile\]\]"
		}
	}
	set fd [open $optarr(output_file) w]
	puts $fd [join $index "\n"]
	close $fd
}

# -------------------------------------------------------------------
# PROC: package_filter ARGS
#
# Filter for calls to Tcl `package' command. Stores information about
# any call with the subcommand `provide'.
# -------------------------------------------------------------------

proc package_filter {args} {
	global packages libfile errcount unresolved
	global interp pkgcmds procs

	set argsbuf $args
	lappend argsbuf ""
	Juf::Sequence::assign $argsbuf op package version
	juf_branch $op provide {
		if [string length $version] {
			# indicate that package is loaded
			if [info exists packages($package)] {
				if {[llength $packages($package)] > 1} {
					if {[string compare $version [lindex $packages($package) 1]] != 0} {
						Juf::Error::error "conflicting versions provided for package \"$package\": [lindex $packages($package) 1], then $version"
						incr errcount
					} else {
						return $version
					}
				} else {
					return $version
				}
			} else {
				set packages($package) [list $libfile $version]
				return $version
			}
		} elseif [info exists packages($package)] {
			return [lindex $packages($package) end]
		}
	} require {
		if ![info exists packages($package)] {
			if [info exists version] {
				#
				# store required version
				#
				set packages($package) [list $version]
			} else {
				set packages($package) ""
				set version ""
			}
			if [catch [list $interp eval [package unknown] $package [list \
					$version]] excinfo] {
				Juf::Error::error $libfile $excinfo
				incr errcount
			} else {
				#
				# check for success
				#
				if ![string length [$interp eval package versions $package]] {
					error "can't find package \"$package\""
				}
			}
		} else {
			# install commands provided by package
			if [info exists pkgcmds($package)] {
				foreach provcmd $pkgcmds($package) {
					if [info exists procs($provcmd)] {
						proc_install $interp $provcmd
					}
				}
			}
			return [lindex $packages($package) end]
		}
	} default {
		$interp eval package_interned $args
	}
}

# -----------------------------------------------
# PROC: proc_filter NAME DEF
#
# Filter for calls to [incr Tcl] `proc' command.
# -----------------------------------------------

proc proc_filter {name args} {
	global interp commands procs

	if {[string first :: $name] != 0} {
		if [string length [$interp eval namespace parent]] {
			set name [$interp eval namespace current]::$name
		} else {
			set name ::$name
		}
	}
	lappend commands $name
	# store proc
	set procs($name) $args
	# define proc
	proc_install $interp $name
}

# -------------------------------------------------
# PROC: proc_install INTERP NAME
#
# Defines procedure NAME within interpreter INTERP.
# -------------------------------------------------

proc proc_install {interp name} {
	global procs

	# Analyse namespace and create missing ones
	$interp eval namespace eval [list [namespace qualifiers $name]] [list ""]
	$interp eval proc_interned $name [list [lindex $procs($name) 0]] \
			[lrange $procs($name) 1 end]
}

# -----------------------------------------------
# PROC: class_filter NAME DEF
#
# Filter for calls to [incr Tcl] `class' command.
# -----------------------------------------------

proc class_filter {name def} {
	global interp commands

	lappend commands ::$name
	$interp alias $name nop
}

# ------------------------------------------------
# PROC: finish_script INTERP
#
# Detects manually inserted entries of auto_index.
# ------------------------------------------------

proc finish_script {interp} {
	global libfile autocmds package

	foreach entry [$interp eval array names auto_index] {
		set autocmds($entry) [$interp eval set auto_index($entry)]
		regsub -all -- "\\\$" $autocmds($entry) "\\\$" autocmds($entry)
	}
}

eval main $argv

