NetNews Usenet Archive 1992 #18/NN_1992_18.iso/spool/comp/lang/perl/5435

Text File | 1992-08-22 | 5.9 KB | 272 lines

Newsgroups: comp.lang.perl
Path: sparky!uunet!fmrco!fmrco!asherman
From: [e-mail] (Aaron Sherman)
Subject: Re: Filename expansion ("~user")
In-Reply-To: [e-mail]'s message of 21 Aug 92 16:23:01 GMT
Message-ID: <[e-mail]>
Sender: [e-mail]
Reply-To: [e-mail]
Organization: I-Kinetics, 19 Bishop-Allen Dr., Cambridge, MA
References: <[e-mail]>
    <[e-mail]>
Distribution: usa
Date: Sun, 23 Aug 1992 00:30:46 GMT
Lines: 256


This is a library based on my "apath" program, which allows you to
resolve path names in various ways. To see what it is capable of, look
at the get_options subroutine, or try the following calls:

    require 'apathlib.pl';
    print &apath('t','~root'),"\n";
    print &apath('ve','/usr/bin/${PAGER}'),"\n";
    print join("\n",&apath('sl','/bin','/etc/route')),"\n";
    print &apath('tsa','~bin/bin'),"\n";

To sum up:

    &apath(OPTIONS,LIST)

    where OPTIONS is one of: a, n, l, u, t, v or s.
    and LIST is a list of paths to resolve.

TODO:

    o Allow setting of options ONCE to increase speed for later
      calls.

    o Add support for Domain/OS style paths (i.e. //foo, where foo
      is a machine name).

    o Always have to make it just a LITTLE faster...

-------------CUT HERE-----------------
# Apathlib: a library for Analyzing and simplifying path-names.
# Copyright (C) 1992  Aaron Sherman
#
#    This program is free software; you can redistribute it to your
#    heart's content, just don't claim that you wrote it, and leave
#    this copyright section alone.
#
#    If you make changes, note this in the code.

#    This program 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.

# You can contact the author via electronic-mail as:
#
#    [e-mail]
#

package apath;

$version = '$Id: apathlib.pl,v 1.3 1992/08/22 23:14:17 asherman Exp $';

package main;

sub apath
{
    package apath;

    local($options,@list) = @_;
    local(*_,%done,$file,$line,@return);

    &get_options($options);

    foreach(@list)
    {
    # I don't increment $done{$_} here, since it is done below.

    &expand_name($_) if ($tilde || $variable);

    next if ($unique && $done{$_});

    if ($validate && ! -e $_)
    {
        push(@return,undef);
        next;
    }
    ($file,$line) = &follow($_);

    unless(($unique && $done{$file}++) || ($delete && $_ eq $file))
    {
        push(@return,$line);
    }
    }

    @return;
}


package apath;

sub get_options
{
    local($opt) = @_;

    $long        = 0;
    $abbrv        = 0;
    $delete        = 0;
    $unique        = 0;
    $validate        = 0;
    $links        = 0;
    $variable        = 0;
    $tilde        = 0;

    foreach(split(//,$opt))
    {
    if ($_ eq 'a')        # Abbreviated long-output
    {
        $long = 1;
        $abbrv = 1;
    }
    elsif ($_ eq 'n')        # Delete paths that are not simplified.
    {
        $delete = 1;
    }
    elsif ($_ eq 'e')        # Validate that files exist
    {
        $validate = 1;
    }
    elsif ($_ eq 'l')        # Long output
    {
        $long = 1;
        $abbrv = 0;
    }
    elsif ($_ eq 'u')        # Uniquify output
    {
        $unique = 1;
    }
    elsif ($_ eq 't')        # Tilde (~) expansion
    {
        $tilde = 1;
    }
    elsif ($_ eq 'v')        # Variable (/foo/${BAR}) expansion
    {
        $variable = 1;
    }
    elsif ($_ eq 's')        # Resolve symlinks
    {
        $links = 1;
    }
    }
}

# This subroutine resolves ~ and variable abbreviations

sub expand_name
{
    local($file) = @_;

    if ($tilde && $file =~ /^\~/)
    {
    $file =~ s%^\~([^/]*)%%;
    $tname = $1;
    if ($tname eq '')
    {
        $tname = getlogin;
    }
    @pwd = getpwnam($tname);
    if (@pwd)
    {
        $file = $pwd[7] . $file;
    }
    }

    while ($variable && $file =~ /\$\{(\w+)\}/)
    {
    local($var) = $ENV{$1};
    $file =~ s/\$\{\w+\}/$var/;
    }
    $_[0] = $file;
}

# This subroutine follows a file-path, element by element, and determines what
# it's hard path is (i.e. the path without any symbolic links, and no .'s or
# ..'s, except at the beginnings of relative-paths).
#
# It's return is a two-element list of the hard path, and the line to print.
# The format of the line to print is dependant on the values of $long and
# $abbrv.
#
# No globals are modified.
sub follow
{
    local($exist,$_) = ((-e $_[0]), @_);
    local($line,$abs,$tmp,$link,@path_stack);

    if ($long)
    {
    $line = "$_:";
    $line .= "\n" unless ($abbrv);
    }

    # Split up the path, and initialize the stack.
    if (/^\/+$/)
    {
    push(@path_stack,'');
    }
    else
    {
    @path_stack = split(m./+.,$_);
    }

    # Pop each element off of the stack, pushing elements on, when a
    # symbolic-link is encountered. As elements are poped off, they
    # are added to the end of $abs, which is the file's "hard path-name"
    while(defined($elem = shift(@path_stack)))
    {
    # $elem eq '' means a null path-element. Could be ''/'foo'
    if ($elem eq '' || $elem eq '.')
    {
        $abs = '/' if ($elem eq '' && $abs eq '');
        next;
    }

    # Resolve .. in path-names.
    if ($abs && $elem eq '..')
    {
        if ($abs =~ m%^\.\.(/\.\.)*$%)
        {
        $abs .= '/..';
        }
        elsif ($abs ne '/')
        {
            $abs =~ s%[^/]+$%%;
            $abs = '.' if $abs eq '';
            $abs =~ s%/+$%% unless $abs eq '/';
        }
        next;
    }

    # Don't add a / if nothing there yet.
    $tmp = $abs . (($abs eq '' || $abs =~ m%/$%)?'':'/') . $elem;

    # Check for symbolic-links.
    if ($exist && $links && defined($link = readlink($tmp)))
    {
        $line .= "\t\t$tmp -> $link\n" if ($long && !$abbrv);
        $abs = '' if substr($link,0,1) eq '/';
        unshift(@path_stack,split(m./+.,$link));
    }
    else
    {
        $abs = $tmp;
    }
    }
    $abs = '.' if $abs eq '';
    $line .= "\t" if ($long && !$abbrv);
    $line .= $abs;
    ($abs,$line);
}

1;
-----------------CUT HERE-----------
--
--------
Disclaimer: I am solely responsible for the content of this message.
The views expressed here may not be the views of I-Kinetics, Fidelity,
any of the Fidelity-owned corporations or my mother.