summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/GlobMapper.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/File/GlobMapper.pm679
1 files changed, 679 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/GlobMapper.pm b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
new file mode 100644
index 00000000000..40a606309e0
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
@@ -0,0 +1,679 @@
+package File::GlobMapper;
+
+use strict;
+use warnings;
+use Carp;
+
+our ($CSH_GLOB);
+
+BEGIN
+{
+ if ($] < 5.006)
+ {
+ require File::BSDGlob; import File::BSDGlob qw(:glob) ;
+ $CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
+ *globber = \&File::BSDGlob::csh_glob;
+ }
+ else
+ {
+ require File::Glob; import File::Glob qw(:glob) ;
+ $CSH_GLOB = File::Glob::GLOB_CSH() ;
+ #*globber = \&File::Glob::bsd_glob;
+ *globber = \&File::Glob::csh_glob;
+ }
+}
+
+our ($Error);
+
+our ($VERSION, @EXPORT_OK);
+$VERSION = '1.000';
+@EXPORT_OK = qw( globmap );
+
+
+our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
+$noPreBS = '(?<!\\\)' ; # no preceeding backslash
+$metachars = '.*?[](){}';
+$matchMetaRE = '[' . quotemeta($metachars) . ']';
+
+%mapping = (
+ '*' => '([^/]*)',
+ '?' => '([^/])',
+ '.' => '\.',
+ '[' => '([',
+ '(' => '(',
+ ')' => ')',
+ );
+
+%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
+
+sub globmap ($$;)
+{
+ my $inputGlob = shift ;
+ my $outputGlob = shift ;
+
+ my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_)
+ or croak "globmap: $Error" ;
+ return $obj->getFileMap();
+}
+
+sub new
+{
+ my $class = shift ;
+ my $inputGlob = shift ;
+ my $outputGlob = shift ;
+ # TODO -- flags needs to default to whatever File::Glob does
+ my $flags = shift || $CSH_GLOB ;
+ #my $flags = shift ;
+
+ $inputGlob =~ s/^\s*\<\s*//;
+ $inputGlob =~ s/\s*\>\s*$//;
+
+ $outputGlob =~ s/^\s*\<\s*//;
+ $outputGlob =~ s/\s*\>\s*$//;
+
+ my %object =
+ ( InputGlob => $inputGlob,
+ OutputGlob => $outputGlob,
+ GlobFlags => $flags,
+ Braces => 0,
+ WildCount => 0,
+ Pairs => [],
+ Sigil => '#',
+ );
+
+ my $self = bless \%object, ref($class) || $class ;
+
+ $self->_parseInputGlob()
+ or return undef ;
+
+ $self->_parseOutputGlob()
+ or return undef ;
+
+ my @inputFiles = globber($self->{InputGlob}, $flags) ;
+
+ if (GLOB_ERROR)
+ {
+ $Error = $!;
+ return undef ;
+ }
+
+ #if (whatever)
+ {
+ my $missing = grep { ! -e $_ } @inputFiles ;
+
+ if ($missing)
+ {
+ $Error = "$missing input files do not exist";
+ return undef ;
+ }
+ }
+
+ $self->{InputFiles} = \@inputFiles ;
+
+ $self->_getFiles()
+ or return undef ;
+
+ return $self;
+}
+
+sub _retError
+{
+ my $string = shift ;
+ $Error = "$string in input fileglob" ;
+ return undef ;
+}
+
+sub _unmatched
+{
+ my $delimeter = shift ;
+
+ _retError("Unmatched $delimeter");
+ return undef ;
+}
+
+sub _parseBit
+{
+ my $self = shift ;
+
+ my $string = shift ;
+
+ my $out = '';
+ my $depth = 0 ;
+
+ while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
+ {
+ $out .= quotemeta($1) ;
+ $out .= $mapping{$2} if defined $mapping{$2};
+
+ ++ $self->{WildCount} if $wildCount{$2} ;
+
+ if ($2 eq ',')
+ {
+ return _unmatched "("
+ if $depth ;
+
+ $out .= '|';
+ }
+ elsif ($2 eq '(')
+ {
+ ++ $depth ;
+ }
+ elsif ($2 eq ')')
+ {
+ return _unmatched ")"
+ if ! $depth ;
+
+ -- $depth ;
+ }
+ elsif ($2 eq '[')
+ {
+ # TODO -- quotemeta & check no '/'
+ # TODO -- check for \] & other \ within the []
+ $string =~ s#(.*?\])##
+ or return _unmatched "[" ;
+ $out .= "$1)" ;
+ }
+ elsif ($2 eq ']')
+ {
+ return _unmatched "]" ;
+ }
+ elsif ($2 eq '{' || $2 eq '}')
+ {
+ return _retError "Nested {} not allowed" ;
+ }
+ }
+
+ $out .= quotemeta $string;
+
+ return _unmatched "("
+ if $depth ;
+
+ return $out ;
+}
+
+sub _parseInputGlob
+{
+ my $self = shift ;
+
+ my $string = $self->{InputGlob} ;
+ my $inGlob = '';
+
+ # Multiple concatenated *'s don't make sense
+ #$string =~ s#\*\*+#*# ;
+
+ # TODO -- Allow space to delimit patterns?
+ #my @strings = split /\s+/, $string ;
+ #for my $str (@strings)
+ my $out = '';
+ my $depth = 0 ;
+
+ while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
+ {
+ $out .= quotemeta($1) ;
+ $out .= $mapping{$2} if defined $mapping{$2};
+ ++ $self->{WildCount} if $wildCount{$2} ;
+
+ if ($2 eq '(')
+ {
+ ++ $depth ;
+ }
+ elsif ($2 eq ')')
+ {
+ return _unmatched ")"
+ if ! $depth ;
+
+ -- $depth ;
+ }
+ elsif ($2 eq '[')
+ {
+ # TODO -- quotemeta & check no '/' or '(' or ')'
+ # TODO -- check for \] & other \ within the []
+ $string =~ s#(.*?\])##
+ or return _unmatched "[";
+ $out .= "$1)" ;
+ }
+ elsif ($2 eq ']')
+ {
+ return _unmatched "]" ;
+ }
+ elsif ($2 eq '}')
+ {
+ return _unmatched "}" ;
+ }
+ elsif ($2 eq '{')
+ {
+ # TODO -- check no '/' within the {}
+ # TODO -- check for \} & other \ within the {}
+
+ my $tmp ;
+ unless ( $string =~ s/(.*?)$noPreBS\}//)
+ {
+ return _unmatched "{";
+ }
+ #$string =~ s#(.*?)\}##;
+
+ #my $alt = join '|',
+ # map { quotemeta $_ }
+ # split "$noPreBS,", $1 ;
+ my $alt = $self->_parseBit($1);
+ defined $alt or return 0 ;
+ $out .= "($alt)" ;
+
+ ++ $self->{Braces} ;
+ }
+ }
+
+ return _unmatched "("
+ if $depth ;
+
+ $out .= quotemeta $string ;
+
+
+ $self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
+ $self->{InputPattern} = $out ;
+
+ #print "# INPUT '$self->{InputGlob}' => '$out'\n";
+
+ return 1 ;
+
+}
+
+sub _parseOutputGlob
+{
+ my $self = shift ;
+
+ my $string = $self->{OutputGlob} ;
+ my $maxwild = $self->{WildCount};
+
+ if ($self->{GlobFlags} & GLOB_TILDE)
+ #if (1)
+ {
+ $string =~ s{
+ ^ ~ # find a leading tilde
+ ( # save this in $1
+ [^/] # a non-slash character
+ * # repeated 0 or more times (0 means me)
+ )
+ }{
+ $1
+ ? (getpwnam($1))[7]
+ : ( $ENV{HOME} || $ENV{LOGDIR} )
+ }ex;
+
+ }
+
+ # max #1 must be == to max no of '*' in input
+ while ( $string =~ m/#(\d)/g )
+ {
+ croak "Max wild is #$maxwild, you tried #$1"
+ if $1 > $maxwild ;
+ }
+
+ my $noPreBS = '(?<!\\\)' ; # no preceeding backslash
+ #warn "noPreBS = '$noPreBS'\n";
+
+ #$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
+ $string =~ s/${noPreBS}#(\d)/\${$1}/g;
+ $string =~ s#${noPreBS}\*#\${inFile}#g;
+ $string = '"' . $string . '"';
+
+ #print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
+ $self->{OutputPattern} = $string ;
+
+ return 1 ;
+}
+
+sub _getFiles
+{
+ my $self = shift ;
+
+ my %outInMapping = ();
+ my %inFiles = () ;
+
+ foreach my $inFile (@{ $self->{InputFiles} })
+ {
+ next if $inFiles{$inFile} ++ ;
+
+ my $outFile = $inFile ;
+
+ if ( $inFile =~ m/$self->{InputPattern}/ )
+ {
+ no warnings 'uninitialized';
+ eval "\$outFile = $self->{OutputPattern};" ;
+
+ if (defined $outInMapping{$outFile})
+ {
+ $Error = "multiple input files map to one output file";
+ return undef ;
+ }
+ $outInMapping{$outFile} = $inFile;
+ push @{ $self->{Pairs} }, [$inFile, $outFile];
+ }
+ }
+
+ return 1 ;
+}
+
+sub getFileMap
+{
+ my $self = shift ;
+
+ return $self->{Pairs} ;
+}
+
+sub getHash
+{
+ my $self = shift ;
+
+ return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::GlobMapper - Extend File Glob to Allow Input and Output Files
+
+=head1 SYNOPSIS
+
+ use File::GlobMapper qw( globmap );
+
+ my $aref = globmap $input => $output
+ or die $File::GlobMapper::Error ;
+
+ my $gm = new File::GlobMapper $input => $output
+ or die $File::GlobMapper::Error ;
+
+
+=head1 DESCRIPTION
+
+This module needs Perl5.005 or better.
+
+This module takes the existing C<File::Glob> module as a starting point and
+extends it to allow new filenames to be derived from the files matched by
+C<File::Glob>.
+
+This can be useful when carrying out batch operations on multiple files that
+have both an input filename and output filename and the output file can be
+derived from the input filename. Examples of operations where this can be
+useful include, file renaming, file copying and file compression.
+
+
+=head2 Behind The Scenes
+
+To help explain what C<File::GlobMapper> does, consider what code you
+would write if you wanted to rename all files in the current directory
+that ended in C<.tar.gz> to C<.tgz>. So say these files are in the
+current directory
+
+ alpha.tar.gz
+ beta.tar.gz
+ gamma.tar.gz
+
+and they need renamed to this
+
+ alpha.tgz
+ beta.tgz
+ gamma.tgz
+
+Below is a possible implementation of a script to carry out the rename
+(error cases have been omitted)
+
+ foreach my $old ( glob "*.tar.gz" )
+ {
+ my $new = $old;
+ $new =~ s#(.*)\.tar\.gz$#$1.tgz# ;
+
+ rename $old => $new
+ or die "Cannot rename '$old' to '$new': $!\n;
+ }
+
+Notice that a file glob pattern C<*.tar.gz> was used to match the
+C<.tar.gz> files, then a fairly similar regular expression was used in
+the substitute to allow the new filename to be created.
+
+Given that the file glob is just a cut-down regular expression and that it
+has already done a lot of the hard work in pattern matching the filenames,
+wouldn't it be handy to be able to use the patterns in the fileglob to
+drive the new filename?
+
+Well, that's I<exactly> what C<File::GlobMapper> does.
+
+Here is same snippet of code rewritten using C<globmap>
+
+ for my $pair (globmap '<*.tar.gz>' => '<#1.tgz>' )
+ {
+ my ($from, $to) = @$pair;
+ rename $from => $to
+ or die "Cannot rename '$old' to '$new': $!\n;
+ }
+
+So how does it work?
+
+Behind the scenes the C<globmap> function does a combination of a
+file glob to match existing filenames followed by a substitute
+to create the new filenames.
+
+Notice how both parameters to C<globmap> are strings that are delimited by <>.
+This is done to make them look more like file globs - it is just syntactic
+sugar, but it can be handy when you want the strings to be visually
+distinctive. The enclosing <> are optional, so you don't have to use them - in
+fact the first thing globmap will do is remove these delimiters if they are
+present.
+
+The first parameter to C<globmap>, C<*.tar.gz>, is an I<Input File Glob>.
+Once the enclosing "< ... >" is removed, this is passed (more or
+less) unchanged to C<File::Glob> to carry out a file match.
+
+Next the fileglob C<*.tar.gz> is transformed behind the scenes into a
+full Perl regular expression, with the additional step of wrapping each
+transformed wildcard metacharacter sequence in parenthesis.
+
+In this case the input fileglob C<*.tar.gz> will be transformed into
+this Perl regular expression
+
+ ([^/]*)\.tar\.gz
+
+Wrapping with parenthesis allows the wildcard parts of the Input File
+Glob to be referenced by the second parameter to C<globmap>, C<#1.tgz>,
+the I<Output File Glob>. This parameter operates just like the replacement
+part of a substitute command. The difference is that the C<#1> syntax
+is used to reference sub-patterns matched in the input fileglob, rather
+than the C<$1> syntax that is used with perl regular expressions. In
+this case C<#1> is used to refer to the text matched by the C<*> in the
+Input File Glob. This makes it easier to use this module where the
+parameters to C<globmap> are typed at the command line.
+
+The final step involves passing each filename matched by the C<*.tar.gz>
+file glob through the derived Perl regular expression in turn and
+expanding the output fileglob using it.
+
+The end result of all this is a list of pairs of filenames. By default
+that is what is returned by C<globmap>. In this example the data structure
+returned will look like this
+
+ ( ['alpha.tar.gz' => 'alpha.tgz'],
+ ['beta.tar.gz' => 'beta.tgz' ],
+ ['gamma.tar.gz' => 'gamma.tgz']
+ )
+
+
+Each pair is an array reference with two elements - namely the I<from>
+filename, that C<File::Glob> has matched, and a I<to> filename that is
+derived from the I<from> filename.
+
+
+
+=head2 Limitations
+
+C<File::GlobMapper> has been kept simple deliberately, so it isn't intended to
+solve all filename mapping operations. Under the hood C<File::Glob> (or for
+older versions of Perl, C<File::BSDGlob>) is used to match the files, so you
+will never have the flexibility of full Perl regular expression.
+
+=head2 Input File Glob
+
+The syntax for an Input FileGlob is identical to C<File::Glob>, except
+for the following
+
+=over 5
+
+=item 1.
+
+No nested {}
+
+=item 2.
+
+Whitespace does not delimit fileglobs.
+
+=item 3.
+
+The use of parenthesis can be used to capture parts of the input filename.
+
+=item 4.
+
+If an Input glob matches the same file more than once, only the first
+will be used.
+
+=back
+
+The syntax
+
+=over 5
+
+=item B<~>
+
+=item B<~user>
+
+
+=item B<.>
+
+Matches a literal '.'.
+Equivalent to the Perl regular expression
+
+ \.
+
+=item B<*>
+
+Matches zero or more characters, except '/'. Equivalent to the Perl
+regular expression
+
+ [^/]*
+
+=item B<?>
+
+Matches zero or one character, except '/'. Equivalent to the Perl
+regular expression
+
+ [^/]?
+
+=item B<\>
+
+Backslash is used, as usual, to escape the next character.
+
+=item B<[]>
+
+Character class.
+
+=item B<{,}>
+
+Alternation
+
+=item B<()>
+
+Capturing parenthesis that work just like perl
+
+=back
+
+Any other character it taken literally.
+
+=head2 Output File Glob
+
+The Output File Glob is a normal string, with 2 glob-like features.
+
+The first is the '*' metacharacter. This will be replaced by the complete
+filename matched by the input file glob. So
+
+ *.c *.Z
+
+The second is
+
+Output FileGlobs take the
+
+=over 5
+
+=item "*"
+
+The "*" character will be replaced with the complete input filename.
+
+=item #1
+
+Patterns of the form /#\d/ will be replaced with the
+
+=back
+
+=head2 Returned Data
+
+
+=head1 EXAMPLES
+
+=head2 A Rename script
+
+Below is a simple "rename" script that uses C<globmap> to determine the
+source and destination filenames.
+
+ use File::GlobMapper qw(globmap) ;
+ use File::Copy;
+
+ die "rename: Usage rename 'from' 'to'\n"
+ unless @ARGV == 2 ;
+
+ my $fromGlob = shift @ARGV;
+ my $toGlob = shift @ARGV;
+
+ my $pairs = globmap($fromGlob, $toGlob)
+ or die $File::GlobMapper::Error;
+
+ for my $pair (@$pairs)
+ {
+ my ($from, $to) = @$pair;
+ move $from => $to ;
+ }
+
+
+
+Here is an example that renames all c files to cpp.
+
+ $ rename '*.c' '#1.cpp'
+
+=head2 A few example globmaps
+
+Below are a few examples of globmaps
+
+To copy all your .c file to a backup directory
+
+ '</my/home/*.c>' '</my/backup/#1.c>'
+
+If you want to compress all
+
+ '</my/home/*.[ch]>' '<*.gz>'
+
+To uncompress
+
+ '</my/home/*.[ch].gz>' '</my/home/#1.#2>'
+
+=head1 SEE ALSO
+
+L<File::Glob|File::Glob>
+
+=head1 AUTHOR
+
+The I<File::GlobMapper> module was written by Paul Marquess, F<pmqs@cpan.org>.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2005 Paul Marquess. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-20 17:24:27 +0000