# $Id$
$VERSION{''.__FILE__} = '$Revision$';
#
# >>Title:: Name Processing Library
#
# >>Copyright::
# Copyright (c) 1992-1996, Ian Clatworthy (ianc@mincom.com).
# You may distribute under the terms specified in the LICENSE file.
#
# >>History::
# -----------------------------------------------------------------------
# Date Who Change
# 29-Feb-96 ianc SDF 2.000
# -----------------------------------------------------------------------
#
# >>Purpose::
# This library provides support for file-name processing.
# With careful use, the routines provide portability across
# [[Unix]]-like and [[Windows]]-like file-naming systems.
#
# >>Description::
#
# >>Limitations::
#
# >>Resources::
#
# >>Implementation::
#
######### Constants #########
#
# >>Description::
# {{Y:NAME_OS}} returns the current operating system style, either
# {{unix}} or {{dos}}. {{Y:NAME_DIR_TABLE}} and {{Y:NAME_PATH_TABLE}}
# are lookup tables of directory and path separators for different
# operating system styles. {{Y:NAME_DIR_SEP}} and {{Y:NAME_PATH_SEP}}
# are the respective separators for {{NAME_OS}}.
#
$NAME_OS = $ENV{'COMSPEC'} ? 'dos' : 'unix';
$NAME_OS = 'mac' if $^O =~ /Mac/;
%NAME_DIR_TABLE = (
'unix', '/',
'dos', '\\',
'mac', ':',
);
%NAME_PATH_TABLE = (
'unix', ':',
'dos', ';',
'mac', ';',
);
$NAME_DIR_SEP = $NAME_DIR_TABLE{$NAME_OS};
$NAME_PATH_SEP = $NAME_PATH_TABLE{$NAME_OS};
######### Variables #########
# Lookup tables of conversion rules built by NameLoadConversionRules()
%_name_conversion_sources = ();
%_name_conversion_actions = ();
######### Routines #########
#
# >>Description::
# {{Y:NameOS}} returns the SDF version of the OS name.
#
sub NameOS {
return $NAME_OS;
}
#
# >>Description::
# {{Y:NameIsAbsolute}} returns 1 if the name is in absolute (or
# non-relative) format.
#
sub NameIsAbsolute {
local($name) = @_;
local($result);
SWITCH: {
$result = $name =~ m#^\/#, last SWITCH if $NAME_OS eq 'unix';
$result = $name =~ m#^([A-Za-z]:)?[\\/]#, last SWITCH if $NAME_OS eq 'dos';
$result = $name =~ m#^[^:]+:#, last SWITCH if $NAME_OS eq 'mac';
die "Unknown OS: $NAME_OS";
}
return $result;
}
#
# >>Description::
# {{Y:NameAbsolute}} returns the absolute name for a file.
#
sub NameAbsolute {
local($name) = @_;
local($result);
local($pwd);
# If already absolute, do nothing
return $name if &NameIsAbsolute($name);
# Get & prepend the current directory
$pwd = $NAME_OS eq 'unix' || $NAME_OS eq 'mac' ? `pwd` : `cd`;
chop($pwd);
return &NameJoin($pwd, $name);
}
#
# >>Description::
# {{Y:NameFind}} searches the directories for a file with the name
# given. If found, the combined name (directory + local name) is returned.
# If the name is absolute, the file is checked to exist. i.e. the directories
# are not searched.
# In either case, if the file is not found, an empty string is returned.
#
sub NameFind {
local($name, @dirs) = @_;
local($found_name);
local($dir, $full);
# handle "-": return itself
return $name if $name eq "-";
# handle absolute filenames
if (&NameIsAbsolute($name)) {
if (-r $name) {
return $name;
}
else {
return "";
}
}
$DB::single = 1;
if($NAME_OS eq 'mac') {
$name =~ s#/#:#g ;
$name =~ s#^:##;
}
# Otherwise, search for the name
foreach $dir (@dirs) {
if ($NAME_OS eq 'mac') {
$dir = "" if $dir eq '.';
$dir =~ s#/#:#g;
$dir =~ s#:$##;
}
if ($dir eq $NAME_DIR_SEP) {
$full = $dir . $name;
}
else {
$full = $dir . $NAME_DIR_SEP . $name;
}
if (-r $full) {
return $full;
}
}
# If we reach here, we had no luck
return "";
}
#
# >>Description::
# {{Y:NameSplit}} extracts components from a name.
# {{short}} is the name without the directory.
#
sub NameSplit {
local($name) = @_;
local($dir, $base, $ext, $short);
# Ensure unix style
$base = $name;
$base =~ s#\\#/#g if $NAME_OS eq "dos";
$base =~ s#\:#/#g if $NAME_OS eq "mac";
# get directory and base.ext
if ($base =~ m#/([^/]+)$#) {
$dir = $`;
$base = $1;
}
# get extension
if ($base =~ m#\.([^\.]+)$#) {
$base = $`;
$ext = $1;
}
# Return result
$dir =~ s#\/#:#g if $NAME_OS eq "mac";
$short = &NameJoin("", $base, $ext);
return ($dir, $base, $ext, $short);
}
#
# >>Description::
# {{Y:NamePathComponentSplit}} completely splits a path into its component parts.
# Returns a list of the parts.
#
sub NamePathComponentSplit {
my $sep;
my $path = shift @_;
$sep = '/';
$sep = '\\' if $NAME_OS eq 'dos';
$sep = ':' if $NAME_OS eq 'mac';
return split $sep, $path;
}
#
# >>Description::
# {{Y:NameJoin}} builds a name from its components. If the base name is
# already absolute, the directory is not prepended.
#
sub NameJoin {
local($dir, $base, $ext) = @_;
local($name);
# handle "-": return itself
$name = $base;
return $name if $name eq "-";
# prepend directory if present and name is not already absolute
if ($dir && ! &NameIsAbsolute($name)) {
$name = $dir . $NAME_DIR_SEP . $name;
}
# append extension, if any
$name .= ".$ext" if $ext;
return $name;
}
#
# >>Description::
# {{Y:NameSubExt}} substitutes the extension on a name.
#
sub NameSubExt {
local($name, $new_ext) = @_;
local($new_name);
local($dir, $base, $ext);
($dir, $base, $ext) = &NameSplit($name);
return &NameJoin($dir, $base, $new_ext);
}
#
# >>Description::
# {{Y:NameLoadConversionRules}} loads a table of conversion rules to
# be used by {{Y:NameFindOrGenerate}}. The fields in {{@table}} are:
#
# * {{Context}} - the driver for which this conversion applies
# * {{To}} - the destination figure format
# * {{From}} - the original figure format
# * {{Action}} - the command to use to do the conversion.
#
# Rules do not chain, so defining rules for A->B and B->C do not
# imply that A will be converted to C. If {{validate}} is set,
# the table is validated.
#
#
sub NameLoadConversionRules {
local(*table, $validate) = @_;
# local();
# Validate the table
&TableValidate(*table, *_SDF_CONVERSION_RULES) if $validate;
# Load the rules
local @flds;
my $rec;
my %values;
my $context;
my $to;
my $from;
my $action;
@flds = &TableFields(shift(@table));
for $rec (@table) {
%values = &TableRecSplit(*flds, $rec);
$context = $values{'Context'};
$to = $values{'To'};
$from = $values{'From'};
$action = $values{'Action'};
push(@{$_name_conversion_sources{$context,$to}}, $from);
$_name_conversion_actions{$context,$from,$to} = $action;
}
## Dump the table, if debugging
#for $igc (sort keys %_name_conversion_sources) {
# $aref = $_name_conversion_sources{$igc};
# print "$igc: ";
# for $igc2 (@$aref) {
# print " $igc2";
# }
# print "\n";
#}
}
#
# >>Description::
# {{Y:NameFindOrGenerate}} searches a list of directories for a file
# with one of the list of extensions. The extensions are searched
# for in the order given. If {{NameLoadConversionRules}} has been
# called, this routine will attempt to generate a file in the current
# directory using the nominated {{context}}, if any. If a file was found
# or generated, the combined name (directory + local name) is returned.
# If the name is absolute, the file is checked to exist. i.e. the directories
# are not searched.
# In either case, if the file is not found, an empty string is returned.
#
sub NameFindOrGenerate {
local($name, $dir_list_ref, $ext_list_ref, $context) = @_;
local($full);
local($dir);
# handle "-": return itself
return $name if $name eq "-";
# handle absolute filenames
if (&NameIsAbsolute($name)) {
if (-r $name) {
return $name;
}
else {
return "";
}
}
# Otherwise, search for the name
foreach $dir (@$dir_list_ref) {
$dir =~ s#/#:#g if $NAME_OS eq 'mac';
$dir = "" if $dir eq '.' && $NAME_OS eq 'mac';
$full = &NameFindInDirectory($dir, $name, $ext_list_ref, $context);
return $full if $full ne '';
}
# If we reach here, we had no luck
return "";
}
#
# >>Description::
# {{Y:NameFindInDirectory}} attempts to find a file directory {{dir}}
# using {{base}} and the set of extensions given by {{$ext_list_ref}}.
# For each base.ext combination, if it doesn't find that file,
# it tries to generate a file of that name in the current
# directory using:
#
# * the conversion rules loaded by {{Y:NameLoadConversionRules}}
# * the files called {{base.*}} in the {{dir}} directory
# * the {{context}}
#
# If the file is found or generated, its name is returned,
# otherwise an empty string is returned.
#
# Note: If the base already has an extension, the extension list isn't used.
#
sub NameFindInDirectory {
local($dir, $base, $ext_list_ref, $context) = @_;
local($full);
# If the base already has an extension, don't use the extension list
my $ext = (&'NameSplit($base))[2];
my @exts = $ext ne '' ? ($ext) : @$ext_list_ref;
$base = &NameSubExt($base, '') if $ext ne '';
# Find/generate the file
my %rules = %{$_name_conversions{$context}};
my $i;
for ($i = 0; $i <= $#exts; $i++) {
$ext = $exts[$i];
$full = &NameJoin($dir, $base, $ext);
return $full if -r $full;
# Try generating the file
my $source_ext;
my $action;
my $source;
my $dest;
for $source_ext (@{$_name_conversion_sources{$context,$ext}}) {
$action = $_name_conversion_actions{$context,$source_ext,$ext};
$source = &NameJoin($dir, $base, $source_ext);
if (-r $source) {
$dest = &NameJoin('.', $base, $ext);
# Do parameter substitution on the action
my $cmd = eval '"' . $action . '"';
if ($@) {
&AppMsg('warning', "error in conversion action '$action': $@");
next;
}
# Generate the file and check it exists
my $exit_code = system($cmd);
if ($exit_code) {
&AppMsg('warning', "error in conversion from '$source' to '$dest': $@");
}
return $dest if -r $dest;
}
}
}
# If we reach here, we had no luck
return "";
}
# package return value
1;