File Coverage

blib/lib/VMS/FileUtils/SafeName.pm

Criterion	Covered	Total	%
statement	79	90	87.7
branch	69	76	90.7
condition	3	3	100.0
subroutine	6	7	85.7
pod	5	5	100.0
total	162	181	89.5

#
#   UNIX/VMS Filename "special character" and upper/lower case mapping
#   as used by Multinet and UCX NFS
#
#   Version:    0.021
#   Author:     C. Lane     [e-mail]
#   Revised:    4 Jan 2001
#

=head1 NAME

VMS::FileUtils::SafeName -- convert special chars and case of filenames

=head1 Synopsis

use VMS::FileUtils::SafeName qw(:all) ;

$vmsusablename = safename('unix:..name &tc',$do_all_dots);
$unixname      = unsafename($vmsusablename);
$path          = safepath('x.y/version:1.2.3',$do_all_dots_filename);
$unixpath      = unsafepath($safepathoutput);
$archivename   = safe_archive('HTML-Parser-1.07.tar.gz');

=head1 DESCRIPTION

This package provides conversion between Unix filenames and VMS filenames
where the Unix filenames may have characters that are illegal under VMS.

Spaces, punctuation, control characters, etc. get mapped to a sequence of
the form '$6C'.  Also the case of the original unix filename is preserved
using '$' to shift from lower to uppercase:

    Unix filename       safename output
    -------------       ---------------
    abc.DEF.ghi     ->  $ABC.$DEF$5NGHI
                        ^    ^   ^^^ extra periods get converted
                        +----+-------change case

The conversion may be reversed with unsafename

The conversion provided here is the same as is contained in the
Multinet and UCX NFS software.

Routines:

=head2  safename

Converts upper/lower case, punctuation etc. to chars valid for VMS filename.
The first '.' in the filename is left intact (unless the second parameter
to vmsify_name is true, in which case all .s are converted).

Lowercase is taken as the default for input filenames.

=head2 unsafename

Converts filenames produced by safename back to their original form.

=head2 safepath

Converts path elements into VMS-safe form.  The trailing element
(if the path doesn't end in a '/') can optionally have all periods
converted, or (default) all but the first period converted. Path
elements that correspond to directory names have all periods converted

=head2 unsafepath

Reverses the conversion done by safepath

=head2 safe_archive

Converts filename of the type typically used for CPAN archives into
a VMS-compatible format:

    HTML-Parser-1.07.tar.gz  ->   HTML-Parser-1_07.tar-gz


=head1 REVISION

This document was last revised on 10 Mar 1998, for Perl 5.004.59

=cut

package VMS::FileUtils::SafeName;
require 5.002;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
use Exporter();


$VERSION = '0.02';
@ISA = qw( Exporter );
@EXPORT_OK = qw(safename unsafename safepath unsafepath safe_archive);
%EXPORT_TAGS =  (
    all  => [qw(safename unsafename safepath unsafepath safe_archive)]
);


sub safename ($;$) {
    my (@fn) = split(//,$_[0]);
    my ($doalldots) = $_[1];
    my ($out) = '';
    my ($shift) = 0;
    my ($dots) = defined($doalldots) && $doalldots;

    foreach (@fn) {
        if (/[a-z]/) {
            $out .= ($shift==0 ? uc($_) : '$'.uc($_)) ;
            $shift = 0;
        } elsif (/[A-Z]/) {
            $out .= ($shift==1 ? uc($_) : '$'.uc($_)) ;
            $shift = 1;
        } elsif (/[0-9\-_]/) {
            $out .= $_;
        } elsif ($_ eq '$') {
            $out .= '$$';
        } elsif ($_ eq '.') {
            $out .= $dots ? '$5N': '.';
            $dots++;
        } elsif (ord($_) == 0) {
            $out .= '$6A';
        } elsif ($_ eq ' ') {
            $out .= '$7A';
        } elsif (ord($_) == 0x40) {
            $out .= '$8A';
        } elsif (ord($_) == 0x60) {
            $out .= '$9A';
        } elsif (ord($_) <= 0x1A) {
            $out .= '$4'.chr(ord($_)-0x01+ord('A'));
        } elsif (ord($_) <= 0x1F) {
            $out .= '$6'.chr(ord($_)-0x1B+ord('B'));
        } elsif (ord($_) <= 0x3A) {
            $out .= '$5'.chr(ord($_)-0x21+ord('A'));
        } elsif (ord($_) <= 0x3F) {
            $out .= '$7'.chr(ord($_)-0x3B+ord('B'));
        } elsif (ord($_) <= 0x5E) {
            $out .= '$8'.chr(ord($_)-0x5B+ord('B'));
        } elsif (ord($_) <= 0x7F) {
            $out .= '$9'.chr(ord($_)-0x7B+ord('B'));
        } else {
            $out .= sprintf('$%03.3o',ord($_));
        }
    }
    return($out);
}


sub unsafename ($) {
    my ($in) = uc($_[0]);
    my ($shift, $i, $mod, $out);

    $mod =1 ;
    while ($mod) {
        $mod = 0;
        if ($in =~ /\$([0-7]{3,3})/) {
            $in = $`.chr(oct($1)).$';
            $mod = 1;
        } elsif ($in =~ /\$([4-9])([A-Z])/) {
            $i = ord($2) - ord('A');
            if ($1 == 4) {
                $in = $`.chr($i+0x01).$';
            } elsif ($1 == 5) {
                $in = $`.chr($i+0x21).$';
            } elsif ($1 == 6) {
                $in = $`.($i ? chr($i+0x1A) : chr(0)).$';
            } elsif ($1 == 7) {
                $in = $`.($i ? chr($i+0x3A) : ' ').$';
            } elsif ($1 == 8) {
                $in = $`.($i ? chr($i+0x5A) : chr(0x40)).$';
            } elsif ($1 == 9) {
                $in = $`.($i ? chr($i+0x7A) : chr(0x60)).$';
            }
            $mod = 1;
        }
    }

    $mod = 1;
    $shift = 0;
    $in = lc($in);
    $out = '';
    while ($mod) {
        $mod = 0;
        if ($in =~ /\$([A-Z\$])/i) {
            if ($1 eq '$') {
                $out .= $`.'$';
                $in  = $';
                $mod = 1;
            } else {
                $shift = !$shift;
                $out .= $`.($shift? uc($1) : lc($1));
                $in = $shift ? uc($') : lc($');
                $mod = 1;
            }
        }
    }
    return ($out.$in);
}

sub safepath ($;$) {
    my ($path, $dolast) = @_;
    my (@e) = split('/',$path);
    my ($j, $isadir);

    if (!defined($dolast)) {$dolast = 0;}
    $isadir = ($path =~ /\/$/);
    $dolast ^= $isadir;

    for ($j = 0; $j < $#e ; $j++) {
        $e[$j] = safename($e[$j],1);
    }
    $e[$#e] = safename($e[$#e],$dolast);
    $path = join('/',@e).($isadir ? '/' : '');
    return $path;
}

sub unsafepath ($) {
    return unsafename($_[0]);
}


sub safe_archive ($) {
    my $name = shift;
    my $suff = '';
    if ($name =~ /\.([\w\-\$]+)\.(gz|Z|zip|gzip)\Z/i) {
        $suff = $1.'-'.$2;
        $name = $`;
    } elsif ($name =~ /\.([\w\-\$]+)\Z/i) {
        $suff = $1;
        $name = $`;
    }
    $name =~ s#\.$##;
    $name =~ s#\.#_#g;
    $name .= '.'.$suff;
    return $name;
}



1;