File Coverage

blib/lib/Hub/Base/FileSystem.pm

Criterion	Covered	Total	%
statement	94	456	20.6
branch	20	258	7.7
condition	9	76	11.8
subroutine	20	46	43.4
pod	31	31	100.0
total	174	867	20.0

package Hub::Base::FileSystem;
use strict;
use IO::File;
use IO::Dir;
use IO::Handle;
use Fcntl qw/:flock/;
use File::Copy qw/copy/;
use Hub qw/:lib/;
our $VERSION = '4.00043';
our @EXPORT = qw//;
our @EXPORT_OK = qw/
  SEPARATOR
  META_FILENAME
  $MODE_TO_MASK
  fileopen
  fileclose
  filetime
  find
  cpdir
  cpfile
  mvfile
  rmdirrec
  rmfile
  chperm
  mkdiras
  getcrown
  readdir
  sort_dir_list
  readfile
  writefile
  parsefile
  pushwp
  popwp
  srcpath
  fixpath
  secpath
  getaddr
  getpath
  getspec
  getname
  getext
  abspath
  realpath
  relpath
  mkabsdir
/;

# Win32 modules are installed
eval("use Win32::FileSecurity");
our $HAS_WIN32 = $@ ? 0 : 1;

# Character to use as the file and directory separator
use constant SEPARATOR => '/';

# Filename for metadata
use constant META_FILENAME => '.metadata';

# ------------------------------------------------------------------------------
# $MODE_TO_MASK - Translations for Win32::FileSecurity::MakeMask
# ------------------------------------------------------------------------------

our $MODE_TO_MASK = {

  '7' => {
    'FILE'  => ["FULL"],
    'DIR'   => ["FULL", "GENERIC_ALL"],
  },

  '6' => {
    'FILE'  => ["CHANGE"],
    'DIR'   => ["ADD", "CHANGE", "GENERIC_WRITE", "GENERIC_READ", "GENERIC_EXECUTE"],
  },

  '5' => {
    'FILE'  => ["READ", "STANDARD_RIGHTS_EXECUTE"],
    'DIR'   => ["GENERIC_READ", "GENERIC_EXECUTE"],
  },

  '4' => {
    'FILE'  => ["READ"],
    'DIR'   => ["GENERIC_READ", "GENERIC_EXECUTE"],
  },

  '3' => {
    'FILE'  => ["STANDARD_RIGHTS_WRITE", "STANDARD_RIGHTS_EXECUTE"],
    'DIR'   => ["GENERIC_READ", "GENERIC_EXECUTE"],
  },

  '2' => {
    'FILE'  => ["STANDARD_RIGHTS_WRITE"],
    'DIR'   => ["GENERIC_READ", "GENERIC_EXECUTE"],
  },

  '1' => {
    'FILE'  => ["STANDARD_RIGHTS_EXECUTE"],
    'DIR'   => ["GENERIC_EXECUTE"],
  },

  '0' => {
    'FILE'  => [""],
    'DIR'   => [""],
  },

};

#-------------------------------------------------------------------------------
# fileopen FILENAME [PARAMS]
#
# For platforms which don't flock, create a lockfile for a specified
# filename.  Waits for #winlock_timeout seconds if a lockfile exists (unless
# READONLY is specified).
#-------------------------------------------------------------------------------

sub fileopen {
  my $filename = shift || return;
  my $readonly = $filename !~ /^>/;
  my $handle = IO::File->new($filename);
  croak "$!: $filename" unless defined $handle;
  my $flockopr = $readonly ? LOCK_SH : LOCK_EX;
  my $flocked = flock($handle,$flockopr);
  if( $@ or not $flocked ) {
    my $path = Hub::getpath( $filename );
    my $name = Hub::getname( $filename );
    my $lock_filename = "$path/.lock-$name";
    my $timeout = $$Hub{'/conf/timeout/lockfile'} || 1;
    $timeout *= 2; # because we only sleep for 1/2 second each loop
    for( 0 .. $timeout ) {
      last unless -e $lock_filename;
      last if $readonly;
      warn( "Waiting for lock on: $filename" );
      sleep .5;
    }#for
    if( open( LOCKFILE, ">$lock_filename" ) ) {
      print LOCKFILE "Lock file";
      close LOCKFILE;
    } else {
      die( "$!: $lock_filename" ) unless $readonly;
    }#if
  }#if
  return $handle;
}#fileopen

#-------------------------------------------------------------------------------
# fileclose HANDLE, [FILENAME]
#
# Unlock and close the file.
# Always remove the lockfile for a specified filename.
#-------------------------------------------------------------------------------

sub fileclose {
    my $handle = shift;
    my $filename = shift;
    if( defined $handle ) {
        flock($handle,LOCK_UN);
        close $handle;
    }#if
    if( $filename ) {
        my $path = Hub::getpath( $filename );
        my $name = Hub::getname( $filename );
        my $lock_filename = "$path/.lock-$name";
        unlink $lock_filename if -e $lock_filename;
    }#if
}#fileclose

# ------------------------------------------------------------------------------
# filetime - Return file's timestamp
#
# filetime LIST, [OPTIONS]
#
# Where:
#
#   LIST                A list of valid path names or file handles
#   OPTIONS -mtime      Return last-modified time (default)
#           -atime       last-accessed time
#           -ctime       creation time
#   OPTIONS -max        Return greatest value (default)
#           -min         least value
# ------------------------------------------------------------------------------

sub filetime {
  my $opts = Hub::opts( \@_, { mtime => 1, max => 1 } );
  my $result = -1;
  foreach my $file ( @_ ) {
    my $time = -1;
    my $fh = new IO::File;
    if($fh->open($file)) {
      my $stats = stat($fh);
      $$opts{'mtime'} and $time = $stats->mtime();
      $$opts{'atime'} and $time = $stats->mtime();
      $$opts{'ctime'} and $time = $stats->mtime();
      $fh->close();
    }#if
    $result = $$opts{'max'} ? Hub::max( $result, $time ) :
      Hub::min( $result, $time );
  }#foreach
  return $result;
}#filetime

# ------------------------------------------------------------------------------
# find - Find files on disk
# find $directory, [options]
#
# The directory entries '.' and '..' are always suppressed.
#
# No sorting is done here, entries appear in directory order with the directory
# listing coming before its sub-directory's listings.
#
# Options:
#
#   -name         => \@list|$list   Filename patterns to include
#   -include      => \@list|$list   Path patterns to include
#   -exclude      => \@list|$list   Path patterns to ignore.
#   -ignore       => \@list|$list   Path patterns to ignore
#   -filesonly    => 0|1            Omit directory entries from the result
#   -dirsonly     => 0|1            Omit file entries from the result
#
# Examples:
#
#   # Return the whole mess
#   find('/var/www/html');
#
#   # Wild-card search
#   my @list = find('/var/www/html/*.css');
#
#   # Find by filename
#   my @list = find('/var/www/html', -name => '\.htaccess;\.htpasswd');
#
#   # Ignore these paths
#   my @list = find('/var/www/html', -ignore => ".bak;.swp");
#
#   # Ignore these paths AND do not recurse into them
#   my @list = find('/var/www/html', -exclude => "CVS;.svn");
#
#   # Just find these paths
#   # This would also match a directories named ".gif"!
#   my @list = find('/var/www/html', -include => ".gif;.jp?g;.png");
#
#   # Omit directory entries from the result
#   my @list = find('/var/www/html', -filesonly => 1);
#
#   # Omit file entries from the result
#   my @list = find('/var/www/html', -dirsonly => 1);
#
# The options:
#
#   -name
#   -include
#   -exclude
#   -ignore
#
# Can be provided as array references, meaning:
#
#   my @patterns = qw(1024x768.gif 800x600.jpe?g)
#   my @list = find('/var/www/html', -include => \@patterns);
#
# is equivelent to:
#
#   my @list = find('/var/www/html', -include => "1024x768.gif;800x600.jpe?g");
# ------------------------------------------------------------------------------

sub find {
  my $opts = Hub::opts(\@_, {
    'include'   => [],
    'ignore'    => [],
    'exclude'   => [],
    'name'      => [],
  });
  my $dir = shift || croak "Provide a directory";
  my $opt_hash = shift;
  for (qw/name exclude ignore include/) {
    defined $$opts{$_} && ref($$opts{$_}) ne 'ARRAY'
      and $$opts{$_} = [split /\s*;\s*/, $$opts{$_}];
  }
  # Options, for backwards compatablity, can also be provided in a single hash
  if( defined $opt_hash ) {
    if( ref($opt_hash) eq 'HASH' ) {
      Hub::merge($opts, $opt_hash);
    } else {
      croak "Unknown option: $opt_hash";
    }#if
  }#if

  # Global exludes
  push @{$$opts{'ignore'}}, split(/\s*;\s*/, $$Hub{'/sys/ENV/GLOBAL_IGNORE'})
    if defined $$Hub{'/sys/ENV/GLOBAL_IGNORE'};
  push @{$$opts{'exclude'}}, split(/\s*;\s*/, $$Hub{'/sys/ENV/GLOBAL_EXCLUDE'})
    if defined $$Hub{'/sys/ENV/GLOBAL_EXCLUDE'};

  # Single argument such as '/var/www/html/*.html'
  unless(-d $dir) {
    my $path = Hub::getpath($dir);
    if(-d $path) {
      my $name = Hub::getname($dir);
      $dir = $path;
      $opts->{'include'} = [ $name ];
      $opts->{'filesonly'} = 1;
    }#if
  }

  # Translate path patterns like (*.txt or *.*) into regex patterns
  foreach my $k (qw/include exclude ignore/) {
    map {
      $_ =~ s/^\*/.*/;
      $_ =~ s/(?
    } @{$opts->{$k}};
  }

  # Implementation
  $dir = Hub::fixpath($dir);
  my $found = _find($dir, $opts);
  return defined $found ? @$found : ();

}

sub _find {
  my ($dir, $opts) = @_;

  # Read directory
  my @all = ();
  my $d = IO::Dir->new($dir);
  die "$!: '$dir' in '" . cwd() . "'" unless defined $d;
  while (defined($_ = $d->read)) {
    push @all, $_ unless /^\.+$/;
  }
  undef $d;

  # Find matches
  my $list = ();
  my @subdirs = ();
  foreach my $name ( @all ) {
    my $i = "$dir/$name";
    my $ok = 1;

    # Entire path rule
    if (@{$opts->{'include'}}) {
      $ok = 0;
      for (@{$opts->{'include'}}) {
        if ($i =~ $_) {
          $ok = 1;
          last;
        }
      }
    }

    # Filename rule
    if (@{$opts->{'name'}}) {
      $ok = 0;
      for (@{$opts->{'name'}}) {
        if ($name =~ $_) {
          $ok = 1;
          last;
        }
      }
    }

    # Exclusion rules
    for (@{$opts->{'ignore'}}, @{$opts->{'exclude'}}) {
      if ($i =~ $_) {
        $ok = 0;
        last;
      }
    }

    # Looking for just files (or directories?)
    if( -d $i ) {
      $ok = 0 if $opts->{'filesonly'};
      # Regardless, shall we recurse?
      my $recurse = 1;
      for (@{$opts->{'exclude'}}) {
        if( $i =~ $_ ) {
          $recurse = 0;
          last;
        }
      }
      if( $recurse ) {
        push @subdirs, $i;
      }
    } else {
      $ok = 0 if $opts->{'dirsonly'};
    }

    # If it passed all the rules
    if( $ok ) {
        push @$list, $i;
    }
  }

  # Recurse into subdirectories
  foreach my $subdir ( @subdirs ) {
      my $found = _find($subdir, $opts);
      ref($found) eq 'ARRAY' and push @$list, @$found;
  }

  return $list;
}#find

# ------------------------------------------------------------------------------
# cpdir - Copy a directory
# cpdir $source_dir, $target_dir, [filters], [permissions], [options]
#
# B this function does *not* behave like your shell's C command!
# It differs in that when the target directory exists, the *contents* of the
# source directory are copied.  This is done so that the default operation is:
#
#   # don't create /home/$username/newuser!
#   cpdir('templates/newuser', "/home/$username");
#
# To get the same behavior as C, use the '-as_subdir' flag.
#
# Files are only copied when the source file's modified time is newer
# (unless the 'force' option is set).
#
# C: See L
#
# C: See L
#
# C:
#
#   -force => 1               # Always perform the copy
#   -as_subdir => 1           # Copy as a sub-directory of $target
#   -peers => 1               # The $source and $target are peers (may be
#                               different names)
#
#   -peers and -as_subdir are mutually exclusive
#
# ------------------------------------------------------------------------------

sub cpdir {
  my ($opts, $source_dir, $target_dir, $perms) = Hub::opts(\@_);
  Hub::merge($opts, $perms) if isa($perms, 'HASH'); # backward compatibility
  my $target_parent = Hub::getpath($target_dir) || '.';
  croak "Provide an existing source: $source_dir" unless -d $source_dir;
  croak "Provide an existing target: $target_parent" unless -d $target_parent;
  my $item_count = 0;
  if ($$opts{'as_subdir'}) {
    $target_dir .= SEPARATOR if $target_dir;
    $target_dir .= Hub::getname($source_dir);
    mkabsdir($target_dir, -opts => $opts);
  } elsif ($$opts{'peers'}) {
    mkabsdir($target_dir, -opts => $opts);
    $item_count++;
  }
  my @items = Hub::find($source_dir, -opts => $opts);
  foreach my $item (@items) {
    my $target = $item;
    $target =~ s/^$source_dir/$target_dir/;
    if( -d $item ) {
      if ((! -d $target) || $opts->{'force'}) {
        Hub::mkdiras($target, -opts => $opts);
      }
    } else {
      Hub::cpfile($item, $target, -opts => $opts);
    }
  }
  $item_count += @items;
  return $item_count;
}#cpdir

# ------------------------------------------------------------------------------
# cpfile - Copy a file and apply permissions and mode
#
# cpfile $SOURCE, $TARGET, [\%PERMISSIONS], [OPTIONS]
#
# Where:
#
#   $SOURCE         File to be copied
#   $TARGET         Target path (file or directory)
#   \%PERMISSIONS   Permission hash (see Hub::chperm)
#   OPTIONS         -newer      Only copy when the source is newer (mtime) than
#                               the target
#
# See also: L
# ------------------------------------------------------------------------------

sub cpfile {
  my ($opts, $source, $dest, $perms) = Hub::opts(\@_);
  Hub::merge($opts, $perms) if isa($perms, 'HASH'); # backward compatibility
  my @result  = ();
  foreach my $file (-f $source
      ? $source
      : ref($source) eq 'HASH'
        ? Hub::find('.', $source)
        : Hub::find($source)) {
    return unless -f $file;
    my $target = $dest;
    if(-d $target) {
      my $fn = Hub::getname( $file );
      $target .= "/$fn";
    }
    my $copy = $$opts{'force'};
    if( !$copy ) {
      my $source_stats = stat( $file );
      my $target_stats = stat( $target );
      if( !$target_stats || $source_stats->mtime() > $target_stats->mtime() ) {
        $copy = 1;
      }
    }
    if( $copy ) {
      my $fpath = Hub::getpath( $target );
      Hub::mkabsdir($fpath, -opts => $opts);
      if( copy( $file, $target ) ) {
        Hub::chperm($target, -opts => $opts);
      } else {
        die( "$!: $target" );
      }
    }
    push @result, $target;
  }
  return Hub::sizeof(\@result) == 1
    ? shift @result
    : wantarray
      ? @result
      : \@result;
}#cpfile

# ------------------------------------------------------------------------------
# rmfile - Remove file
# ------------------------------------------------------------------------------

sub rmfile {
  unlink @_;
}#rmfile

# ------------------------------------------------------------------------------
# mvfile - Move (rename) a file
# ------------------------------------------------------------------------------

sub mvfile {
  my ($f1,$f2) = @_;
  rename $f1, $f2;
  Hub::touch($f2);
}#mvfile

# ------------------------------------------------------------------------------
# rmdirrec TARGET_DIR
#
# Recursively remove a directory.
# ------------------------------------------------------------------------------

sub rmdirrec {
  my $dir = shift || die "Provide a directory";
  my $fh  = IO::Handle->new();
  $dir = Hub::abspath( $dir );
  return unless defined $dir && -d $dir;
  my @list = ();
  if( opendir $fh, $dir ) {
    my @subdirs = ();
    my @all = grep ! /^\.+$/, readdir $fh;
    closedir $fh;
    foreach my $name ( @all ) {
      my $i = "$dir/$name";
      if( -f $i ) {
        Hub::rmfile( $i );
      } elsif( -d $i ) {
        Hub::rmdirrec( $i );
      }#if
    }#foreach
    rmdir $dir;
  }#if
}#rmdirrec

# ------------------------------------------------------------------------------
# chperm - Change permissions of a file or directory
# chperm $path, [filters], [permissions], [options]
#
# options:
#
#   recperms=1        # will recurse if  is a directory
#
# filters: Used when recperms is set.  See L.
#
# permissions:
#
#   uid     => Hub::getuid( "username" ),    # user id
#   gid     => Hub::getgid( "username" ),    # group id
#   dmode   => 0775,
#   fmode   => {            # fmode can ref a hash of extensions
#       '*'     => 0644,    # '*' is used for unmatched
#       'cgi'   => 0755,    # specific cgi file extension
#       'dll'   => 'SKIP',  # do not update dll files
#   }
#   fmode   => 0655,        # or, fmode can be used for all files
#
# ------------------------------------------------------------------------------

sub chperm {
  my ($opts,$path,$perms) = Hub::opts(\@_, {
    'recperms'  => 0,
    'fmode'     => 0644,
  });
  Hub::merge($opts, $perms) if isa($perms, 'HASH'); # backward compatibility
  my @items = $$opts{'recperms'} ? Hub::find($path, $opts) : $path;
  foreach my $target ( @items ) {
    if (-d $target) {
      my $mode = $$opts{'dmode'} || 0755;
       _chperm($$opts{'uid'}, $$opts{'gid'}, $mode, $target);
    } else {
      my $mode = undef;
      if (isa($$opts{'fmode'}, 'HASH')) {
        my $ext = Hub::getext($target);
        if( $$opts{'fmode'}->{$ext} ) {
          $mode = $$opts{'fmode'}->{$ext};
        } else {
          $mode = $$opts{'fmode'}->{'*'} if $$opts{'fmode'}->{'*'};
        }
      } else {
        $mode = $$opts{'fmode'};
      }
      $mode and
        _chperm($$opts{'uid'}, $$opts{'gid'}, $mode, $target);
    }
  }
}#chperm

# ------------------------------------------------------------------------------
# _chperm - Change permission proxy (splits between Win32 and normal routines)
# _chperm $user, $group, $mode, @targets
#
# C<$user> may be either the numeric uid, or the user name
#
# C<$group> may be either the numeric gid, or the group name
#
# C<$mode> may be either the octal value (such as 0755) or the string value
# (such as '755')
#
# On win32, default permissions are taken from the configuration file (by
# default, '.conf' in the current directory):
#
#   group = /conf/win32/group_name
#   owner = /conf/win32/owner_name
#   other = /conf/win32/other_name
#
# When not specified in the configuration, these values will be
#
#   group = Win32::LoginName
#   owner = the same as 'other'
#   other = Everyone
# ------------------------------------------------------------------------------

sub _chperm {
  my $owner   = shift;
  my $group   = shift;
  my $mode    = shift;
  foreach my $target ( @_ ) {
    if( $HAS_WIN32 && ($mode ne 'SKIP') ) {
      $target = Hub::abspath( $target );
      my $mode_str = sprintf( "%o", $mode );
      my $other = $$Hub{'/conf/win32/other_name'} || 'Everyone';
      $group ||= $$Hub{'/conf/win32/group_name'} || 'Win32::LoginName';
      $owner ||= $$Hub{'/conf/win32/owner_name'};
      unless($owner) { $owner = $other; $other = ""; }
      my $owner_flag = substr( $mode_str, 0, 1 );
      my $group_flag = substr( $mode_str, 1, 1 );
      my $other_flag = substr( $mode_str, 2, 1 );
      my $passed = 1;
      $owner and $passed &= _chperm_win32( $owner, $owner_flag, $target,
        "WRITE_OWNER", "WRITE_DAC" );
      $group and $passed &= _chperm_win32( $group, $group_flag, $target );
      $other and $passed &= _chperm_win32( $other, $other_flag, $target );
      _chperm_normal($owner, $group, $mode, $target) unless $passed;
    } else {
      _chperm_normal($owner, $group, $mode, $target);
    }
  }
}

# ------------------------------------------------------------------------------
# _chperm_normal - Use chmod and chown to change permissions
# _chperm_normal $user, $group, $mode, $target
#
# See L<_chperm> for $user, $group, and $mode settings
# ------------------------------------------------------------------------------

sub _chperm_normal {
  my $owner   = shift;
  my $group   = shift;
  my $mode    = shift;
  my $target  = shift;
  # Change owner first
  if (defined $owner) {
    unless (chown Hub::getuid($owner), Hub::getgid($group), $target) {
      warn "$!: chown $owner:$group $target";
    }
  }
  # Convert string of octal digits
  $mode = length(sprintf('%o',$mode)) > 3 ? oct($mode) : $mode;
  if ($mode ne 'SKIP') {
    unless (chmod $mode, $target) {
      warn "$!: chmod $mode $target";
    }
  }
}#_chperm_normal

# ------------------------------------------------------------------------------
# _chperm_win32 - Change permissions on Win32
#
# On Win32, we still don't "really" change the owner (Anybody know how?)
# ------------------------------------------------------------------------------

sub _chperm_win32 {
  my $user    = shift;
  my $flag    = shift;
  my $target  = shift;
  my $index   = -d $target ? "DIR" : "FILE";
  my $mmargs  = $MODE_TO_MASK->{$flag}->{$index};
  my $retval  = 0;
  my @mmargs  = @_;
  push @mmargs, @$mmargs if ref($mmargs) eq 'ARRAY';
  if( @mmargs ) {
    $retval = 1;
    my $mask = Win32::FileSecurity::MakeMask( @mmargs );
    my $privHash = {};
    # If there isn't an ACL, we receive: Error handling error: 3,
    # GetFileSecurity
    eval( "Win32::FileSecurity::Get( \$target, \$privHash )" );
    $@ and do { chomp $@; warn( "$target: $@" ); $retval = 0; };
    return $retval unless $retval;
    if( $flag ) {
      $privHash->{$user} = $mask;
    } else {
      delete $privHash->{$user};
    }#if
    eval( "Win32::FileSecurity::Set( \$target, \$privHash )" );
    $@ and do { chomp $@; warn( "$target: $@" ); $retval = 0; };
  }#if
  return $retval;
}#_chperm_win32

# ------------------------------------------------------------------------------
# mkdiras - Make a directy with specified permissions
# mkdiras $path, [permissions]
#
# permissions: See L
# ------------------------------------------------------------------------------

sub mkdiras {
  my ($opts, $path, $perms) = Hub::opts(\@_);
  croak "Provide a path" unless defined $path;
  return if -d $path;
  if (mkdir $path) {
    Hub::chperm($path, $opts) if %$opts;
  } else {
    croak("$!: $path");
  }
}#mkdiras

# ------------------------------------------------------------------------------
# getcrown - Return the first line of a file
# getcrown $file_path
#
# Returns empty-string when $file_path does not exist
# ------------------------------------------------------------------------------

sub getcrown {
  my $filepath = shift or croak "Provide a file path";
  my $crown = '';
  if (open FILE, $filepath) {
    $crown = ;
    close FILE;
  }
  return $crown;
}#getcrown

# ------------------------------------------------------------------------------
# readdir - Read a directory in proper order
# readdir $dir
# ------------------------------------------------------------------------------

sub readdir {
  my $dir = shift;
  return () unless -d $dir;
  opendir (DIR, $dir) or die "$!: $dir";
  my @list = sort grep {!/^\.+/} readdir DIR;
  closedir DIR;
  # Sort entries
  Hub::sort_dir_list($dir, \@list);
# my $md_filename = $dir.SEPARATOR.META_FILENAME;
# if (-f $md_filename) {
#   my $md = Hub::mkinst('HashFile', $md_filename);
#   my $order = $$md{'sort_order'};
#   if (isa($order, 'ARRAY')) {
#     my $idx = 0;
#     my %sort_values = map {$_, $idx++} @$order;
#     @list = sort {
#       Hub::compare('<=>', $sort_values{$a}, $sort_values{$b})
#     } @list;
#   }
# }
  return @list;
}#readdir

# ------------------------------------------------------------------------------
# sort_dir_list - Sort the provided directory listing
# sort_dir_list $dir, \@listing
# ------------------------------------------------------------------------------

sub sort_dir_list {
  my ($opts, $dir, $list) = Hub::opts(\@_);
  my $md_filename = $dir.SEPARATOR.META_FILENAME;
  if (-f $md_filename) {
    Hub::frefresh($md_filename);
    my $md = Hub::mkinst('HashFile', $md_filename);
    # Sort entries
    my $order = $$md{'sort_order'};
    if (isa($order, 'ARRAY')) {
      my $idx = 0;
      my %sort_values = map {$_, $idx++} @$order;
      @$list = sort {
        Hub::sort_compare('<=>', $sort_values{$a}, $sort_values{$b})
      } @$list;
    }
  }
}#sort_dir_list

# ------------------------------------------------------------------------------
# readfile PATH
#
# Read and return the contents of a file.
# ------------------------------------------------------------------------------

sub readfile {
  my $path = shift || return;
  my $opts = Hub::opts(\@_) if @_;
  local $_;
  my @contents = ();
  my $fh = Hub::fileopen($path);
  if( $fh ) {
    @contents = <$fh>;
    Hub::fileclose($fh, $path);
  }#if
  defined $$opts{'asa'} and return @contents;
  my $contents = '';
  map { $contents .= $_ } @contents;
  return $contents;
}#readfile

# ------------------------------------------------------------------------------
# writefile - Write $contents to $path
# writefile $path, \$contents, [options]
# writefile $path, $contents, [options]
#
# options:
#
#   -mode   => 0644     Set/update file's mode
#   -flags  => >|>>     Flags used to open the file
#
# Returns 1 if the file could be openned and written to, otherwise 0.
# ------------------------------------------------------------------------------

sub writefile {
  my ($opts,$filepath,$contents) = Hub::opts(\@_, {'flags' => '>'});
  croak "Provide a file" unless $filepath;
  croak "Provide file contents" unless defined $contents;
  my $perms = ();
  my $ret = 0;
  my $fh = Hub::fileopen("$$opts{'flags'}$filepath");
  if( $fh ) {
    print $fh ref($contents) eq 'SCALAR' ? $$contents : $contents;
    Hub::fileclose($fh, $filepath);
    if( defined($$opts{'perms'}) ) {
      Hub::chperm($filepath, $$opts{'perms'});
    }
    $ret = 1;
  }
  return $ret;
}

# ------------------------------------------------------------------------------
# parsefile - Populate a file with runtime data.
# parsefile $filename, [options]
# parsefile $filename, \%data, [\%more_data..], [options]
#
# parameters:
#
#   $filename   File to parse as a template.
#   \%data      Hashref of name/value pairs.
#
# options:
#
#   -as_ref=1   Return a scalar reference
#   -alone      Do not include configuration and instance values
#   -inline     Update the file on disk!
# ------------------------------------------------------------------------------

sub parsefile {
  my ($opts) = Hub::opts(\@_, {'as_ref' => 0});
  my $file = shift;
  my @values = @_ ? ( @_ ) : ();
  push @values, $$Hub{+SEPARATOR} unless $$opts{'alone'};
  my $contents = Hub::readfile( $file );
  my $parser = Hub::mkinst( 'StandardParser', -template => \$contents,
    -opts => $opts );
  my $results = $parser->populate( @values );
  Hub::expect( SCALAR => $results );
  $$opts{'inline'} and Hub::writefile( $file, $results );
  return $$opts{'as_ref'} ? $results : $$results;
}#parsefile

# ------------------------------------------------------------------------------
# pushwp - Push path onto working directory stack
# ------------------------------------------------------------------------------

sub pushwp {
  $$Hub{'/sys/PATH'} ||= [];
  push @{$$Hub{'/sys/PATH'}}, @_;
}#pushwp

# ------------------------------------------------------------------------------
# popwp - Pop path from working directory stack
# ------------------------------------------------------------------------------

sub popwp {
  return pop @{$$Hub{'/sys/PATH'}};
}#popwp

# ------------------------------------------------------------------------------
# srcpath - Search the working path for $file
# srcpath $file
# ------------------------------------------------------------------------------

sub srcpath {
  my $unknown = shift || return;
  -e $unknown and return $unknown;
  for (
    @{$$Hub{'/sys/PATH'}},
    $$Hub{'/sys/ENV/WORKING_DIR'},
    $$Hub{'/sys/ENV/BASE_DIR'}
  ) {
    next unless defined && $_;
    my $spec = Hub::fixpath( "$_/$unknown" );
    if(-e $spec) {
      return $spec;
    }
  }
}#srcpath

# ------------------------------------------------------------------------------
# secpath - Authorize a path for the runtime access
# secpath $path
#
# Intention is to be able to pass anything to this method and it will only
# return a path when it is valid.  Being valid means that it resolves to a file
# or directory which is at or below the WORKING_DIR.
# ------------------------------------------------------------------------------

sub secpath {
  my $abspath = Hub::abspath(@_, -must_exit => 0);
  return defined Hub::getaddr($abspath) ? $abspath : undef;
}#secpath

#-------------------------------------------------------------------------------
# fixpath - Clean up malformed paths (usually due to concatenation logic).
# fixpath $path
#-------------------------------------------------------------------------------
#|test(match)   fixpath( "../../../users/newuser/web/bin/../src/screens" );
#~              ../../../users/newuser/web/src/screens
#~
#|test(match)   fixpath( "users/newuser/web/" );
#~              users/newuser/web
#~
#|test(match)   fixpath( "users/../web/bin/../src" );
#~              web/src
#~
#|test(match)   fixpath( "users//newuser" );
#~              users/newuser
#~
#|test(match)   fixpath( "users//newuser/./files" );
#~              users/newuser/files
#~
#|test(match)   fixpath( "http://site/users//newuser" );
#~              http://site/users/newuser
#|test(match)   fixpath( '/home/hub/build/../../../out/doc/pod' );
#~              /out/doc/pod
#-------------------------------------------------------------------------------

sub fixpath {
  my $path = shift || return;
  # correct solidus
  $path =~ s/\\/\//g;
  # remove empty dirs, ie: // (unless it looks like protocol '://')
  $path =~ s/(?
  # remove pointless dirs, ie: /./
  $path =~ s/\/\.\//\//g;
  # condense relative subdirs
  while( $path =~ s/[^\/\.]+\/\.\.\/?//g ) {
    # remove empty dirs (again)
    $path =~ s/(?
  }#while
  # remove trailing /
  $path =~ s/\/\z//;
  return $path;
}#fixpath

# ------------------------------------------------------------------------------
# getaddr - Get the Hub address for a file
# getaddr $filename
#
# C<$filename> may be relative to the running module (see L)
#
# For the inverse, see L
# ------------------------------------------------------------------------------

sub getaddr {
  my $path = Hub::srcpath(@_) || $_[0];
  my $result = ();
  return unless defined $path;
  foreach my $dir ($$Hub{'/sys/ENV/WORKING_DIR'}, $$Hub{'/sys/ENV/BASE_DIR'}) {
    next unless defined $dir;
    $path =~ s#^$dir## and return $path;
  }
  return undef;
}#getaddr

# ------------------------------------------------------------------------------
# getpath - Exract the parent from the given filepath
# ------------------------------------------------------------------------------
#|test(match,/etc)        getpath( "/etc/passwd" )
#|test(match,/usr/local)  getpath( "/usr/local/bin" )
# ------------------------------------------------------------------------------

sub getpath {
  my $orig = Hub::fixpath( shift ) || '';
  my ($path) = $orig =~ /(.*)\//;
  return $path || '';
}#sub

# ------------------------------------------------------------------------------
# getspec - Given a path to a file, return (directory, filename, extension)
# getspec $path
# ------------------------------------------------------------------------------

sub getspec {
  my $path = shift;
  my $name  = Hub::getname( $path )  || "";
  my $ext   = Hub::getext( $path )   || "";
  my $dir   = Hub::getpath( $path )  || "";
  $name =~ s/\.$ext$//; # return the name w/o extension
  return ($dir,$name,$ext);
}#getspec

#-------------------------------------------------------------------------------
# getname Return the file name (last element) of given path
# getname $path
# Note, if the given path is a full directory path, the last directory is
# still considerred a filename.
#-------------------------------------------------------------------------------
#|test(match) getname("../../../users/newuser/web/data/p001/batman-small.jpg");
#=batman-small.jpg
#|test(match) getname("../../../users/newuser/web/data/p001");
#=p001
#|test(match) getname("/var/log/*.log");
#=*.log
#-------------------------------------------------------------------------------

sub getname {
  return unless defined $_[0];
  return pop @{[split(SEPARATOR, $_[0])]};
}

# ------------------------------------------------------------------------------
# getext - Return the file extension at the given path
# getext $path
# ------------------------------------------------------------------------------
#|test(match) getext( "/foo/bar/filename.ext" )
#=ext
#|test(match) getext( "filename.cgi" )
#=cgi
# ------------------------------------------------------------------------------

sub getext {
  my $orig = shift;
  my $fn = getname($orig) || '';
  my $tmp = reverse($fn);
  $tmp =~ s/\..*//;
  my $ret = reverse $tmp;
  return $ret eq $fn ? '' : $ret;
}#getext

# ------------------------------------------------------------------------------
# realpath - Resolve the address to it's real file on disk.
# realpath $address
#
# Used to translate our Hub system addresses into real filesystem paths.
# When /foo/bar.txt is really cwd().'/foo/bar.txt', we strip the beginning /.
# When using mounts, return the file's real path.
#
# For the inverse, see L
# ------------------------------------------------------------------------------

sub realpath {
  my $real_path = shift;
  croak "Provide an address" unless defined $real_path;
  $real_path =~ s/^\///;
  # TODO implement mounts
  return $real_path ? $real_path : '.';
}#realpath

#-------------------------------------------------------------------------------
# abspath - Return the absolute path
# abspath $node, [options]
# options:
#   -must_exist=0   Allow paths which don't exist
#-------------------------------------------------------------------------------

sub abspath {
  my $path = shift; # important to shift (filenames can start with a dash)
  my ($opts) = Hub::opts(\@_, {must_exist => 0,});
  my $result = ();
  if ($$opts{'must_exist'}) {
    $result = _find_abspath($path, $$Hub{'/sys/ENV/WORKING_DIR'});
    if (! -e $result) {
      $result = _find_abspath($path, $$Hub{'/sys/ENV/BASE_DIR'});
    }
#   die "$!: $result" unless -e $result;
    return undef unless -e $result;
  } else {
    $result = _find_abspath($path);
  }
  return $result;
}#abspath

# ------------------------------------------------------------------------------
# _find_abspath - Get the absolute path (may or may not exist)
# _find_abspath $node
# _find_abspath $node $working_dir
# ------------------------------------------------------------------------------

sub _find_abspath {
  my $relative_path = shift || return;
  my $base_dir = shift;
# $relative_path =~ s/\\/\//g;
  return $relative_path if $relative_path =~ /^\/|^[A-Za-z]:\//;
  $base_dir ||= Hub::bestof($$Hub{'/sys/ENV/WORKING_DIR'},Hub::getpath($0));
  $base_dir = cwd() unless $base_dir =~ /^\/|^[A-Za-z]:\//;
# $base_dir =~ s/\\/\//g;
  return fixpath("$base_dir/$relative_path");
}#_find_abspath

# ------------------------------------------------------------------------------
# relpath - Relative path
# relpath $path, $from_dir
# ------------------------------------------------------------------------------
#|test(match,..)    relpath("/home/docs", "/home/docs/install");
#|test(match)       relpath("/home/src", "/home/docs/install");
#~                  ../../src
#|test(match)       relpath("/home/docs/README.txt", "/home/docs");
#~                  README.txt
#|test(match)       relpath("README.txt", "/DEBUG");
#~                  README.txt
# ------------------------------------------------------------------------------

sub relpath {
  my $path = Hub::fixpath(shift) || '';
  my $from = Hub::fixpath(shift) || '';
  return $path unless $path =~ SEPARATOR;
  my @from_parts = split SEPARATOR, $from;
  my @path_parts = split SEPARATOR, $path;
  my @relpath = ();
  my $begin_idx = 0;
  for (my $idx = 0; $idx < @from_parts; $idx++) {
    last unless defined $path_parts[$idx];
    last if $from_parts[$idx] ne $path_parts[$idx];
    $begin_idx++;
  }
  for (my $idx = $begin_idx; $idx < @from_parts; $idx++) {
    push @relpath, '..';
  }
  for (my $idx = $begin_idx; $idx < @path_parts; $idx++) {
    push @relpath, $path_parts[$idx];
  }
  return join SEPARATOR, grep {$_} @relpath;
}#relpath

# ------------------------------------------------------------------------------
# mkabsdir - Create the directory specified, including parent directories.
# mkabsdir $dir, [permissions]
# See L
# ------------------------------------------------------------------------------

sub mkabsdir {
  my ($opts, $dir) = Hub::opts(\@_);
  my $abs_path = _find_abspath($dir);
  return unless $abs_path;
  return $abs_path if -e $abs_path;
  my $build_path = '';
  foreach my $part ( split SEPARATOR, $abs_path ) {
    $build_path .= "$part/";
    -d $build_path and next;
    Hub::mkdiras($build_path, -opts => $opts);
  }
  return $abs_path;
}#makeAbsoluteDir

# ------------------------------------------------------------------------------
1;

__END__