From 804be6ac00dda12660071b6fbfce3e4647eff732 Mon Sep 17 00:00:00 2001 From: Flavio Poletti Date: Tue, 28 Feb 2023 00:22:22 +0100 Subject: [PATCH] Add bundled version and script to produce it --- bundle/mobundle | 4110 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ quine.sh | 11 + 2 files changed, 4121 insertions(+) create mode 100755 bundle/mobundle create mode 100755 quine.sh diff --git a/bundle/mobundle b/bundle/mobundle new file mode 100755 index 0000000..ff5353d --- /dev/null +++ b/bundle/mobundle @@ -0,0 +1,4110 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Carp; +use Pod::Usage qw( pod2usage ); +use Getopt::Long qw( :config gnu_getopt ); +use English qw( -no_match_vars ); +use File::Basename qw( basename ); +my $VERSION = '0.1.2'; + +# __MOBUNDLE_INCLUSION__ +BEGIN { + my %file_for = ( + + 'Path/Class/Dir.pm' => <<'END_OF_FILE', + use strict; + + package Path::Class::Dir; + { + $Path::Class::Dir::VERSION = '0.37'; + } + + use Path::Class::File; + use Carp(); + use parent qw(Path::Class::Entity); + + use IO::Dir (); + use File::Path (); + use File::Temp (); + use Scalar::Util (); + + # updir & curdir on the local machine, for screening them out in + # children(). Note that they don't respect 'foreign' semantics. + my $Updir = __PACKAGE__->_spec->updir; + my $Curdir = __PACKAGE__->_spec->curdir; + + sub new { + my $self = shift->SUPER::new(); + + # If the only arg is undef, it's probably a mistake. Without this + # special case here, we'd return the root directory, which is a + # lousy thing to do to someone when they made a mistake. Return + # undef instead. + return if @_==1 && !defined($_[0]); + + my $s = $self->_spec; + + my $first = (@_ == 0 ? $s->curdir : + !ref($_[0]) && $_[0] eq '' ? (shift, $s->rootdir) : + shift() + ); + + $self->{dirs} = []; + if ( Scalar::Util::blessed($first) && $first->isa("Path::Class::Dir") ) { + $self->{volume} = $first->{volume}; + push @{$self->{dirs}}, @{$first->{dirs}}; + } + else { + ($self->{volume}, my $dirs) = $s->splitpath( $s->canonpath("$first") , 1); + push @{$self->{dirs}}, $dirs eq $s->rootdir ? "" : $s->splitdir($dirs); + } + + push @{$self->{dirs}}, map { + Scalar::Util::blessed($_) && $_->isa("Path::Class::Dir") + ? @{$_->{dirs}} + : $s->splitdir( $s->canonpath($_) ) + } @_; + + + return $self; + } + + sub file_class { "Path::Class::File" } + + sub is_dir { 1 } + + sub as_foreign { + my ($self, $type) = @_; + + my $foreign = do { + local $self->{file_spec_class} = $self->_spec_class($type); + $self->SUPER::new; + }; + + # Clone internal structure + $foreign->{volume} = $self->{volume}; + my ($u, $fu) = ($self->_spec->updir, $foreign->_spec->updir); + $foreign->{dirs} = [ map {$_ eq $u ? $fu : $_} @{$self->{dirs}}]; + return $foreign; + } + + sub stringify { + my $self = shift; + my $s = $self->_spec; + return $s->catpath($self->{volume}, + $s->catdir(@{$self->{dirs}}), + ''); + } + + sub volume { shift()->{volume} } + + sub file { + local $Path::Class::Foreign = $_[0]->{file_spec_class} if $_[0]->{file_spec_class}; + return $_[0]->file_class->new(@_); + } + + sub basename { shift()->{dirs}[-1] } + + sub dir_list { + my $self = shift; + my $d = $self->{dirs}; + return @$d unless @_; + + my $offset = shift; + if ($offset < 0) { $offset = $#$d + $offset + 1 } + + return wantarray ? @$d[$offset .. $#$d] : $d->[$offset] unless @_; + + my $length = shift; + if ($length < 0) { $length = $#$d + $length + 1 - $offset } + return @$d[$offset .. $length + $offset - 1]; + } + + sub components { + my $self = shift; + return $self->dir_list(@_); + } + + sub subdir { + my $self = shift; + return $self->new($self, @_); + } + + sub parent { + my $self = shift; + my $dirs = $self->{dirs}; + my ($curdir, $updir) = ($self->_spec->curdir, $self->_spec->updir); + + if ($self->is_absolute) { + my $parent = $self->new($self); + pop @{$parent->{dirs}} if @$dirs > 1; + return $parent; + + } elsif ($self eq $curdir) { + return $self->new($updir); + + } elsif (!grep {$_ ne $updir} @$dirs) { # All updirs + return $self->new($self, $updir); # Add one more + + } elsif (@$dirs == 1) { + return $self->new($curdir); + + } else { + my $parent = $self->new($self); + pop @{$parent->{dirs}}; + return $parent; + } + } + + sub relative { + # File::Spec->abs2rel before version 3.13 returned the empty string + # when the two paths were equal - work around it here. + my $self = shift; + my $rel = $self->_spec->abs2rel($self->stringify, @_); + return $self->new( length $rel ? $rel : $self->_spec->curdir ); + } + + sub open { IO::Dir->new(@_) } + sub mkpath { File::Path::mkpath(shift()->stringify, @_) } + sub rmtree { File::Path::rmtree(shift()->stringify, @_) } + + sub remove { + rmdir( shift() ); + } + + sub traverse { + my $self = shift; + my ($callback, @args) = @_; + my @children = $self->children; + return $self->$callback( + sub { + my @inner_args = @_; + return map { $_->traverse($callback, @inner_args) } @children; + }, + @args + ); + } + + sub traverse_if { + my $self = shift; + my ($callback, $condition, @args) = @_; + my @children = grep { $condition->($_) } $self->children; + return $self->$callback( + sub { + my @inner_args = @_; + return map { $_->traverse_if($callback, $condition, @inner_args) } @children; + }, + @args + ); + } + + sub recurse { + my $self = shift; + my %opts = (preorder => 1, depthfirst => 0, @_); + + my $callback = $opts{callback} + or Carp::croak( "Must provide a 'callback' parameter to recurse()" ); + + my @queue = ($self); + + my $visit_entry; + my $visit_dir = + $opts{depthfirst} && $opts{preorder} + ? sub { + my $dir = shift; + my $ret = $callback->($dir); + unless( ($ret||'') eq $self->PRUNE ) { + unshift @queue, $dir->children; + } + } + : $opts{preorder} + ? sub { + my $dir = shift; + my $ret = $callback->($dir); + unless( ($ret||'') eq $self->PRUNE ) { + push @queue, $dir->children; + } + } + : sub { + my $dir = shift; + $visit_entry->($_) foreach $dir->children; + $callback->($dir); + }; + + $visit_entry = sub { + my $entry = shift; + if ($entry->is_dir) { $visit_dir->($entry) } # Will call $callback + else { $callback->($entry) } + }; + + while (@queue) { + $visit_entry->( shift @queue ); + } + } + + sub children { + my ($self, %opts) = @_; + + my $dh = $self->open or Carp::croak( "Can't open directory $self: $!" ); + + my @out; + while (defined(my $entry = $dh->read)) { + next if !$opts{all} && $self->_is_local_dot_dir($entry); + next if ($opts{no_hidden} && $entry =~ /^\./); + push @out, $self->file($entry); + $out[-1] = $self->subdir($entry) if -d $out[-1]; + } + return @out; + } + + sub _is_local_dot_dir { + my $self = shift; + my $dir = shift; + + return ($dir eq $Updir or $dir eq $Curdir); + } + + sub next { + my $self = shift; + unless ($self->{dh}) { + $self->{dh} = $self->open or Carp::croak( "Can't open directory $self: $!" ); + } + + my $next = $self->{dh}->read; + unless (defined $next) { + delete $self->{dh}; + ## no critic + return undef; + } + + # Figure out whether it's a file or directory + my $file = $self->file($next); + $file = $self->subdir($next) if -d $file; + return $file; + } + + sub subsumes { + Carp::croak "Too many arguments given to subsumes()" if $#_ > 2; + my ($self, $other) = @_; + Carp::croak( "No second entity given to subsumes()" ) unless defined $other; + + $other = $self->new($other) unless eval{$other->isa( "Path::Class::Entity")}; + $other = $other->dir unless $other->is_dir; + + if ($self->is_absolute) { + $other = $other->absolute; + } elsif ($other->is_absolute) { + $self = $self->absolute; + } + + $self = $self->cleanup; + $other = $other->cleanup; + + if ($self->volume || $other->volume) { + return 0 unless $other->volume eq $self->volume; + } + + # The root dir subsumes everything (but ignore the volume because + # we've already checked that) + return 1 if "@{$self->{dirs}}" eq "@{$self->new('')->{dirs}}"; + + # The current dir subsumes every relative path (unless starting with updir) + if ($self eq $self->_spec->curdir) { + return $other->{dirs}[0] ne $self->_spec->updir; + } + + my $i = 0; + while ($i <= $#{ $self->{dirs} }) { + return 0 if $i > $#{ $other->{dirs} }; + return 0 if $self->{dirs}[$i] ne $other->{dirs}[$i]; + $i++; + } + return 1; + } + + sub contains { + Carp::croak "Too many arguments given to contains()" if $#_ > 2; + my ($self, $other) = @_; + Carp::croak "No second entity given to contains()" unless defined $other; + return unless -d $self and (-e $other or -l $other); + + # We're going to resolve the path, and don't want side effects on the objects + # so clone them. This also handles strings passed as $other. + $self= $self->new($self)->resolve; + $other= $self->new($other)->resolve; + + return $self->subsumes($other); + } + + sub tempfile { + my $self = shift; + return File::Temp::tempfile(@_, DIR => $self->stringify); + } + + 1; + __END__ + + =head1 NAME + + Path::Class::Dir - Objects representing directories + + =head1 VERSION + + version 0.37 + + =head1 SYNOPSIS + + use Path::Class; # Exports dir() by default + + my $dir = dir('foo', 'bar'); # Path::Class::Dir object + my $dir = Path::Class::Dir->new('foo', 'bar'); # Same thing + + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. + print "dir: $dir\n"; + + if ($dir->is_absolute) { ... } + if ($dir->is_relative) { ... } + + my $v = $dir->volume; # Could be 'C:' on Windows, empty string + # on Unix, 'Macintosh HD:' on Mac OS + + $dir->cleanup; # Perform logical cleanup of pathname + $dir->resolve; # Perform physical cleanup of pathname + + my $file = $dir->file('file.txt'); # A file in this directory + my $subdir = $dir->subdir('george'); # A subdirectory + my $parent = $dir->parent; # The parent directory, 'foo' + + my $abs = $dir->absolute; # Transform to absolute path + my $rel = $abs->relative; # Transform to relative path + my $rel = $abs->relative('/foo'); # Relative to /foo + + print $dir->as_foreign('Mac'); # :foo:bar: + print $dir->as_foreign('Win32'); # foo\bar + + # Iterate with IO::Dir methods: + my $handle = $dir->open; + while (my $file = $handle->read) { + $file = $dir->file($file); # Turn into Path::Class::File object + ... + } + + # Iterate with Path::Class methods: + while (my $file = $dir->next) { + # $file is a Path::Class::File or Path::Class::Dir object + ... + } + + + =head1 DESCRIPTION + + The C class contains functionality for manipulating + directory names in a cross-platform way. + + =head1 METHODS + + =over 4 + + =item $dir = Path::Class::Dir->new( , , ... ) + + =item $dir = dir( , , ... ) + + Creates a new C object and returns it. The + arguments specify names of directories which will be joined to create + a single directory object. A volume may also be specified as the + first argument, or as part of the first argument. You can use + platform-neutral syntax: + + my $dir = dir( 'foo', 'bar', 'baz' ); + + or platform-native syntax: + + my $dir = dir( 'foo/bar/baz' ); + + or a mixture of the two: + + my $dir = dir( 'foo/bar', 'baz' ); + + All three of the above examples create relative paths. To create an + absolute path, either use the platform native syntax for doing so: + + my $dir = dir( '/var/tmp' ); + + or use an empty string as the first argument: + + my $dir = dir( '', 'var', 'tmp' ); + + If the second form seems awkward, that's somewhat intentional - paths + like C or C<\Windows> aren't cross-platform concepts in the + first place (many non-Unix platforms don't have a notion of a "root + directory"), so they probably shouldn't appear in your code if you're + trying to be cross-platform. The first form is perfectly natural, + because paths like this may come from config files, user input, or + whatever. + + As a special case, since it doesn't otherwise mean anything useful and + it's convenient to define this way, C<< Path::Class::Dir->new() >> (or + C) refers to the current directory (C<< File::Spec->curdir >>). + To get the current directory as an absolute path, do C<< + dir()->absolute >>. + + Finally, as another special case C will return undef, + since that's usually an accident on the part of the caller, and + returning the root directory would be a nasty surprise just asking for + trouble a few lines later. + + =item $dir->stringify + + This method is called internally when a C object is + used in a string context, so the following are equivalent: + + $string = $dir->stringify; + $string = "$dir"; + + =item $dir->volume + + Returns the volume (e.g. C on Windows, C on Mac OS, + etc.) of the directory object, if any. Otherwise, returns the empty + string. + + =item $dir->basename + + Returns the last directory name of the path as a string. + + =item $dir->is_dir + + Returns a boolean value indicating whether this object represents a + directory. Not surprisingly, L objects always + return false, and C objects always return true. + + =item $dir->is_absolute + + Returns true or false depending on whether the directory refers to an + absolute path specifier (like C or C<\Windows>). + + =item $dir->is_relative + + Returns true or false depending on whether the directory refers to a + relative path specifier (like C or C<./dir>). + + =item $dir->cleanup + + Performs a logical cleanup of the file path. For instance: + + my $dir = dir('/foo//baz/./foo')->cleanup; + # $dir now represents '/foo/baz/foo'; + + =item $dir->resolve + + Performs a physical cleanup of the file path. For instance: + + my $dir = dir('/foo//baz/../foo')->resolve; + # $dir now represents '/foo/foo', assuming no symlinks + + This actually consults the filesystem to verify the validity of the + path. + + =item $file = $dir->file( , , ..., ) + + Returns a L object representing an entry in C<$dir> + or one of its subdirectories. Internally, this just calls C<< + Path::Class::File->new( @_ ) >>. + + =item $subdir = $dir->subdir( , , ... ) + + Returns a new C object representing a subdirectory + of C<$dir>. + + =item $parent = $dir->parent + + Returns the parent directory of C<$dir>. Note that this is the + I parent, not necessarily the physical parent. It really + means we just chop off entries from the end of the directory list + until we cain't chop no more. If the directory is relative, we start + using the relative forms of parent directories. + + The following code demonstrates the behavior on absolute and relative + directories: + + $dir = dir('/foo/bar'); + for (1..6) { + print "Absolute: $dir\n"; + $dir = $dir->parent; + } + + $dir = dir('foo/bar'); + for (1..6) { + print "Relative: $dir\n"; + $dir = $dir->parent; + } + + ########### Output on Unix ################ + Absolute: /foo/bar + Absolute: /foo + Absolute: / + Absolute: / + Absolute: / + Absolute: / + Relative: foo/bar + Relative: foo + Relative: . + Relative: .. + Relative: ../.. + Relative: ../../.. + + =item @list = $dir->children + + Returns a list of L and/or C + objects listed in this directory, or in scalar context the number of + such objects. Obviously, it is necessary for C<$dir> to + exist and be readable in order to find its children. + + Note that the children are returned as subdirectories of C<$dir>, + i.e. the children of F will be F and F, not + F and F. + + Ordinarily C will not include the I and I + entries C<.> and C<..> (or their equivalents on non-Unix systems), + because that's like I'm-my-own-grandpa business. If you do want all + directory entries including these special ones, pass a true value for + the C parameter: + + @c = $dir->children(); # Just the children + @c = $dir->children(all => 1); # All entries + + In addition, there's a C parameter that will exclude all + normally "hidden" entries - on Unix this means excluding all entries + that begin with a dot (C<.>): + + @c = $dir->children(no_hidden => 1); # Just normally-visible entries + + + =item $abs = $dir->absolute + + Returns a C object representing C<$dir> as an + absolute path. An optional argument, given as either a string or a + C object, specifies the directory to use as the base + of relativity - otherwise the current working directory will be used. + + =item $rel = $dir->relative + + Returns a C object representing C<$dir> as a + relative path. An optional argument, given as either a string or a + C object, specifies the directory to use as the base + of relativity - otherwise the current working directory will be used. + + =item $boolean = $dir->subsumes($other) + + Returns true if this directory spec subsumes the other spec, and false + otherwise. Think of "subsumes" as "contains", but we only look at the + I, not whether C<$dir> actually contains C<$other> on the + filesystem. + + The C<$other> argument may be a C object, a + L object, or a string. In the latter case, we + assume it's a directory. + + # Examples: + dir('foo/bar' )->subsumes(dir('foo/bar/baz')) # True + dir('/foo/bar')->subsumes(dir('/foo/bar/baz')) # True + dir('foo/..')->subsumes(dir('foo/../bar)) # True + dir('foo/bar' )->subsumes(dir('bar/baz')) # False + dir('/foo/bar')->subsumes(dir('foo/bar')) # False + dir('foo/..')->subsumes(dir('bar')) # False! Use C to resolve ".." + + + =item $boolean = $dir->contains($other) + + Returns true if this directory actually contains C<$other> on the + filesystem. C<$other> doesn't have to be a direct child of C<$dir>, + it just has to be subsumed after both paths have been resolved. + + =item $foreign = $dir->as_foreign($type) + + Returns a C object representing C<$dir> as it would + be specified on a system of type C<$type>. Known types include + C, C, C, C, and C, i.e. anything for which + there is a subclass of C. + + Any generated objects (subdirectories, files, parents, etc.) will also + retain this type. + + =item $foreign = Path::Class::Dir->new_foreign($type, @args) + + Returns a C object representing C<$dir> as it would + be specified on a system of type C<$type>. Known types include + C, C, C, C, and C, i.e. anything for which + there is a subclass of C. + + The arguments in C<@args> are the same as they would be specified in + C. + + =item @list = $dir->dir_list([OFFSET, [LENGTH]]) + + Returns the list of strings internally representing this directory + structure. Each successive member of the list is understood to be an + entry in its predecessor's directory list. By contract, C<< + Path::Class->new( $dir->dir_list ) >> should be equivalent to C<$dir>. + + The semantics of this method are similar to Perl's C or + C functions; they return C elements starting at + C. If C is omitted, returns all the elements starting + at C up to the end of the list. If C is negative, + returns the elements from C onward except for C<-LENGTH> + elements at the end. If C is negative, it counts backward + C elements from the end of the list. If C and + C are both omitted, the entire list is returned. + + In a scalar context, C with no arguments returns the + number of entries in the directory list; C returns + the single element at that offset; C returns + the final element that would have been returned in a list context. + + =item $dir->components + + Identical to C. It exists because there's an analogous + method C in the C class that also + returns the basename string, so this method lets someone call + C without caring whether the object is a file or a + directory. + + =item $fh = $dir->open() + + Passes C<$dir> to C<< IO::Dir->open >> and returns the result as an + L object. If the opening fails, C is returned and + C<$!> is set. + + =item $dir->mkpath($verbose, $mode) + + Passes all arguments, including C<$dir>, to C<< File::Path::mkpath() + >> and returns the result (a list of all directories created). + + =item $dir->rmtree($verbose, $cautious) + + Passes all arguments, including C<$dir>, to C<< File::Path::rmtree() + >> and returns the result (the number of files successfully deleted). + + =item $dir->remove() + + Removes the directory, which must be empty. Returns a boolean value + indicating whether or not the directory was successfully removed. + This method is mainly provided for consistency with + C's C method. + + =item $dir->tempfile(...) + + An interface to L's C function. Just like + that function, if you call this in a scalar context, the return value + is the filehandle and the file is Ced as soon as possible + (which is immediately on Unix-like platforms). If called in a list + context, the return values are the filehandle and the filename. + + The given directory is passed as the C parameter. + + Here's an example of pretty good usage which doesn't allow race + conditions, won't leave yucky tempfiles around on your filesystem, + etc.: + + my $fh = $dir->tempfile; + print $fh "Here's some data...\n"; + seek($fh, 0, 0); + while (<$fh>) { do something... } + + Or in combination with a C: + + my $fh = $dir->tempfile; + print $fh "Here's some more data...\n"; + seek($fh, 0, 0); + if ($pid=fork()) { + wait; + } else { + something($_) while <$fh>; + } + + + =item $dir_or_file = $dir->next() + + A convenient way to iterate through directory contents. The first + time C is called, it will C the directory and read the + first item from it, returning the result as a C or + L object (depending, of course, on its actual + type). Each subsequent call to C will simply iterate over the + directory's contents, until there are no more items in the directory, + and then the undefined value is returned. For example, to iterate + over all the regular files in a directory: + + while (my $file = $dir->next) { + next unless -f $file; + my $fh = $file->open('r') or die "Can't read $file: $!"; + ... + } + + If an error occurs when opening the directory (for instance, it + doesn't exist or isn't readable), C will throw an exception + with the value of C<$!>. + + =item $dir->traverse( sub { ... }, @args ) + + Calls the given callback for the root, passing it a continuation + function which, when called, will call this recursively on each of its + children. The callback function should be of the form: + + sub { + my ($child, $cont, @args) = @_; + # ... + } + + For instance, to calculate the number of files in a directory, you + can do this: + + my $nfiles = $dir->traverse(sub { + my ($child, $cont) = @_; + return sum($cont->(), ($child->is_dir ? 0 : 1)); + }); + + or to calculate the maximum depth of a directory: + + my $depth = $dir->traverse(sub { + my ($child, $cont, $depth) = @_; + return max($cont->($depth + 1), $depth); + }, 0); + + You can also choose not to call the callback in certain situations: + + $dir->traverse(sub { + my ($child, $cont) = @_; + return if -l $child; # don't follow symlinks + # do something with $child + return $cont->(); + }); + + =item $dir->traverse_if( sub { ... }, sub { ... }, @args ) + + traverse with additional "should I visit this child" callback. + Particularly useful in case examined tree contains inaccessible + directories. + + Canonical example: + + $dir->traverse_if( + sub { + my ($child, $cont) = @_; + # do something with $child + return $cont->(); + }, + sub { + my ($child) = @_; + # Process only readable items + return -r $child; + }); + + Second callback gets single parameter: child. Only children for + which it returns true will be processed by the first callback. + + Remaining parameters are interpreted as in traverse, in particular + C is equivalent to + C. + + =item $dir->recurse( callback => sub {...} ) + + Iterates through this directory and all of its children, and all of + its children's children, etc., calling the C subroutine for + each entry. This is a lot like what the L module does, + and of course C will work fine on L objects, + but the advantage of the C method is that it will also feed + your callback routine C objects rather than just pathname + strings. + + The C method requires a C parameter specifying + the subroutine to invoke for each entry. It will be passed the + C object as its first argument. + + C also accepts two boolean parameters, C and + C that control the order of recursion. The default is a + preorder, breadth-first search, i.e. C<< depthfirst => 0, preorder => 1 >>. + At the time of this writing, all combinations of these two parameters + are supported I C<< depthfirst => 0, preorder => 0 >>. + + C is normally not required to return any value. If it + returns special constant C (more easily + available as C<< $item->PRUNE >>), no children of analyzed + item will be analyzed (mostly as if you set C<$File::Find::prune=1>). Of course + pruning is available only in C, in postorder return value + has no effect. + + =item $st = $file->stat() + + Invokes C<< File::stat::stat() >> on this directory and returns a + C object representing the result. + + =item $st = $file->lstat() + + Same as C, but if C<$file> is a symbolic link, C + stats the link instead of the directory the link points to. + + =item $class = $file->file_class() + + Returns the class which should be used to create file objects. + + Generally overridden whenever this class is subclassed. + + =back + + =head1 AUTHOR + + Ken Williams, kwilliams@cpan.org + + =head1 SEE ALSO + + L, L, L + + =cut + +END_OF_FILE + + 'File/Slurp.pm' => <<'END_OF_FILE', + package File::Slurp; + + use strict; + use warnings ; + + our $VERSION = '9999.32'; + $VERSION = eval $VERSION; + + use Carp ; + use Exporter qw(import); + use Fcntl qw( :DEFAULT ) ; + use File::Basename (); + use File::Spec; + use File::Temp qw(tempfile); + use IO::Handle (); + use POSIX qw( :fcntl_h ) ; + use Errno ; + + my @std_export = qw( + read_file + write_file + overwrite_file + append_file + read_dir + ) ; + + my @edit_export = qw( + edit_file + edit_file_lines + ) ; + + my @abbrev_export = qw( + rf + wf + ef + efl + ) ; + + our @EXPORT_OK = ( + @edit_export, + @abbrev_export, + qw( + slurp + prepend_file + ), + ) ; + + our %EXPORT_TAGS = ( + 'all' => [ @std_export, @edit_export, @abbrev_export, @EXPORT_OK ], + 'edit' => [ @edit_export ], + 'std' => [ @std_export ], + 'abr' => [ @abbrev_export ], + ) ; + + our @EXPORT = @std_export ; + + my $max_fast_slurp_size = 1024 * 100 ; + + my $is_win32 = $^O =~ /win32/i ; + + *slurp = \&read_file ; + *rf = \&read_file ; + + sub read_file { + my $file_name = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {@_}; + # options we care about: + # array_ref binmode blk_size buf_ref chomp err_mode scalar_ref + + # let's see if we have a stringified object before doing anything else + # We then only have to deal with when we are given a file handle/globref + if (ref($file_name)) { + my $ref_result = _check_ref($file_name, $opts); + if (ref($ref_result)) { + @_ = ($opts, $ref_result); + goto &_error; + } + $file_name = $ref_result if $ref_result; + # we have now stringified $file_name if possible. if it's still a ref + # then we probably have a file handle + } + + my $fh; + if (ref($file_name)) { + $fh = $file_name; + } + else { + # to keep with the old ways, read in :raw by default + unless (open $fh, "<:raw", $file_name) { + @_ = ($opts, "read_file '$file_name' - open: $!"); + goto &_error; + } + # even though we set raw, let binmode take place here (busted) + if (my $bm = $opts->{binmode}) { + binmode $fh, $bm; + } + } + + # we are now sure to have an open file handle. Let's slurp it in the same + # way that File::Slurper does. + my $buf; + my $buf_ref = $opts->{buf_ref} || \$buf; + ${$buf_ref} = ''; + my $blk_size = $opts->{blk_size} || 1024 * 1024; + if (my $size = -f $fh && -s _) { + $blk_size = $size if $size < $blk_size; + my ($pos, $read) = 0; + do { + unless(defined($read = read $fh, ${$buf_ref}, $blk_size, $pos)) { + @_ = ($opts, "read_file '$file_name' - read: $!"); + goto &_error; + } + $pos += $read; + } while ($read && $pos < $size); + } + else { + ${$buf_ref} = do { local $/; <$fh> }; + } + seek($fh, $opts->{_data_tell}, SEEK_SET) if $opts->{_is_data} && $opts->{_data_tell}; + + # line endings if we're on Windows + ${$buf_ref} =~ s/\015\012/\012/g if ${$buf_ref} && $is_win32 && !$opts->{binmode}; + + # we now have a buffer filled with the file content. Figure out how to + # return it to the user + my $want_array = wantarray; # let's only ask for this once + if ($want_array || $opts->{array_ref}) { + use re 'taint'; + my $sep = $/; + $sep = '\n\n+' if defined $sep && $sep eq ''; + # split the buffered content into lines + my @lines = length(${$buf_ref}) ? + ${$buf_ref} =~ /(.*?$sep|.+)/sg : (); + chomp @lines if $opts->{chomp}; + return \@lines if $opts->{array_ref}; + return @lines; + } + return $buf_ref if $opts->{scalar_ref}; + # if the function was called in scalar context, return the contents + return ${$buf_ref} if defined $want_array; + # if we were called in void context, return nothing + return; + } + + # errors in this sub are returned as scalar refs + # a normal IO/GLOB handle is an empty return + # an overloaded object returns its stringified as a scalarfilename + + sub _check_ref { + + my( $handle, $opts ) = @_ ; + + # check if we are reading from a handle (GLOB or IO object) + + if ( eval { $handle->isa( 'GLOB' ) || $handle->isa( 'IO' ) } ) { + + # we have a handle. deal with seeking to it if it is DATA + + my $err = _seek_data_handle( $handle, $opts ) ; + + # return the error string if any + + return \$err if $err ; + + # we have good handle + return ; + } + + eval { require overload } ; + + # return an error if we can't load the overload pragma + # or if the object isn't overloaded + + return \"Bad handle '$handle' is not a GLOB or IO object or overloaded" + if $@ || !overload::Overloaded( $handle ) ; + + # must be overloaded so return its stringified value + + return "$handle" ; + } + + sub _seek_data_handle { + + my( $handle, $opts ) = @_ ; + # store some meta-data about the __DATA__ file handle + $opts->{_is_data} = 0; + $opts->{_data_tell} = 0; + + # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a + # glob/handle. only the DATA handle is untainted (since it is from + # trusted data in the source file). this allows us to test if this is + # the DATA handle and then to do a sysseek to make sure it gets + # slurped correctly. on some systems, the buffered i/o pointer is not + # left at the same place as the fd pointer. this sysseek makes them + # the same so slurping with sysread will work. + + eval{ require B } ; + + if ( $@ ) { + + return <IO->IoFLAGS & 16 ) { + + # we now know we have the data handle. Let's store its original + # location in the file so that we can put it back after the read. + # this is only done for Bugwards-compatibility in some dists such as + # CPAN::Index::API that made use of the oddity where sysread was in use + # before + $opts->{_is_data} = 1; + $opts->{_data_tell} = tell($handle); + # set the seek position to the current tell. + + # unless( sysseek( $handle, tell( $handle ), SEEK_SET ) ) { + # return "read_file '$handle' - sysseek: $!" ; + # } + } + + # seek was successful, return no error string + + return ; + } + + *wf = \&write_file ; + + sub write_file { + my $file_name = shift; + my $opts = (ref $_[0] eq 'HASH') ? shift : {}; + # options we care about: + # append atomic binmode buf_ref err_mode no_clobber perms + + my $fh; + my $no_truncate = 0; + my $orig_filename; + # let's see if we have a stringified object or some sort of handle + # or globref before doing anything else + if (ref($file_name)) { + my $ref_result = _check_ref($file_name, $opts); + if (ref($ref_result)) { + # some error happened while checking for a ref + @_ = ($opts, $ref_result); + goto &_error; + } + if ($ref_result) { + # we have now stringified $file_name from the overloaded obj + $file_name = $ref_result; + } + else { + # we now have a proper handle ref + # make sure we don't call truncate on it + $fh = $file_name; + $no_truncate = 1; + # can't do atomic or permissions on a file handle + delete $opts->{atomic}; + delete $opts->{perms}; + } + } + + # open the file for writing if we were given a filename + unless ($fh) { + $orig_filename = $file_name; + my $perms = defined($opts->{perms}) ? $opts->{perms} : 0666; + # set the mode for the sysopen + my $mode = O_WRONLY | O_CREAT; + $mode |= O_APPEND if $opts->{append}; + $mode |= O_EXCL if $opts->{no_clobber}; + if ($opts->{atomic}) { + # in an atomic write, we must open a new file in the same directory + # as the original to account for ACLs. We must also set the new file + # to the same permissions as the original unless overridden by the + # caller's request to set a specified permission set. + my $dir = File::Spec->rel2abs(File::Basename::dirname($file_name)); + if (!defined($opts->{perms}) && -e $file_name && -f _) { + $perms = 07777 & (stat $file_name)[2]; + } + # we must ensure we're using a good temporary filename (doesn't already + # exist). This is slower, but safer. + { + local $^W = 0; # AYFKM + (undef, $file_name) = tempfile('.tempXXXXX', DIR => $dir, OPEN => 0); + } + } + $fh = local *FH; + unless (sysopen($fh, $file_name, $mode, $perms)) { + @_ = ($opts, "write_file '$file_name' - sysopen: $!"); + goto &_error; + } + } + # we now have an open file handle as well as data to write to that handle + if (my $binmode = $opts->{binmode}) { + binmode($fh, $binmode); + } + + # get the data to print to the file + # get the buffer ref - it depends on how the data is passed in + # after this if/else $buf_ref will have a scalar ref to the data + my $buf_ref; + my $data_is_ref = 0; + if (ref($opts->{buf_ref}) eq 'SCALAR') { + # a scalar ref passed in %opts has the data + # note that the data was passed by ref + $buf_ref = $opts->{buf_ref}; + $data_is_ref = 1; + } + elsif (ref($_[0]) eq 'SCALAR') { + # the first value in @_ is the scalar ref to the data + # note that the data was passed by ref + $buf_ref = shift; + $data_is_ref = 1; + } + elsif (ref($_[0]) eq 'ARRAY') { + # the first value in @_ is the array ref to the data so join it. + ${$buf_ref} = join '', @{$_[0]}; + } + else { + # good old @_ has all the data so join it. + ${$buf_ref} = join '', @_; + } + + # seek and print + seek($fh, 0, SEEK_END) if $opts->{append}; + print {$fh} ${$buf_ref}; + truncate($fh, tell($fh)) unless $no_truncate; + close($fh); + + if ($opts->{atomic} && !rename($file_name, $orig_filename)) { + @_ = ($opts, "write_file '$file_name' - rename: $!"); + goto &_error; + } + + return 1; + } + + # this is for backwards compatibility with the previous File::Slurp module. + # write_file always overwrites an existing file + *overwrite_file = \&write_file ; + + # the current write_file has an append mode so we use that. this + # supports the same API with an optional second argument which is a + # hash ref of options. + + sub append_file { + + # get the optional opts hash ref + my $opts = $_[1] ; + if ( ref $opts eq 'HASH' ) { + + # we were passed an opts ref so just mark the append mode + + $opts->{append} = 1 ; + } + else { + + # no opts hash so insert one with the append mode + + splice( @_, 1, 0, { append => 1 } ) ; + } + + # magic goto the main write_file sub. this overlays the sub without touching + # the stack or @_ + + goto &write_file + } + + # prepend data to the beginning of a file + + sub prepend_file { + + my $file_name = shift ; + + #print "FILE $file_name\n" ; + + my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; + + # delete unsupported options + + my @bad_opts = + grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; + + delete @{$opts}{@bad_opts} ; + + my $prepend_data = shift ; + $prepend_data = '' unless defined $prepend_data ; + $prepend_data = ${$prepend_data} if ref $prepend_data eq 'SCALAR' ; + + #print "PRE [$prepend_data]\n" ; + + my $err_mode = delete $opts->{err_mode} ; + $opts->{ err_mode } = 'croak' ; + $opts->{ scalar_ref } = 1 ; + + my $existing_data = eval { read_file( $file_name, $opts ) } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "prepend_file '$file_name' - read_file: $!" ) ; + goto &_error ; + } + + #print "EXIST [$$existing_data]\n" ; + + $opts->{atomic} = 1 ; + my $write_result = + eval { write_file( $file_name, $opts, + $prepend_data, $$existing_data ) ; + } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "prepend_file '$file_name' - write_file: $!" ) ; + goto &_error ; + } + + return $write_result ; + } + + # edit a file as a scalar in $_ + + *ef = \&edit_file ; + + sub edit_file(&$;$) { + + my( $edit_code, $file_name, $opts ) = @_ ; + $opts = {} unless ref $opts eq 'HASH' ; + + # my $edit_code = shift ; + # my $file_name = shift ; + # my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; + + #print "FILE $file_name\n" ; + + # delete unsupported options + + my @bad_opts = + grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; + + delete @{$opts}{@bad_opts} ; + + # keep the user err_mode and force croaking on internal errors + + my $err_mode = delete $opts->{err_mode} ; + $opts->{ err_mode } = 'croak' ; + + # get a scalar ref for speed and slurp the file into a scalar + + $opts->{ scalar_ref } = 1 ; + my $existing_data = eval { read_file( $file_name, $opts ) } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "edit_file '$file_name' - read_file: $!" ) ; + goto &_error ; + } + + #print "EXIST [$$existing_data]\n" ; + + my( $edited_data ) = map { $edit_code->(); $_ } $$existing_data ; + + $opts->{atomic} = 1 ; + my $write_result = + eval { write_file( $file_name, $opts, $edited_data ) } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "edit_file '$file_name' - write_file: $!" ) ; + goto &_error ; + } + + return $write_result ; + } + + *efl = \&edit_file_lines ; + + sub edit_file_lines(&$;$) { + + my( $edit_code, $file_name, $opts ) = @_ ; + $opts = {} unless ref $opts eq 'HASH' ; + + # my $edit_code = shift ; + # my $file_name = shift ; + # my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; + + #print "FILE $file_name\n" ; + + # delete unsupported options + + my @bad_opts = + grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; + + delete @{$opts}{@bad_opts} ; + + # keep the user err_mode and force croaking on internal errors + + my $err_mode = delete $opts->{err_mode} ; + $opts->{ err_mode } = 'croak' ; + + # get an array ref for speed and slurp the file into lines + + $opts->{ array_ref } = 1 ; + my $existing_data = eval { read_file( $file_name, $opts ) } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "edit_file_lines '$file_name' - read_file: $!" ) ; + goto &_error ; + } + + #print "EXIST [$$existing_data]\n" ; + + my @edited_data = map { $edit_code->(); $_ } @$existing_data ; + + $opts->{atomic} = 1 ; + my $write_result = + eval { write_file( $file_name, $opts, @edited_data ) } ; + + if ( $@ ) { + + @_ = ( { err_mode => $err_mode }, + "edit_file_lines '$file_name' - write_file: $!" ) ; + goto &_error ; + } + + return $write_result ; + } + + # basic wrapper around opendir/readdir + + sub read_dir { + + my $dir = shift ; + my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { @_ } ; + + # this handle will be destroyed upon return + + local(*DIRH); + + # open the dir and handle any errors + + unless ( opendir( DIRH, $dir ) ) { + + @_ = ( $opts, "read_dir '$dir' - opendir: $!" ) ; + goto &_error ; + } + + my @dir_entries = readdir(DIRH) ; + + @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries ) + unless $opts->{'keep_dot_dot'} ; + + if ( $opts->{'prefix'} ) { + + $_ = File::Spec->catfile($dir, $_) for @dir_entries; + } + + return @dir_entries if wantarray ; + return \@dir_entries ; + } + + # error handling section + # + # all the error handling uses magic goto so the caller will get the + # error message as if from their code and not this module. if we just + # did a call on the error code, the carp/croak would report it from + # this module since the error sub is one level down on the call stack + # from read_file/write_file/read_dir. + + + my %err_func = ( + 'carp' => \&carp, + 'croak' => \&croak, + ) ; + + sub _error { + + my( $opts, $err_msg ) = @_ ; + + # get the error function to use + + my $func = $err_func{ $opts->{'err_mode'} || 'croak' } ; + + # if we didn't find it in our error function hash, they must have set + # it to quiet and we don't do anything. + + return unless $func ; + + # call the carp/croak function + + $func->($err_msg) if $func ; + + # return a hard undef (in list context this will be a single value of + # undef which is not a legal in-band value) + + return undef ; + } + + 1; + __END__ + + =head1 NAME + + File::Slurp - Simple and Efficient Reading/Writing/Modifying of Complete Files + + =head1 SYNOPSIS + + use File::Slurp; + + # read in a whole file into a scalar + my $text = read_file('/path/file'); + + # read in a whole file into an array of lines + my @lines = read_file('/path/file'); + + # write out a whole file from a scalar + write_file('/path/file', $text); + + # write out a whole file from an array of lines + write_file('/path/file', @lines); + + # Here is a simple and fast way to load and save a simple config file + # made of key=value lines. + my %conf = read_file('/path/file') =~ /^(\w+)=(.*)$/mg; + write_file('/path/file', {atomic => 1}, map "$_=$conf{$_}\n", keys %conf); + + # insert text at the beginning of a file + prepend_file('/path/file', $text); + + # in-place edit to replace all 'foo' with 'bar' in file + edit_file { s/foo/bar/g } '/path/file'; + + # in-place edit to delete all lines with 'foo' from file + edit_file_lines sub { $_ = '' if /foo/ }, '/path/file'; + + # read in a whole directory of file names (skipping . and ..) + my @files = read_dir('/path/to/dir'); + + =head1 DESCRIPTION + + This module provides subs that allow you to read or write entire files + with one simple call. They are designed to be simple to use, have + flexible ways to pass in or get the file contents and to be very + efficient. There is also a sub to read in all the files in a + directory. + + =head2 WARNING - PENDING DOOM + + Although you technically I, do NOT use this module to work on file handles, + pipes, sockets, standard IO, or the C handle. These are + features implemented long ago that just really shouldn't be abused here. + + Be warned: this activity will lead to inaccurate encoding/decoding of data. + + All further mentions of actions on the above have been removed from this + documentation and that feature set will likely be deprecated in the future. + + In other words, if you don't have a filename to pass, consider using the + standard C<< do { local $/; <$fh> } >>, or + L/L for working with C<__DATA__>. + + =head1 FUNCTIONS + + L implements the following functions. + + =head2 append_file + + use File::Slurp qw(append_file write_file); + my $res = append_file('/path/file', "Some text"); + # same as + my $res = write_file('/path/file', {append => 1}, "Some text"); + + The C function is simply a synonym for the + L function, but ensures that the C option is + set. + + =head2 edit_file + + use File::Slurp qw(edit_file); + # perl -0777 -pi -e 's/foo/bar/g' /path/file + edit_file { s/foo/bar/g } '/path/file'; + edit_file sub { s/foo/bar/g }, '/path/file'; + sub replace_foo { s/foo/bar/g } + edit_file \&replace_foo, '/path/file'; + + The C function reads in a file into C<$_>, executes a code block that + should modify C<$_>, and then writes C<$_> back to the file. The C + function reads in the entire file and calls the code block one time. It is + equivalent to the C<-pi> command line options of Perl but you can call it from + inside your program and not have to fork out a process. + + The first argument to C is a code block or a code reference. The + code block is not followed by a comma (as with C and C) but a code + reference is followed by a comma. + + The next argument is the filename. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The options are passed through to the + L function. All options are described there. + Only the C and C options are supported. The call to + L has the C option set so you will always + have a consistent file. + + =head2 edit_file_lines + + use File::Slurp qw(edit_file_lines); + # perl -pi -e '$_ = "" if /foo/' /path/file + edit_file_lines { $_ = '' if /foo/ } '/path/file'; + edit_file_lines sub { $_ = '' if /foo/ }, '/path/file'; + sub delete_foo { $_ = '' if /foo/ } + edit_file \&delete_foo, '/path/file'; + + The C function reads each line of a file into C<$_>, and + executes a code block that should modify C<$_>. It will then write C<$_> back + to the file. It is equivalent to the C<-pi> command line options of Perl but + you can call it from inside your program and not have to fork out a process. + + The first argument to C is a code block or a code reference. + The code block is not followed by a comma (as with C and C) but a + code reference is followed by a comma. + + The next argument is the filename. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The options are passed through to the + L function. All options are described there. + Only the C and C options are supported. The call to + L has the C option set so you will always + have a consistent file. + + =head2 ef + + use File::Slurp qw(ef); + # perl -0777 -pi -e 's/foo/bar/g' /path/file + ef { s/foo/bar/g } '/path/file'; + ef sub { s/foo/bar/g }, '/path/file'; + sub replace_foo { s/foo/bar/g } + ef \&replace_foo, '/path/file'; + + The C function is simply a synonym for the L + function. + + =head2 efl + + use File::Slurp qw(efl); + # perl -pi -e '$_ = "" if /foo/' /path/file + efl { $_ = '' if /foo/ } '/path/file'; + efl sub { $_ = '' if /foo/ }, '/path/file'; + sub delete_foo { $_ = '' if /foo/ } + efl \&delete_foo, '/path/file'; + + The C function is simply a synonym for the L + function. + + =head2 overwrite_file + + use File::Slurp qw(overwrite_file); + my $res = overwrite_file('/path/file', "Some text"); + + The C function is simply a synonym for the + L function. + + =head2 prepend_file + + use File::Slurp qw(prepend_file); + prepend_file('/path/file', $header); + prepend_file('/path/file', \@lines); + prepend_file('/path/file', { binmode => ':raw'}, $bin_data); + + # equivalent to: + use File::Slurp qw(read_file write_file); + my $content = read_file('/path/file'); + my $new_content = "hahahaha"; + write_file('/path/file', $new_content . $content); + + The C function is the opposite of L as + it writes new contents to the beginning of the file instead of the end. It is a + combination of L and L. It + works by first using C to slurp in the file and then calling + C with the new data and the existing file data. + + The first argument to C is the filename. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The options are passed through to the + L function. All options are described there. + + Only the C and C options are supported. The + C call has the C option set so you will always have + a consistent file. + + =head2 read_dir + + use File::Slurp qw(read_dir); + my @files = read_dir('/path/to/dir'); + # all files, even the dots + my @files = read_dir('/path/to/dir', keep_dot_dot => 1); + # keep the full file path + my @paths = read_dir('/path/to/dir', prefix => 1); + # scalar context + my $files_ref = read_dir('/path/to/dir'); + + This function returns a list of the filenames in the supplied directory. In + list context, an array is returned, in scalar context, an array reference is + returned. + + The first argument is the path to the directory to read. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The following options are available: + + =over + + =item + + err_mode + + The C option has three possible values: C, C, or the + default, C. In C mode, all errors will be silent. In C mode, + all errors will be emitted as warnings. And, in C mode, all errors will + be emitted as exceptions. Take a look at L or + L to see how to catch exceptions. + + =item + + keep_dot_dot + + The C option is a boolean option, defaulted to false (C<0>). + Setting this option to true (C<1>) will also return the C<.> and C<..> files + that are removed from the file list by default. + + =item + + prefix + + The C option is a boolean option, defaulted to false (C<0>). + Setting this option to true (C<1>) add the directory as a prefix to the file. + The directory and the filename are joined using C<< File::Spec->catfile() >> to + ensure the proper directory separator is used for your OS. See L. + + =back + + =head2 read_file + + use File::Slurp qw(read_file); + my $text = read_file('/path/file'); + my $bin = read_file('/path/file', { binmode => ':raw' }); + my @lines = read_file('/path/file'); + my $lines_ref = read_file('/path/file', array_ref => 1); + my $lines_ref = [ read_file('/path/file') ]; + + # or we can read into a buffer: + my $buffer; + read_file('/path/file', buf_ref => \$buffer); + + # or we can set the block size for the read + my $text_ref = read_file('/path/file', blk_size => 10_000_000, array_ref => 1); + + # or we can get a scalar reference + my $text_ref = read_file('/path/file', scalar_ref => 1); + + This function reads in an entire file and returns its contents to the + caller. In scalar context it returns the entire file as a single + scalar. In list context it will return a list of lines (using the + current value of C<$/> as the separator, including support for paragraph + mode when it is set to C<''>). + + The first argument is the path to the file to be slurped in. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The following options are available: + + =over + + =item + + array_ref + + The C option is a boolean option, defaulted to false (C<0>). Setting + this option to true (C<1>) will only have relevance if the C function + is called in scalar context. When true, the C function will return + a reference to an array of the lines in the file. + + =item + + binmode + + The C option is a string option, defaulted to empty (C<''>). If you + set the C option, then its value is passed to a call to C on + the opened handle. You can use this to set the file to be read in binary mode, + utf8, etc. See C for more. + + =item + + blk_size + + You can use this option to set the block size used when slurping from + an already open handle (like C<\*STDIN>). It defaults to 1MB. + + =item + + buf_ref + + The C option can be used in conjunction with any of the other options. + You can use this option to pass in a scalar reference and the slurped + file contents will be stored in the scalar. This saves an extra copy of + the slurped file and can lower RAM usage vs returning the file. It is + usually the fastest way to read a file into a scalar. + + =item + + chomp + + The C option is a boolean option, defaulted to false (C<0>). Setting + this option to true (C<1>) will cause each line to have its contents Ced. + This option works in list context or in scalar context with the C + option. + + =item + + err_mode + + The C option has three possible values: C, C, or the + default, C. In C mode, all errors will be silent. In C mode, + all errors will be emitted as warnings. And, in C mode, all errors will + be emitted as exceptions. Take a look at L or + L to see how to catch exceptions. + + =item + + scalar_ref + + The C option is a boolean option, defaulted to false (C<0>). It only + has meaning in scalar context. The return value will be a scalar reference to a + string which is the contents of the slurped file. This will usually be faster + than returning the plain scalar. It will also save memory as it will not make a + copy of the file to return. + + =back + + =head2 rf + + use File::Slurp qw(rf); + my $text = rf('/path/file'); + + The C function is simply a synonym for the L + function. + + =head2 slurp + + use File::Slurp qw(slurp); + my $text = slurp('/path/file'); + + The C function is simply a synonym for the L + function. + + =head2 wf + + use File::Slurp qw(wf); + my $res = wf('/path/file', "Some text"); + + + The C function is simply a synonym for the + L function. + + =head2 write_file + + use File::Slurp qw(write_file); + write_file('/path/file', @data); + write_file('/path/file', {append => 1}, @data); + write_file('/path/file', {binmode => ':raw'}, $buffer); + write_file('/path/file', \$buffer); + write_file('/path/file', $buffer); + write_file('/path/file', \@lines); + write_file('/path/file', @lines); + + # binmode + write_file('/path/file', {binmode => ':raw'}, @data); + write_file('/path/file', {binmode => ':utf8'}, $utf_text); + + # buffered + write_file('/path/file', {buf_ref => \$buffer}); + write_file('/path/file', \$buffer); + write_file('/path/file', $buffer); + + # append + write_file('/path/file', {append => 1}, @data); + + # no clobbering + write_file('/path/file', {no_clobber => 1}, @data); + + This function writes out an entire file in one call. By default C + returns C<1> upon successfully writing the file or C if it encountered + an error. You can change how errors are handled with the C option. + + The first argument to C is the filename. + + The next argument(s) is either a hash reference or a flattened hash, + C<< key => value >> pairs. The following options are available: + + =over + + =item + + append + + The C option is a boolean option, defaulted to false (C<0>). Setting + this option to true (C<1>) will cause the data to be be written at the end of + the current file. Internally this sets the C mode flag C. + + The L function sets this option by default. + + =item + + atomic + + The C option is a boolean option, defaulted to false (C<0>). Setting + this option to true (C<1>) will cause the file to be be written to in an + atomic fashion. A temporary file name is created using L. + After the file is closed it is renamed to the original file name + (and C is an atomic operation on most OSes). If the program using + this were to crash in the middle of this, then the temporary file could + be left behind. + + =item + + binmode + + The C option is a string option, defaulted to empty (C<''>). If you + set the C option, then its value is passed to a call to C on + the opened handle. You can use this to set the file to be read in binary mode, + utf8, etc. See C for more. + + =item + + buf_ref + + The C option is used to pass in a scalar reference which has the + data to be written. If this is set then any data arguments (including + the scalar reference shortcut) in C<@_> will be ignored. + + =item + + err_mode + + The C option has three possible values: C, C, or the + default, C. In C mode, all errors will be silent. In C mode, + all errors will be emitted as warnings. And, in C mode, all errors will + be emitted as exceptions. Take a look at L or + L to see how to catch exceptions. + + + =item + + no_clobber + + The C option is a boolean option, defaulted to false (C<0>). Setting + this option to true (C<1>) will ensure an that existing file will not be + overwritten. + + =item + + perms + + The C option sets the permissions of newly-created files. This value + is modified by your process's C and defaults to C<0666> (same as + C). + + NOTE: this option is new as of File::Slurp version 9999.14. + + =back + + =head1 EXPORT + + These are exported by default or with + + use File::Slurp qw(:std); + # read_file write_file overwrite_file append_file read_dir + + These are exported with + + use File::Slurp qw(:edit); + # edit_file edit_file_lines + + You can get all subs in the module exported with + + use File::Slurp qw(:all); + + =head1 SEE ALSO + + =over + + =item * + + L - Provides a straightforward set of functions for the most + common tasks of reading/writing text and binary files. + + =item * + + L - Lightweight and comprehensive file handling, including simple + methods for reading, writing, and editing text and binary files. + + =item * + + L - Similar to Path::Tiny for the L toolkit, always works in + bytes. + + =back + + =head1 AUTHOR + + Uri Guttman, > + + =head1 COPYRIGHT & LICENSE + + Copyright (c) 2003 Uri Guttman. All rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + + =cut + +END_OF_FILE + + 'Path/Class/File.pm' => <<'END_OF_FILE', + use strict; + + package Path::Class::File; + { + $Path::Class::File::VERSION = '0.37'; + } + + use Path::Class::Dir; + use parent qw(Path::Class::Entity); + use Carp; + + use IO::File (); + + sub new { + my $self = shift->SUPER::new; + my $file = pop(); + my @dirs = @_; + + my ($volume, $dirs, $base) = $self->_spec->splitpath($file); + + if (length $dirs) { + push @dirs, $self->_spec->catpath($volume, $dirs, ''); + } + + $self->{dir} = @dirs ? $self->dir_class->new(@dirs) : undef; + $self->{file} = $base; + + return $self; + } + + sub dir_class { "Path::Class::Dir" } + + sub as_foreign { + my ($self, $type) = @_; + local $Path::Class::Foreign = $self->_spec_class($type); + my $foreign = ref($self)->SUPER::new; + $foreign->{dir} = $self->{dir}->as_foreign($type) if defined $self->{dir}; + $foreign->{file} = $self->{file}; + return $foreign; + } + + sub stringify { + my $self = shift; + return $self->{file} unless defined $self->{dir}; + return $self->_spec->catfile($self->{dir}->stringify, $self->{file}); + } + + sub dir { + my $self = shift; + return $self->{dir} if defined $self->{dir}; + return $self->dir_class->new($self->_spec->curdir); + } + BEGIN { *parent = \&dir; } + + sub volume { + my $self = shift; + return '' unless defined $self->{dir}; + return $self->{dir}->volume; + } + + sub components { + my $self = shift; + croak "Arguments are not currently supported by File->components()" if @_; + return ($self->dir->components, $self->basename); + } + + sub basename { shift->{file} } + sub open { IO::File->new(@_) } + + sub openr { $_[0]->open('r') or croak "Can't read $_[0]: $!" } + sub openw { $_[0]->open('w') or croak "Can't write to $_[0]: $!" } + sub opena { $_[0]->open('a') or croak "Can't append to $_[0]: $!" } + + sub touch { + my $self = shift; + if (-e $self) { + utime undef, undef, $self; + } else { + $self->openw; + } + } + + sub slurp { + my ($self, %args) = @_; + my $iomode = $args{iomode} || 'r'; + my $fh = $self->open($iomode) or croak "Can't read $self: $!"; + + if (wantarray) { + my @data = <$fh>; + chomp @data if $args{chomped} or $args{chomp}; + + if ( my $splitter = $args{split} ) { + @data = map { [ split $splitter, $_ ] } @data; + } + + return @data; + } + + + croak "'split' argument can only be used in list context" + if $args{split}; + + + if ($args{chomped} or $args{chomp}) { + chomp( my @data = <$fh> ); + return join '', @data; + } + + + local $/; + return <$fh>; + } + + sub spew { + my $self = shift; + my %args = splice( @_, 0, @_-1 ); + + my $iomode = $args{iomode} || 'w'; + my $fh = $self->open( $iomode ) or croak "Can't write to $self: $!"; + + if (ref($_[0]) eq 'ARRAY') { + # Use old-school for loop to avoid copying. + for (my $i = 0; $i < @{ $_[0] }; $i++) { + print $fh $_[0]->[$i] + or croak "Can't write to $self: $!"; + } + } + else { + print $fh $_[0] + or croak "Can't write to $self: $!"; + } + + close $fh + or croak "Can't write to $self: $!"; + + return; + } + + sub spew_lines { + my $self = shift; + my %args = splice( @_, 0, @_-1 ); + + my $content = $_[0]; + + # If content is an array ref, appends $/ to each element of the array. + # Otherwise, if it is a simple scalar, just appends $/ to that scalar. + + $content + = ref( $content ) eq 'ARRAY' + ? [ map { $_, $/ } @$content ] + : "$content$/"; + + return $self->spew( %args, $content ); + } + + sub remove { + my $file = shift->stringify; + return unlink $file unless -e $file; # Sets $! correctly + 1 while unlink $file; + return not -e $file; + } + + sub copy_to { + my ($self, $dest) = @_; + if ( eval{ $dest->isa("Path::Class::File")} ) { + $dest = $dest->stringify; + croak "Can't copy to file $dest: it is a directory" if -d $dest; + } elsif ( eval{ $dest->isa("Path::Class::Dir") } ) { + $dest = $dest->stringify; + croak "Can't copy to directory $dest: it is a file" if -f $dest; + croak "Can't copy to directory $dest: no such directory" unless -d $dest; + } elsif ( ref $dest ) { + croak "Don't know how to copy files to objects of type '".ref($self)."'"; + } + + require Perl::OSType; + if ( !Perl::OSType::is_os_type('Unix') ) { + + require File::Copy; + return unless File::Copy::cp($self->stringify, "${dest}"); + + } else { + + return unless (system('cp', $self->stringify, "${dest}") == 0); + + } + + return $self->new($dest); + } + + sub move_to { + my ($self, $dest) = @_; + require File::Copy; + if (File::Copy::move($self->stringify, "${dest}")) { + + my $new = $self->new($dest); + + $self->{$_} = $new->{$_} foreach (qw/ dir file /); + + return $self; + + } else { + + return; + + } + } + + sub traverse { + my $self = shift; + my ($callback, @args) = @_; + return $self->$callback(sub { () }, @args); + } + + sub traverse_if { + my $self = shift; + my ($callback, $condition, @args) = @_; + return $self->$callback(sub { () }, @args); + } + + 1; + __END__ + + =head1 NAME + + Path::Class::File - Objects representing files + + =head1 VERSION + + version 0.37 + + =head1 SYNOPSIS + + use Path::Class; # Exports file() by default + + my $file = file('foo', 'bar.txt'); # Path::Class::File object + my $file = Path::Class::File->new('foo', 'bar.txt'); # Same thing + + # Stringifies to 'foo/bar.txt' on Unix, 'foo\bar.txt' on Windows, etc. + print "file: $file\n"; + + if ($file->is_absolute) { ... } + if ($file->is_relative) { ... } + + my $v = $file->volume; # Could be 'C:' on Windows, empty string + # on Unix, 'Macintosh HD:' on Mac OS + + $file->cleanup; # Perform logical cleanup of pathname + $file->resolve; # Perform physical cleanup of pathname + + my $dir = $file->dir; # A Path::Class::Dir object + + my $abs = $file->absolute; # Transform to absolute path + my $rel = $file->relative; # Transform to relative path + + =head1 DESCRIPTION + + The C class contains functionality for manipulating + file names in a cross-platform way. + + =head1 METHODS + + =over 4 + + =item $file = Path::Class::File->new( , , ..., ) + + =item $file = file( , , ..., ) + + Creates a new C object and returns it. The + arguments specify the path to the file. Any volume may also be + specified as the first argument, or as part of the first argument. + You can use platform-neutral syntax: + + my $file = file( 'foo', 'bar', 'baz.txt' ); + + or platform-native syntax: + + my $file = file( 'foo/bar/baz.txt' ); + + or a mixture of the two: + + my $file = file( 'foo/bar', 'baz.txt' ); + + All three of the above examples create relative paths. To create an + absolute path, either use the platform native syntax for doing so: + + my $file = file( '/var/tmp/foo.txt' ); + + or use an empty string as the first argument: + + my $file = file( '', 'var', 'tmp', 'foo.txt' ); + + If the second form seems awkward, that's somewhat intentional - paths + like C or C<\Windows> aren't cross-platform concepts in the + first place, so they probably shouldn't appear in your code if you're + trying to be cross-platform. The first form is perfectly fine, + because paths like this may come from config files, user input, or + whatever. + + =item $file->stringify + + This method is called internally when a C object is + used in a string context, so the following are equivalent: + + $string = $file->stringify; + $string = "$file"; + + =item $file->volume + + Returns the volume (e.g. C on Windows, C on Mac OS, + etc.) of the object, if any. Otherwise, returns the empty string. + + =item $file->basename + + Returns the name of the file as a string, without the directory + portion (if any). + + =item $file->components + + Returns a list of the directory components of this file, followed by + the basename. + + Note: unlike C<< $dir->components >>, this method currently does not + accept any arguments to select which elements of the list will be + returned. It may do so in the future. Currently it throws an + exception if such arguments are present. + + + =item $file->is_dir + + Returns a boolean value indicating whether this object represents a + directory. Not surprisingly, C objects always + return false, and L objects always return true. + + =item $file->is_absolute + + Returns true or false depending on whether the file refers to an + absolute path specifier (like C or C<\Windows\Foo.txt>). + + =item $file->is_relative + + Returns true or false depending on whether the file refers to a + relative path specifier (like C or C<.\Foo.txt>). + + =item $file->cleanup + + Performs a logical cleanup of the file path. For instance: + + my $file = file('/foo//baz/./foo.txt')->cleanup; + # $file now represents '/foo/baz/foo.txt'; + + =item $dir->resolve + + Performs a physical cleanup of the file path. For instance: + + my $file = file('/foo/baz/../foo.txt')->resolve; + # $file now represents '/foo/foo.txt', assuming no symlinks + + This actually consults the filesystem to verify the validity of the + path. + + =item $dir = $file->dir + + Returns a C object representing the directory + containing this file. + + =item $dir = $file->parent + + A synonym for the C method. + + =item $abs = $file->absolute + + Returns a C object representing C<$file> as an + absolute path. An optional argument, given as either a string or a + L object, specifies the directory to use as the base + of relativity - otherwise the current working directory will be used. + + =item $rel = $file->relative + + Returns a C object representing C<$file> as a + relative path. An optional argument, given as either a string or a + C object, specifies the directory to use as the base + of relativity - otherwise the current working directory will be used. + + =item $foreign = $file->as_foreign($type) + + Returns a C object representing C<$file> as it would + be specified on a system of type C<$type>. Known types include + C, C, C, C, and C, i.e. anything for which + there is a subclass of C. + + Any generated objects (subdirectories, files, parents, etc.) will also + retain this type. + + =item $foreign = Path::Class::File->new_foreign($type, @args) + + Returns a C object representing a file as it would + be specified on a system of type C<$type>. Known types include + C, C, C, C, and C, i.e. anything for which + there is a subclass of C. + + The arguments in C<@args> are the same as they would be specified in + C. + + =item $fh = $file->open($mode, $permissions) + + Passes the given arguments, including C<$file>, to C<< IO::File->new >> + (which in turn calls C<< IO::File->open >> and returns the result + as an L object. If the opening + fails, C is returned and C<$!> is set. + + =item $fh = $file->openr() + + A shortcut for + + $fh = $file->open('r') or croak "Can't read $file: $!"; + + =item $fh = $file->openw() + + A shortcut for + + $fh = $file->open('w') or croak "Can't write to $file: $!"; + + =item $fh = $file->opena() + + A shortcut for + + $fh = $file->open('a') or croak "Can't append to $file: $!"; + + =item $file->touch + + Sets the modification and access time of the given file to right now, + if the file exists. If it doesn't exist, C will I it + exist, and - YES! - set its modification and access time to now. + + =item $file->slurp() + + In a scalar context, returns the contents of C<$file> in a string. In + a list context, returns the lines of C<$file> (according to how C<$/> + is set) as a list. If the file can't be read, this method will throw + an exception. + + If you want C run on each line of the file, pass a true value + for the C or C parameters: + + my @lines = $file->slurp(chomp => 1); + + You may also use the C parameter to pass in an IO mode to use + when opening the file, usually IO layers (though anything accepted by + the MODE argument of C is accepted here). Just make sure it's + a I mode. + + my @lines = $file->slurp(iomode => ':crlf'); + my $lines = $file->slurp(iomode => '<:encoding(UTF-8)'); + + The default C is C. + + Lines can also be automatically split, mimicking the perl command-line + option C<-a> by using the C parameter. If this parameter is used, + each line will be returned as an array ref. + + my @lines = $file->slurp( chomp => 1, split => qr/\s*,\s*/ ); + + The C parameter can only be used in a list context. + + =item $file->spew( $content ); + + The opposite of L, this takes a list of strings and prints them + to the file in write mode. If the file can't be written to, this method + will throw an exception. + + The content to be written can be either an array ref or a plain scalar. + If the content is an array ref then each entry in the array will be + written to the file. + + You may use the C parameter to pass in an IO mode to use when + opening the file, just like L supports. + + $file->spew(iomode => '>:raw', $content); + + The default C is C. + + =item $file->spew_lines( $content ); + + Just like C, but, if $content is a plain scalar, appends $/ + to it, or, if $content is an array ref, appends $/ to each element + of the array. + + Can also take an C parameter like C. Again, the + default C is C. + + =item $file->traverse(sub { ... }, @args) + + Calls the given callback on $file. This doesn't do much on its own, + but see the associated documentation in L. + + =item $file->remove() + + This method will remove the file in a way that works well on all + platforms, and returns a boolean value indicating whether or not the + file was successfully removed. + + C is better than simply calling Perl's C function, + because on some platforms (notably VMS) you actually may need to call + C several times before all versions of the file are gone - + the C method handles this process for you. + + =item $st = $file->stat() + + Invokes C<< File::stat::stat() >> on this file and returns a + L object representing the result. + + =item $st = $file->lstat() + + Same as C, but if C<$file> is a symbolic link, C + stats the link instead of the file the link points to. + + =item $class = $file->dir_class() + + Returns the class which should be used to create directory objects. + + Generally overridden whenever this class is subclassed. + + =item $copy = $file->copy_to( $dest ); + + Copies the C<$file> to C<$dest>. It returns a L + object when successful, C otherwise. + + =item $moved = $file->move_to( $dest ); + + Moves the C<$file> to C<$dest>, and updates C<$file> accordingly. + + It returns C<$file> is successful, C otherwise. + + =back + + =head1 AUTHOR + + Ken Williams, kwilliams@cpan.org + + =head1 SEE ALSO + + L, L, L + + =cut + +END_OF_FILE + + 'Path/Class/Entity.pm' => <<'END_OF_FILE', + use strict; + + package Path::Class::Entity; + { + $Path::Class::Entity::VERSION = '0.37'; + } + + use File::Spec 3.26; + use File::stat (); + use Cwd; + use Carp(); + + use overload + ( + q[""] => 'stringify', + 'bool' => 'boolify', + fallback => 1, + ); + + sub new { + my $from = shift; + my ($class, $fs_class) = (ref($from) + ? (ref $from, $from->{file_spec_class}) + : ($from, $Path::Class::Foreign)); + return bless {file_spec_class => $fs_class}, $class; + } + + sub is_dir { 0 } + + sub _spec_class { + my ($class, $type) = @_; + + die "Invalid system type '$type'" unless ($type) = $type =~ /^(\w+)$/; # Untaint + my $spec = "File::Spec::$type"; + ## no critic + eval "require $spec; 1" or die $@; + return $spec; + } + + sub new_foreign { + my ($class, $type) = (shift, shift); + local $Path::Class::Foreign = $class->_spec_class($type); + return $class->new(@_); + } + + sub _spec { (ref($_[0]) && $_[0]->{file_spec_class}) || 'File::Spec' } + + sub boolify { 1 } + + sub is_absolute { + # 5.6.0 has a bug with regexes and stringification that's ticked by + # file_name_is_absolute(). Help it along with an explicit stringify(). + $_[0]->_spec->file_name_is_absolute($_[0]->stringify) + } + + sub is_relative { ! $_[0]->is_absolute } + + sub cleanup { + my $self = shift; + my $cleaned = $self->new( $self->_spec->canonpath("$self") ); + %$self = %$cleaned; + return $self; + } + + sub resolve { + my $self = shift; + Carp::croak($! . " $self") unless -e $self; # No such file or directory + my $cleaned = $self->new( scalar Cwd::realpath($self->stringify) ); + + # realpath() always returns absolute path, kind of annoying + $cleaned = $cleaned->relative if $self->is_relative; + + %$self = %$cleaned; + return $self; + } + + sub absolute { + my $self = shift; + return $self if $self->is_absolute; + return $self->new($self->_spec->rel2abs($self->stringify, @_)); + } + + sub relative { + my $self = shift; + return $self->new($self->_spec->abs2rel($self->stringify, @_)); + } + + sub stat { File::stat::stat("$_[0]") } + sub lstat { File::stat::lstat("$_[0]") } + + sub PRUNE { return \&PRUNE; } + + 1; + __END__ + + =head1 NAME + + Path::Class::Entity - Base class for files and directories + + =head1 VERSION + + version 0.37 + + =head1 DESCRIPTION + + This class is the base class for C and + C, it is not used directly by callers. + + =head1 AUTHOR + + Ken Williams, kwilliams@cpan.org + + =head1 SEE ALSO + + Path::Class + + =cut + +END_OF_FILE + + 'Path/Class.pm' => <<'END_OF_FILE', + use strict; + + package Path::Class; + { + $Path::Class::VERSION = '0.37'; + } + + { + ## no critic + no strict 'vars'; + @ISA = qw(Exporter); + @EXPORT = qw(file dir); + @EXPORT_OK = qw(file dir foreign_file foreign_dir tempdir); + } + + use Exporter; + use Path::Class::File; + use Path::Class::Dir; + use File::Temp (); + + sub file { Path::Class::File->new(@_) } + sub dir { Path::Class::Dir ->new(@_) } + sub foreign_file { Path::Class::File->new_foreign(@_) } + sub foreign_dir { Path::Class::Dir ->new_foreign(@_) } + sub tempdir { Path::Class::Dir->new(File::Temp::tempdir(@_)) } + + + 1; + __END__ + + =head1 NAME + + Path::Class - Cross-platform path specification manipulation + + =head1 VERSION + + version 0.37 + + =head1 SYNOPSIS + + use Path::Class; + + my $dir = dir('foo', 'bar'); # Path::Class::Dir object + my $file = file('bob', 'file.txt'); # Path::Class::File object + + # Stringifies to 'foo/bar' on Unix, 'foo\bar' on Windows, etc. + print "dir: $dir\n"; + + # Stringifies to 'bob/file.txt' on Unix, 'bob\file.txt' on Windows + print "file: $file\n"; + + my $subdir = $dir->subdir('baz'); # foo/bar/baz + my $parent = $subdir->parent; # foo/bar + my $parent2 = $parent->parent; # foo + + my $dir2 = $file->dir; # bob + + # Work with foreign paths + use Path::Class qw(foreign_file foreign_dir); + my $file = foreign_file('Mac', ':foo:file.txt'); + print $file->dir; # :foo: + print $file->as_foreign('Win32'); # foo\file.txt + + # Interact with the underlying filesystem: + + # $dir_handle is an IO::Dir object + my $dir_handle = $dir->open or die "Can't read $dir: $!"; + + # $file_handle is an IO::File object + my $file_handle = $file->open($mode) or die "Can't read $file: $!"; + + =head1 DESCRIPTION + + C is a module for manipulation of file and directory + specifications (strings describing their locations, like + C<'/home/ken/foo.txt'> or C<'C:\Windows\Foo.txt'>) in a cross-platform + manner. It supports pretty much every platform Perl runs on, + including Unix, Windows, Mac, VMS, Epoc, Cygwin, OS/2, and NetWare. + + The well-known module L also provides this service, but + it's sort of awkward to use well, so people sometimes avoid it, or use + it in a way that won't actually work properly on platforms + significantly different than the ones they've tested their code on. + + In fact, C uses C internally, wrapping all + the unsightly details so you can concentrate on your application code. + Whereas C provides functions for some common path + manipulations, C provides an object-oriented model of the + world of path specifications and their underlying semantics. + C doesn't create any objects, and its classes represent + the different ways in which paths must be manipulated on various + platforms (not a very intuitive concept). C creates + objects representing files and directories, and provides methods that + relate them to each other. For instance, the following C + code: + + my $absolute = File::Spec->file_name_is_absolute( + File::Spec->catfile( @dirs, $file ) + ); + + can be written using C as + + my $absolute = Path::Class::File->new( @dirs, $file )->is_absolute; + + or even as + + my $absolute = file( @dirs, $file )->is_absolute; + + Similar readability improvements should happen all over the place when + using C. + + Using C can help solve real problems in your code too - + for instance, how many people actually take the "volume" (like C + on Windows) into account when writing C-using code? I + thought not. But if you use C, your file and directory objects + will know what volumes they refer to and do the right thing. + + The guts of the C code live in the L + and L modules, so please see those + modules' documentation for more details about how to use them. + + =head2 EXPORT + + The following functions are exported by default. + + =over 4 + + =item file + + A synonym for C<< Path::Class::File->new >>. + + =item dir + + A synonym for C<< Path::Class::Dir->new >>. + + =back + + If you would like to prevent their export, you may explicitly pass an + empty list to perl's C, i.e. C. + + The following are exported only on demand. + + =over 4 + + =item foreign_file + + A synonym for C<< Path::Class::File->new_foreign >>. + + =item foreign_dir + + A synonym for C<< Path::Class::Dir->new_foreign >>. + + =item tempdir + + Create a new Path::Class::Dir instance pointed to temporary directory. + + my $temp = Path::Class::tempdir(CLEANUP => 1); + + A synonym for C<< Path::Class::Dir->new(File::Temp::tempdir(@_)) >>. + + =back + + =head1 Notes on Cross-Platform Compatibility + + Although it is much easier to write cross-platform-friendly code with + this module than with C, there are still some issues to be + aware of. + + =over 4 + + =item * + + On some platforms, notably VMS and some older versions of DOS (I think), + all filenames must have an extension. Thus if you create a file + called F and then ask for a list of files in the directory + F, you may find a file called F instead of the F you + were expecting. Thus it might be a good idea to use an extension in + the first place. + + =back + + =head1 AUTHOR + + Ken Williams, KWILLIAMS@cpan.org + + =head1 COPYRIGHT + + Copyright (c) Ken Williams. All rights reserved. + + This library is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + + =head1 SEE ALSO + + L, L, L + + =cut + +END_OF_FILE + + 'Template/Perlish.pm' => <<'END_OF_FILE', + package Template::Perlish; + + # vim: ts=3 sts=3 sw=3 et ai : + + use 5.008_000; + use warnings; + use strict; + use Carp; + use English qw( -no_match_vars ); + use constant ERROR_CONTEXT => 3; + { our $VERSION = '1.58'; } + use Scalar::Util qw< blessed reftype >; + + # Function-oriented interface + sub import { + my ($package, @list) = @_; + + for my $sub (@list) { + croak "subroutine '$sub' not exportable" + unless grep { $sub eq $_ } qw< crumble render traverse >; + + my $caller = caller(); + + no strict 'refs'; ## no critic (ProhibitNoStrict) + local $SIG{__WARN__} = \&Carp::carp; + *{$caller . q<::> . $sub} = \&{$package . q<::> . $sub}; + } ## end for my $sub (@list) + + return; + } ## end sub import + + sub render { + my ($template, @rest) = @_; + my ($variables, %params); + if (@rest) { + $variables = ref($rest[0]) ? shift(@rest) : {splice @rest, 0}; + %params = %{shift @rest} if @rest; + } + return __PACKAGE__->new(%params)->process($template, $variables); + } ## end sub render + + # Object-oriented interface + { + my (%preset_for, %inhibits_defaults); + BEGIN { + %preset_for = ( + 'default' => { + method_over_key => 0, + start => '[%', + stdout => 1, + stop => '%]', + strict_blessed => 0, + traverse_methods => 0, + utf8 => 1, + }, + '1.52' => { + method_over_key => 1, + stdout => 0, + traverse_methods => 1, + }, + ); + + # some defaults are inhibited by the presence of certain input + # parameters. These parameters can still be put externally, though. + %inhibits_defaults = ( + binmode => [qw< utf8 >], + ); + } + sub new { + my $package = shift; + + my %external; + if (@_ == 1) { + %external = %{$_[0]}; + } + elsif (scalar(@_) % 2 == 0) { + while (@_) { + my ($key, $value) = splice @_, 0, 2; + if ($key eq '-preset') { + croak "invalid preset $value in new()" + unless exists $preset_for{$value}; + %external = (%external, %{$preset_for{$value}}); + } + else { + $external{$key} = $value; + } + } + } + else { + croak 'invalid number of input arguments for constructor'; + } + + # compute defaults, removing inhibitions + my %defaults =(%{$preset_for{'default'}}, variables => {}); + for my $inhibitor (keys %inhibits_defaults) { + next unless exists $external{$inhibitor}; + delete $defaults{$_} for @{$inhibits_defaults{$inhibitor}}; + } + + return bless {%defaults, %external}, $package; + } ## end sub new + } + + sub process { + my ($self, $template, $vars) = @_; + return $self->evaluate($self->compile($template), $vars); + } + + sub evaluate { + my ($self, $compiled, $vars) = @_; + $self->_compile_sub($compiled) + unless exists $compiled->{sub}; + return $compiled->{sub}->($vars); + } ## end sub evaluate + + sub compile { ## no critic (RequireArgUnpacking) + my ($self, undef, %args) = @_; + my $outcome = $self->_compile_code_text($_[1]); + return $outcome if $args{no_check}; + return $self->_compile_sub($outcome); + } ## end sub compile + + sub compile_as_sub { ## no critic (RequireArgUnpacking) + my $self = shift; + return $self->compile($_[0])->{'sub'}; + } + + sub _compile_code_text { + my ($self, $template) = @_; + + my $starter = $self->{start}; + my $stopper = $self->{stop}; + + my $compiled = "# line 1 'input'\n"; + $compiled .= "use utf8;\n\n" if $self->{utf8}; + $compiled .= "P('');\n\n"; + my $pos = 0; + my $line_no = 1; + while ($pos < length $template) { + + # Find starter and emit all previous text as simple text + my $start = index $template, $starter, $pos; + last if $start < 0; + my $chunk = substr $template, $pos, $start - $pos; + $compiled .= _simple_text($chunk) + if $start > $pos; + + # Update scanning variables. The line counter is advanced for + # the chunk but not yet for the $starter, so that error reporting + # for unmatched $starter will point to the correct line + $pos = $start + length $starter; + $line_no += ($chunk =~ tr/\n//); + + # Grab code + my $stop = index $template, $stopper, $pos; + if ($stop < 0) { # no matching $stopper, bummer! + my $section = _extract_section({template => $template}, $line_no); + croak "unclosed starter '$starter' at line $line_no\n$section"; + } + my $code = substr $template, $pos, $stop - $pos; + + # Now I can advance the line count considering the $starter too + $line_no += ($starter =~ tr/\n//); + + if (length $code) { + if (my $path = crumble($code)) { + $compiled .= _variable($path); + } + elsif (my ($scalar) = + $code =~ m{\A\s* (\$ [[:alpha:]_]\w*) \s*\z}mxs) + { + $compiled .= + "\nP($scalar); ### straight scalar\n\n"; + } ## end elsif (my ($scalar) = $code...) + elsif (substr($code, 0, 1) eq q<=>) { + $compiled .= "\n# line $line_no 'template<3,$line_no>'\n" + . _expression(substr $code, 1); + } + else { + $compiled .= + "\n# line $line_no 'template<0,$line_no>'\n" . $code; + } + } ## end if (length $code) + + # Update scanning variables + $pos = $stop + length $stopper; + $line_no += (($code . $stopper) =~ tr/\n//); + + } ## end while ($pos < length $template) + + # put last part of input string as simple text + $compiled .= _simple_text(substr($template, $pos || 0)); + + return { + template => $template, + code_text => $compiled, + }; + } ## end sub _compile_code_text + + # The following function is long and complex because it deals with many + # different cases. It is kept as-is to avoid too many calls to other + # subroutines; for this reason, it's reasonably commented. + sub traverse { ## no critic (RequireArgUnpacking,ProhibitExcessComplexity) + + ## no critic (ProhibitDoubleSigils) + my $iref = ref($_[0]); + my $ref_wanted = ($iref eq 'SCALAR') || ($iref eq 'REF'); + my $ref_to_value = $ref_wanted ? shift : \shift; + + # early detection of options, remove them from args list + my $opts = (@_ && (ref($_[-1]) eq 'HASH')) ? pop(@_) : {}; + + # if there's not $path provided, just don't bother going on. Actually, + # no $path means just return root, undefined path is always "not + # present" though. + return ($ref_wanted ? $ref_to_value : $$ref_to_value) unless @_; + my $path_input = shift; + return ($ref_wanted ? undef : '') unless defined $path_input; + + my $crumbs; + if (ref $path_input) { + $crumbs = $path_input; + } + else { + return ($ref_wanted ? $ref_to_value : $$ref_to_value) + if defined($path_input) && !length($path_input); + $crumbs = crumble($path_input); + } + return ($ref_wanted ? undef : '') unless defined $crumbs; + + # go down the rabbit hole + my $use_method = $opts->{traverse_methods} || 0; + my ($strict_blessed, $method_pre) = (0, 0); + if ($use_method) { + $strict_blessed = $opts->{strict_blessed} || 0; + $method_pre = (! $strict_blessed && $opts->{method_over_key}) || 0; + } + for my $crumb (@$crumbs) { + + # $key is what we will look into $$ref_to_value. We don't use + # $crumb directly as we might change $key in the loop, and we + # don't want to spoil $crumbs + my $key = $crumb; + + # $ref tells me how to look down into $$ref_to_value, i.e. as + # an ARRAY or a HASH... or object + my $ref = reftype $$ref_to_value; + + # if $ref is not true, we hit a wall. How we proceed depends on + # whether we were asked to auto-vivify or not. + if (!$ref) { + return '' unless $ref_wanted; # don't bother going on + + # auto-vivification requested! $key will tell us how to + # proceed further, hopefully + $ref = ref $key; + } ## end if (!$ref) + + # if $key is a reference, it will tell us what's expected now + if (my $key_ref = ref $key) { + + # if $key_ref is not the same as $ref there is a mismatch + # between what's available ($ref) and what' expected ($key_ref) + return($ref_wanted ? undef : '') if $key_ref ne $ref; + + # OK, data and expectations agree. Get the "real" key + if ($key_ref eq 'ARRAY') { + $key = $crumb->[0]; # it's an array, key is (only) element + } + elsif ($key_ref eq 'HASH') { + ($key) = keys %$crumb; # hash... key is (only) key + } + } ## end if (my $key_ref = ref ...) + + # if $ref is still not true at this point, we're doing + # auto-vivification and we have a plain key. Some guessing + # will be needed! Plain non-negative integers resolve to ARRAY, + # otherwise we'll consider $key as a HASH key + $ref ||= ($key =~ m{\A (?: 0 | [1-9]\d*) \z}mxs) ? 'ARRAY' : 'HASH'; + + # time to actually do the next step + my $is_blessed = blessed $$ref_to_value; + my $method = $is_blessed && $$ref_to_value->can($key); + if ($is_blessed && $strict_blessed) { + return($ref_wanted ? undef : '') unless $method; + $ref_to_value = \($$ref_to_value->$method()); + } + elsif ($method && $method_pre) { + $ref_to_value = \($$ref_to_value->$method()); + } + elsif (($ref eq 'HASH') && exists($$ref_to_value->{$key})) { + $ref_to_value = \($$ref_to_value->{$key}); + } + elsif (($ref eq 'ARRAY') && exists($$ref_to_value->[$key])) { + $ref_to_value = \($$ref_to_value->[$key]); + } + elsif ($method && $use_method) { + $ref_to_value = \($$ref_to_value->$method()); + } + # autovivification goes here eventually + elsif ($ref eq 'HASH') { + $ref_to_value = \($$ref_to_value->{$key}); + } + elsif ($ref eq 'ARRAY') { + $ref_to_value = \($$ref_to_value->[$key]); + } + else { # don't know what to do with other references! + return $ref_wanted ? undef : ''; + } + } ## end for my $crumb (@$crumbs) + + # normalize output, substitute undef with '' unless $ref_wanted + return + $ref_wanted ? $ref_to_value + : defined($$ref_to_value) ? $$ref_to_value + : ''; + + ## use critic + } ## end sub traverse + + sub V { return '' } + sub A { return } + sub H { return } + sub HK { return } + sub HV { return } + + sub _compile_sub { + my ($self, $outcome) = @_; + + my @warnings; + { + my $utf8 = $self->{utf8} ? 1 : 0; + my $stdout = $self->{stdout} ? 1 : 0; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + my @code; + push @code, <<'END_OF_CODE'; + sub { + my %variables = %{$self->{variables}}; + my $V = \%variables; # generic kid, as before by default + + { + my $vars = shift || {}; + if (ref($vars) eq 'HASH') { # old case + %variables = (%variables, %$vars); + } + else { + $V = $vars; + %variables = (HASH => { %variables }, REF => $V); + } + } + + my $buffer = ''; # output variable + my $OFH; + END_OF_CODE + + my $handle = '$OFH'; + if ($stdout) { + $handle = 'STDOUT'; + push @code, <<'END_OF_CODE'; + local *STDOUT; + open STDOUT, '>', \$buffer or croak "open(): $OS_ERROR"; + $OFH = select(STDOUT); + END_OF_CODE + } + else { + push @code, <<'END_OF_CODE'; + open $OFH, '>', \$buffer or croak "open(): $OS_ERROR"; + END_OF_CODE + } + + push @code, "binmode $handle, ':encoding(utf8)';\n" + if $utf8; + push @code, "binmode $handle, '$self->{binmode}';\n" + if defined $self->{binmode}; + + # add functions that can be seen only within the compiled code + push @code, $self->_compile_code_localsubs($handle); + + push @code, <<'END_OF_CODE'; + { # double closure to free "my" variables + my ($buffer, $OFH); # hide external ones + END_OF_CODE + + # the real code! one additional scope indentation to ensure we + # can "my" variables again + push @code, + "{\n", # this enclusure allows using "my" again + $outcome->{code_text}, + "}\n}\n\n"; + + push @code, "select(\$OFH);\n" if $stdout; + push @code, "close $handle;\n\n"; + + if ($utf8) { + push @code, <<'END_OF_CODE'; + require Encode; + $buffer = Encode::decode(utf8 => $buffer); + + END_OF_CODE + } + + push @code, "return \$buffer;\n}\n"; + + my $code = join '', @code; + #print {*STDOUT} $code, "\n\n\n\n\n"; exit 0; + $outcome->{sub} = eval $code; ## no critic (ProhibitStringyEval) + return $outcome if $outcome->{sub}; + } + + my $error = $EVAL_ERROR; + my ($offset, $starter, $line_no) = + $error =~ m{at[ ]'template<(\d+),(\d+)>'[ ]line[ ](\d+)}mxs; + $line_no -= $offset; + s{at[ ]'template<\d+,\d+>'[ ]line[ ](\d+)} + {'at line ' . ($1 - $offset)}egmxs + for @warnings, $error; + if ($line_no == $starter) { + s{,[ ]near[ ]"[#][ ]line.*?\n\s+}{, near "}gmxs + for @warnings, $error; + } + + my $section = _extract_section($outcome, $line_no); + $error = join '', @warnings, $error, "\n", $section; + + croak $error; + } ## end sub _compile_sub + + sub _compile_code_localsubs { + my ($self, $handle) = @_; + my @code; + push @code, <<'END_OF_CODE'; + + no warnings 'redefine'; + + END_OF_CODE + + # custom functions to be injected + if (defined(my $custom = $self->{functions})) { + push @code, map { + " local *$_ = \$self->{functions}{$_};\n" + } keys %$custom; + } + + # input data structure traversing facility + push @code, <<'END_OF_CODE'; + + local *V = sub { + my $path = scalar(@_) ? shift : []; + my $input = scalar(@_) ? shift : $V; + return traverse($input, $path, $self); + }; + local *A = sub { + my $path = scalar(@_) ? shift : []; + my $input = scalar(@_) ? shift : $V; + return @{traverse($input, $path, $self) || []}; + }; + local *H = sub { + my $path = scalar(@_) ? shift : []; + my $input = scalar(@_) ? shift : $V; + return %{traverse($input, $path, $self) || {}}; + }; + local *HK = sub { + my $path = scalar(@_) ? shift : []; + my $input = scalar(@_) ? shift : $V; + return keys %{traverse($input, $path, $self) || {}}; + }; + local *HV = sub { + my $path = scalar(@_) ? shift : []; + my $input = scalar(@_) ? shift : $V; + return values %{traverse($input, $path, $self) || {}}; + }; + + END_OF_CODE + + # this comes separated because we need $handle + push @code, <<"END_OF_CODE"; + local *P = sub { return print $handle \@_; }; + + use warnings 'redefine'; + + END_OF_CODE + + return @code; + } + + sub _extract_section { + my ($hash, $line_no) = @_; + $line_no--; # for proper comparison with 0-based array + my $start = $line_no - ERROR_CONTEXT; + my $end = $line_no + ERROR_CONTEXT; + + my @lines = split /\n/mxs, $hash->{template}; + $start = 0 if $start < 0; + $end = $#lines if $end > $#lines; + my $n_chars = length($end + 1); + return join '', map { + sprintf "%s%${n_chars}d| %s\n", + (($_ == $line_no) ? '>>' : ' '), ($_ + 1), $lines[$_]; + } $start .. $end; + } ## end sub _extract_section + + sub _simple_text { + my $text = shift; + + return "P('$text');\n\n" if $text !~ /[\n'\\]/mxs; + + $text =~ s/^/ /gmxs; # indent, trick taken from diff -u + return <<"END_OF_CHUNK"; + ### Verbatim text + P(do { + my \$text = <<'END_OF_INDENTED_TEXT'; + $text + END_OF_INDENTED_TEXT + \$text =~ s/^ //gms; # de-indent + substr \$text, -1, 1, ''; # get rid of added newline + \$text; + }); + + END_OF_CHUNK + } ## end sub _simple_text + + sub crumble { + my ($input) = @_; + return unless defined $input; + + $input =~ s{\A\s+|\s+\z}{}gmxs; + return [] unless length $input; + + my $sq = qr{(?mxs: ' [^']* ' )}mxs; + my $dq = qr{(?mxs: " (?:[^\\"] | \\.)* " )}mxs; + my $ud = qr{(?mxs: \w+ )}mxs; + my $chunk = qr{(?mxs: $sq | $dq | $ud)+}mxs; + + # save and reset current pos() on $input + my $prepos = pos($input); + pos($input) = undef; + + my @path; + ## no critic (RegularExpressions::ProhibitCaptureWithoutTest) + push @path, $1 while $input =~ m{\G [.]? ($chunk) }cgmxs; + ## use critic + + # save and restore pos() on $input + my $postpos = pos($input); + pos($input) = $prepos; + + return unless defined $postpos; + return if $postpos != length($input); + + # cleanup @path components + for my $part (@path) { + my @subparts; + while ((pos($part) || 0) < length($part)) { + if ($part =~ m{\G ($sq) }cgmxs) { + push @subparts, substr $1, 1, length($1) - 2; + } + elsif ($part =~ m{\G ($dq) }cgmxs) { + my $subpart = substr $1, 1, length($1) - 2; + $subpart =~ s{\\(.)}{$1}gmxs; + push @subparts, $subpart; + } + elsif ($part =~ m{\G ($ud) }cgmxs) { + push @subparts, $1; + } + else { # shouldn't happen ever + return; + } + } ## end while ((pos($part) || 0) ...) + $part = join '', @subparts; + } ## end for my $part (@path) + + return \@path; + } ## end sub crumble + + sub _variable { + my $path = shift; + my $DQ = q<">; # double quotes + $path = join ', ', map { $DQ . quotemeta($_) . $DQ } @{$path}; + + return <<"END_OF_CHUNK"; + ### Variable from the stash (\$V) + P(V([$path])); + + END_OF_CHUNK + } ## end sub _variable + + sub _expression { + my $expression = shift; + return <<"END_OF_CHUNK"; + # Expression to be evaluated and printed out + { + my \$value = do {{ + $expression + }}; + P(\$value) if defined \$value; + } + + END_OF_CHUNK + + } ## end sub _expression + + 1; + +END_OF_FILE + + ); + + unshift @INC, sub { + my ($me, $packfile) = @_; + return unless exists $file_for{$packfile}; + (my $text = $file_for{$packfile}) =~ s/^\ //gmxs; + chop($text); # added \n at the end + open my $fh, '<', \$text or die "open(): $!\n"; + return $fh; + }; + + + our @__MOBUNDLE_MODULES__ = qw< + File::Slurp + Path::Class + Path::Class::Dir + Path::Class::Entity + Path::Class::File + Template::Perlish + >; + +} ## end BEGIN +# __MOBUNDLE_INCLUSION__ + +use File::Slurp (); +use Template::Perlish; +use Path::Class qw( foreign_file dir ); + +# Integrated logging facility +# use Log::Log4perl qw( :easy :no_extra_logdie_message ); +# Log::Log4perl->easy_init({level=>$INFO, layout=>'[%d %-5p] %m%n'}); + +my %config = (output => '-', 'modules-from' => [], include => []); +GetOptions( + \%config, + qw( + usage help man version + add-modules-list|L! + autoscan|scan|a! + autoscan-list|scan-list|modules-list|l! + body|b=s + body-from|script|program|B=s + head|h=s + head-from|H=s + head-from-body|S:i + head-from-paragraph|P! + include|I=s@ + modules|module|m=s@ + modules-from|M=s@ + output|o=s + standard-head|s! + unbundle|u! + ) +); +pod2usage(message => "$0 $VERSION", -verbose => 99, -sections => ' ') + if $config{version}; +pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage}; +pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS') + if $config{help}; +pod2usage(-verbose => 2) if $config{man}; + +# Manage unbundle before all the rest +if ($config{unbundle}) { + unbundle(@ARGV); + exit 0; +} + +# Various checks for input parameter consistence and overriding +pod2usage( + message => "head and standard-head are mutually exclusive", + -verbose => 99, + -sections => '' +) if exists($config{head}) && exists($config{'standard-head'}); +$config{head} = "#!/usr/bin/env perl\n" + if exists $config{'standard-head'}; + +pod2usage( + message => "(standard-)head and head-from are mutually exclusive", + -verbose => 99, + -sections => '' +) if exists($config{head}) && exists($config{'head-from'}); +$config{head} = read_file($config{'head-from'}) + if exists $config{'head-from'}; + +# Get body +if (@ARGV) { + pod2usage( + message => "body and bare parameter are mutually exclusive", + -verbose => 99, + -sections => '' + ) if exists $config{body}; + pod2usage( + message => "body-from and bare parameter are mutually exclusive", + -verbose => 99, + -sections => '' + ) if exists($config{'body-from'}); + pod2usage( + message => "only one bare command line parameter is allowed", + -verbose => 99, + -sections => '' + ) if @ARGV > 1; + $config{'body-from'} = shift @ARGV; +} +if (exists $config{'body-from'}) { + pod2usage( + message => "body and body-from are mutually exclusive", + -verbose => 99, + -sections => '' + ) if exists $config{body}; + $config{body} = read_file($config{'body-from'}) +} +pod2usage( + message => "one between body, body-from or bare parameter is needed", + -verbose => 99, + -sections => '' +) unless exists $config{body}; + + +if (exists $config{'head-from-body'}) { + pod2usage( + message => "multiple head sources are not allowed", + -verbose => 99, + -sections => '' + ) if exists($config{head}); + + my @body = split /\n/, $config{body}; + my @header = splice @body, 0, $config{'head-from-body'} || 1; + + $config{head} = join "\n", @header; + $config{body} = join "\n", @body; +} ## end if (exists $config{'head-from-body'... + +if (exists $config{'head-from-paragraph'}) { + pod2usage( + message => "multiple head sources are not allowed", + -verbose => 99, + -sections => '' + ) if exists($config{head}); + + ($config{head}, $config{body}) = split /\n\s*?\n/, $config{body}, 2; +} + +push @INC, @{$config{include}}; + +for my $file (@{$config{'modules-from'}}) { + chomp(my @modules = read_file($file)); + push @{$config{modules}}, @modules; +} + +# Load files for explicitly requested modules +my %modules = map { + (my $filename = $_) =~ s{::}{/}g; + $filename .= '.pm' unless $filename =~ /\./mxs; + $filename => get_module_contents($filename); +} @{$config{modules}}; + +# Now autoscan if requested. Already-loaded modules will be skipped +if ($config{autoscan} || $config{'autoscan-list'}) { + require Module::ScanDeps; + require File::Temp; + require Config; + + my $fh = File::Temp->new(UNLINK => 1, SUFFIX => '.pl'); + binmode $fh; + print {$fh} $config{body}; + $fh->close(); + + my @filenames = $fh->filename(); + my %flag_for; + while (@filenames) { + my $filename = shift @filenames; + next if $flag_for{$filename}++; + my $deps_for = + Module::ScanDeps::scan_deps(files => [$filename], skip => {%modules}); + + my $priv = dir($Config::Config{privlib}); + my $arch = dir($Config::Config{archlib}); + while (my ($key, $mod) = each %$deps_for) { + next if exists $modules{$key}; + + # Restrict to modules... + next unless $mod->{type} eq 'module'; + + my $privPath = $priv->file($key)->as_foreign('Unix'); + my $archPath = $arch->file($key)->as_foreign('Unix'); + next if $mod->{file} eq $privPath || $mod->{file} eq $archPath; + + $modules{$key} = read_file($mod->{file}); + push @filenames, $mod->{file}; + } ## end while (my ($key, $mod) = ... + } + + if ($config{'autoscan-list'}) { + for my $path (sort keys %modules) { + (my $name = $path) =~ s/\.pm$//; + $name =~ s{/}{::}g; + print "$name\n"; + } + exit 0; + } +} ## end if ($config{autoscan}) + +$config{modules} = \%modules; + +my $template = <<'END_OF_TEMPLATE'; +[% head %] + +# __MOBUNDLE_INCLUSION__ +BEGIN { + my %file_for = ( +[% while (my ($filename, $contents) = each %{$variables{modules}}) { %] + '[%= $filename %]' => <<'END_OF_FILE', +[%= $contents =~ s/^/ /gmxs; $contents; %] +END_OF_FILE +[% } %] + ); + + unshift @INC, sub { + my ($me, $packfile) = @_; + return unless exists $file_for{$packfile}; + (my $text = $file_for{$packfile}) =~ s/^\ //gmxs; + chop($text); # added \n at the end + open my $fh, '<', \$text or die "open(): $!\n"; + return $fh; + }; + +[% if ($variables{'add-modules-list'}) { %] + our @__MOBUNDLE_MODULES__ = qw< +[% for my $path (sort {$a cmp $b} %{$variables{modules}}) { + (my $name = $path) =~ s{\.pm$}{}mxs or next; + $name =~ s{/}{::}gmxs; +%] [%= $name %] +[% } +%] >; +[% } %] +} ## end BEGIN +# __MOBUNDLE_INCLUSION__ + +[% body %] +END_OF_TEMPLATE + +write_file($config{output}, + Template::Perlish->new()->process($template, \%config)); + +sub read_file { + File::Slurp::read_file $_[0] eq '-' ? \*STDIN : $_[0]; +} + +sub write_file { + my $f = shift; + File::Slurp::write_file(($f eq '-' ? \*STDOUT : $f), @_); +} + +sub get_module_contents { + my ($filename) = @_; + for my $item (@INC) { + my $full_path = + foreign_file('Unix', $item . '/' . $filename)->stringify(); + next unless -e $full_path; + return scalar read_file $full_path; + } ## end for my $item (@INC) + carp "could not find module file: '$filename'"; +} ## end sub get_module_contents + +sub unbundle { + BUNDLED: + for my $bundled (@_) { + my $modules = read_modules($bundled); + while (my ($filename, $contents) = each %$modules) { + save_file($filename, $contents); + } + } +} + +sub save_file { + my ($path, $contents) = @_; + my $output = $config{output} ne '-' ? $config{output} : 'lib'; + my $upath = foreign_file(Unix => "$output/$path"); + $upath->dir()->mkpath(); + write_file($upath->openw(), $contents); +} + +sub read_modules { + my ($bundled) = @_; + + open my $fh, '<', $bundled + or die "open('$bundled'): $OS_ERROR"; + + # read __MOBUNDLE_INCLUSION__ section + my @lines; + 1 while scalar(<$fh>) !~ m{^\#\ __MOBUNDLE_INCLUSION__$}mxs; + while (<$fh>) { + last if m{^\#\ __MOBUNDLE_INCLUSION__$}mxs; + push @lines, $_; + } + if (!@lines) { + warn "nothing in $bundled\n"; + next BUNDLED; + } + + 1 while shift(@lines) !~ m{^\s*my \s* \%file_for}mxs; + unshift @lines, '('; + 1 while pop(@lines) !~ m{^\s*unshift \s* \@INC}mxs; + my $definition = join '', @lines; + + my %file_for = eval $definition; + return %file_for if wantarray(); + return \%file_for; +} + +__END__ + +=head1 NAME + +mobundle - bundle modules inside your scripts + +=head1 VERSION + +Ask the version number to the script itself, calling: + + shell$ mobundle --version + +=head1 USAGE + + mobundle [--usage] [--help] [--man] [--version] + + mobundle [--autoscan|--scan|-a] + [--autoscan-list|--scan-list|--modules-list|-l] + [--body|-b ] + [--body-from|--script|--program|-B ] + [--head|-h ] [--head-from|-H ] + [--head-from-body|-S ] + [--head-from-paragraph|-P] + [--include|-I ] + [--module|-m ] + [--modules-from|-M ] + [--output|-o ] + [--standard-head|-s] + [--unbundle|-u] + +=head1 EXAMPLES + + # the one I always look for + shell$ mobundle -LPo bundled.pl -m Mod::One -m Mod::Two script.pl + + # other useful examples + shell$ mobundle -m Template::Perlish yourscript.pl + + shell$ mobundle -m Template::Perlish --head '#!/path/to/perl' script.pl + + shell$ mobundle -m Acme::Laugh --head-from-paragraph laugh.pl + + # This lists all the modules that mobundle would include with + # --autoscan|--scan|-a. Save it, trim it and you're done! + shell$ mobundle --autoscan-list laugh.pl + + # If you want to bundle some module that is local to your project + shell$ mobundle -I ./lib -m My::Module ./bin/script.pl + + # If you have a recently-bundled file you can easily extract modules + shell% mobundle -u bundled-program.pl -o mylib + +=head1 DESCRIPTION + +C lets you bundle Perl modules inside your Perl script, in order +to ship a single script instead of N separate files. + +The underlying logic is simple: all modules are included in the generated +script, and the module loading mechanism is tweaked in order to let you +load the bundled modules. See the documentation for L +to understand how. + +The generated script will be compound of three main parts: a C, +a section with the bundled modules and the logic to load them, and +a C. Briefly speaking: + +=over + +=item B + +this is where you should put your shabang and the Cs that you would +like to happen before the module loading mechanism is tweaked. + +The C is guaranteed to start at the very first octet in the result, +so you can put a shabang. + +=item B + +this part is generated automatically based on your instructions about which +modules should be bundled. + +=item B + +this is the body of your script, i.e. what your script is supposed to do. +It will likely contain either Cs or Cs that need the modules +that are bundled in the C section. + +=back + +If you have a bundled script, apart from doing it yourself you can also +unbundle it, see C<< --unbundle | -u >> below. + +=head2 Why Another? Use PAR! + +L is fantastic: lets you bundle all the needed components of your +application inside a single executable, and ship it. But... there's a +niche that it's not able to cover, at least looking at the documentation. + +In particular, there seem to be two different operation modes, depending +on your needs + +=over + +=item * + +either you're willing to bundle the interpreter as well, in which case +L (or, better, L) will generate a super-executable bundling all +necessary stuff + +=item * + +or you have to be sure that L is installed in the target directory. + +=back + +My need was somewhere in between: on the one side I wasn't willing to bundle +the interpreter, on the other I couldn't ensure that L was available. + +In particular, this kind of need arises every time that my programs only need +Pure-Perl modules, that do not need any platform-specific installation +process. In this case, bundling the interpreter means restricting the +applicability to one (or more, at some cost) platform only; the other way +is simply not acceptable in some environments. + + +=head1 OPTIONS + +=over + +=item --add-modules-list | -L + +adds a list of the modules that have been embedded in package variable +C<@__MOBUNDLE_MODULES__>. This list can then be read, e.g.: + + { + our @__MOBUNDLE_MODULES__; + print "have module <$_>\n" for @__MOBUNDLE_MODULES__; + } + +=item --autoscan | -scan | -a + +tries to use L to find non-core modules that might be +needed. Note that this is not PAR, so you should be careful of what is +taken in. + +For example, L can operate without L, but +L will bring it in together with a lot of stuff. + +=item --autoscan-list | --scan-list | --modules-list | -l + +print out the list of modules that would be included by L. + +=item --body | -b + +turn your one-liner in a self contained script! Just pass the C of your +script and you're done. + +=item --body-from | -B + +get the body of the target script from the given filename. + +=item --head | -h + +the C is the part that will be put at the very beginning of the +resulting script. Can be useful to specify a shabang. + +=item --head-from | -H + +get the C from the given filename. See L. + +=item --head-from-body | -S + +get the C taking it from the first C lines of the body. See +L and L. + +=item --head-from-paragraph | -P + +get the C from the very first paragraph in the C. See +L and L. + +=item --help + +print a somewhat more verbose help, showing usage, this description of +the options and some examples from the synopsis. + +=item --include | -I + +add C to @INC, which is also the directory used to look for +modules' sources. + +=item --man + +print out the full documentation for the script. + +=item --module | -m + +include the given module in the final script. You can specify this option +multiple times for multiple modules. + +When used with L, these modules are skipped during the scan. + +=item --modules-from | -M + +get a list of modules to bundle from the given filename. + +=item --output | -o + +set a filename for output, instead of standard output. When C<-> is given, +standard output is assumed. + +When used with C<< --unbundle | -u >>, it is the name of the base output +directory where modules will be written. + +=item --standard-head | -s + +put a standard header at the beginning of the generated script, i.e.: + + #!/usr/bin/env perl + +=item --unbundle | -u + +unbundle an already-bundled script. In this case, the C<--output|-o> +option is considered a directory; if not specified, the C directory +is used (and created if needed). + +Unbundling assumes that the bundled script was produced with a fairly recent +version of I; in particular, it is important that the +C<__MOBUNDLE_INCLUSION__> comments are present. + +=item --usage + +print a concise usage line and exit. You can specify this option +multiple times for multiple modules. + +=item --version + +print the version of the script. + +=back + +=head1 CONFIGURATION AND ENVIRONMENT + +mobundle requires no configuration files or environment variables. + +=head1 DEPENDENCIES + +Non-core modules needed: + +=over + +=item B<< File::Slurp >> + +=item B<< Template::Perlish >> + +=item B<< Path::Class >> + +=item B<< Module::ScanDeps >> + +but only if you want to use the L option. + +=back + +Did you say that I should I them?!? + +=head1 BUGS AND LIMITATIONS + +No bugs have been reported. + +Please report any bugs or feature requests through http://rt.cpan.org/ + +Undoubtfully there are many bugs, and more limitations. + +=head1 AUTHOR + +Flavio Poletti C + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2008-2011, 2023 by Flavio Poletti C. + +Up to version 0.1.1 this program was licensed under the terms of the +Artistic License 2.0. + +Since version 0.1.2 on, this program is licensed under the Apache License, +Version 2.0 (the "License"); you may not use this file except in compliance +with the License. You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +If this is a bundled version of the program, the following subsections +apply to the embedded modules. + +=head2 Copyright for C + +Copyright (c) 2003 Uri Guttman. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head2 Copyright for C + +Copyright (c) Ken Williams. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head2 Copyright for C + +Copyright (c) 2008-2016 by Flavio Poletti polettix@cpan.org. + +This module is free software. You can redistribute it and/or modify it under +the terms of the Artistic License 2.0. + +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. + +=cut + diff --git a/quine.sh b/quine.sh new file mode 100755 index 0000000..2bcca4a --- /dev/null +++ b/quine.sh @@ -0,0 +1,11 @@ +#!/bin/sh +md="$(dirname "$(readlink -f "$0")")" +PERL5LIB="$md/local/lib/perl5" "$md/mobundle" -LPo "$md/bundle/mobundle" \ + -m Path::Class::Entity \ + -m Path::Class::File \ + -m Path::Class::Dir \ + -m Path::Class \ + -m File::Slurp \ + -m Template::Perlish \ + "$md/mobundle" +chmod +x "$md/bundle/mobundle" -- 2.11.4.GIT