X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=modules%2Ffallback%2FFile%2FSlurp.pm;fp=modules%2Ffallback%2FFile%2FSlurp.pm;h=0000000000000000000000000000000000000000;hb=53593baa211863fbf66540cf1bcc36c8fb37257f;hp=0aad7ed46a57916df4a794f1b696130b500881a6;hpb=deb4d2dbb676d7d6f69dfe7815d6e0cb09bd4a44;p=kivitendo-erp.git diff --git a/modules/fallback/File/Slurp.pm b/modules/fallback/File/Slurp.pm deleted file mode 100644 index 0aad7ed46..000000000 --- a/modules/fallback/File/Slurp.pm +++ /dev/null @@ -1,742 +0,0 @@ -package File::Slurp; - -use strict; - -use Carp ; -use POSIX qw( :fcntl_h ) ; -use Fcntl qw( :DEFAULT ) ; -use Symbol ; - -my $is_win32 = $^O =~ /win32/i ; - -# Install subs for various constants that aren't set in older perls -# (< 5.005). Fcntl on old perls uses Exporter to define subs without a -# () prototype These can't be overridden with the constant pragma or -# we get a prototype mismatch. Hence this less than aesthetically -# appealing BEGIN block: - -BEGIN { - unless( eval { defined SEEK_SET() } ) { - *SEEK_SET = sub { 0 }; - *SEEK_CUR = sub { 1 }; - *SEEK_END = sub { 2 }; - } - - unless( eval { defined O_BINARY() } ) { - *O_BINARY = sub { 0 }; - *O_RDONLY = sub { 0 }; - *O_WRONLY = sub { 1 }; - } - - unless ( eval { defined O_APPEND() } ) { - - if ( $^O =~ /olaris/ ) { - *O_APPEND = sub { 8 }; - *O_CREAT = sub { 256 }; - *O_EXCL = sub { 1024 }; - } - elsif ( $^O =~ /inux/ ) { - *O_APPEND = sub { 1024 }; - *O_CREAT = sub { 64 }; - *O_EXCL = sub { 128 }; - } - elsif ( $^O =~ /BSD/i ) { - *O_APPEND = sub { 8 }; - *O_CREAT = sub { 512 }; - *O_EXCL = sub { 2048 }; - } - } -} - -# print "OS [$^O]\n" ; - -# print "O_BINARY = ", O_BINARY(), "\n" ; -# print "O_RDONLY = ", O_RDONLY(), "\n" ; -# print "O_WRONLY = ", O_WRONLY(), "\n" ; -# print "O_APPEND = ", O_APPEND(), "\n" ; -# print "O_CREAT ", O_CREAT(), "\n" ; -# print "O_EXCL ", O_EXCL(), "\n" ; - -use base 'Exporter' ; -use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ; - -%EXPORT_TAGS = ( 'all' => [ - qw( read_file write_file overwrite_file append_file read_dir ) ] ) ; - -@EXPORT = ( @{ $EXPORT_TAGS{'all'} } ); -@EXPORT_OK = qw( slurp ) ; - -$VERSION = '9999.13'; - -*slurp = \&read_file ; - -sub read_file { - - my( $file_name, %args ) = @_ ; - -# set the buffer to either the passed in one or ours and init it to the null -# string - - my $buf ; - my $buf_ref = $args{'buf_ref'} || \$buf ; - ${$buf_ref} = '' ; - - my( $read_fh, $size_left, $blk_size ) ; - -# check if we are reading from a handle (glob ref or IO:: object) - - if ( ref $file_name ) { - -# slurping a handle so use it and don't open anything. -# set the block size so we know it is a handle and read that amount - - $read_fh = $file_name ; - $blk_size = $args{'blk_size'} || 1024 * 1024 ; - $size_left = $blk_size ; - -# 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 ( $@ ) { - - @_ = ( \%args, <IO->IoFLAGS & 16 ) { - -# set the seek position to the current tell. - - sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) || - croak "sysseek $!" ; - } - } - else { - -# a regular file. set the sysopen mode - - my $mode = O_RDONLY ; - -#printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ; - -# open the file and handle any error - - $read_fh = gensym ; - unless ( sysopen( $read_fh, $file_name, $mode ) ) { - @_ = ( \%args, "read_file '$file_name' - sysopen: $!"); - goto &_error ; - } - - binmode($read_fh, $args{'binmode'}) if $args{'binmode'}; - -# get the size of the file for use in the read loop - - $size_left = -s $read_fh ; - - unless( $size_left ) { - - $blk_size = $args{'blk_size'} || 1024 * 1024 ; - $size_left = $blk_size ; - } - } - -# infinite read loop. we exit when we are done slurping - - while( 1 ) { - -# do the read and see how much we got - - my $read_cnt = sysread( $read_fh, ${$buf_ref}, - $size_left, length ${$buf_ref} ) ; - - if ( defined $read_cnt ) { - -# good read. see if we hit EOF (nothing left to read) - - last if $read_cnt == 0 ; - -# loop if we are slurping a handle. we don't track $size_left then. - - next if $blk_size ; - -# count down how much we read and loop if we have more to read. - $size_left -= $read_cnt ; - last if $size_left <= 0 ; - next ; - } - -# handle the read error - - @_ = ( \%args, "read_file '$file_name' - sysread: $!"); - goto &_error ; - } - -# fix up cr/lf to be a newline if this is a windows text file - - ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ; - -# this is the 5 returns in a row. each handles one possible -# combination of caller context and requested return type - - my $sep = $/ ; - $sep = '\n\n+' if defined $sep && $sep eq '' ; - -# caller wants to get an array ref of lines - -# this split doesn't work since it tries to use variable length lookbehind -# the m// line works. -# return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'} ; - return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ] - if $args{'array_ref'} ; - -# caller wants a list of lines (normal list context) - -# same problem with this split as before. -# return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ; - return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () - if wantarray ; - -# caller wants a scalar ref to the slurped text - - return $buf_ref if $args{'scalar_ref'} ; - -# caller wants a scalar with the slurped text (normal scalar context) - - return ${$buf_ref} if defined wantarray ; - -# caller passed in an i/o buffer by reference (normal void context) - - return ; -} - -sub write_file { - - my $file_name = shift ; - -# get the optional argument hash ref from @_ or an empty hash ref. - - my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ; - - my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ; - -# get the buffer ref - it depends on how the data is passed into write_file -# after this if/else $buf_ref will have a scalar ref to the data. - - if ( ref $args->{'buf_ref'} eq 'SCALAR' ) { - -# a scalar ref passed in %args has the data -# note that the data was passed by ref - - $buf_ref = $args->{'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 '', @_ ; - } - -# see if we were passed a open handle to spew to. - - if ( ref $file_name ) { - -# we have a handle. make sure we don't call truncate on it. - - $write_fh = $file_name ; - $no_truncate = 1 ; - } - else { - -# spew to regular file. - - if ( $args->{'atomic'} ) { - -# in atomic mode, we spew to a temp file so make one and save the original -# file name. - $orig_file_name = $file_name ; - $file_name .= ".$$" ; - } - -# set the mode for the sysopen - - my $mode = O_WRONLY | O_CREAT ; - $mode |= O_APPEND if $args->{'append'} ; - $mode |= O_EXCL if $args->{'no_clobber'} ; - -#printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ; - -# open the file and handle any error. - - $write_fh = gensym ; - unless ( sysopen( $write_fh, $file_name, $mode ) ) { - @_ = ( $args, "write_file '$file_name' - sysopen: $!"); - goto &_error ; - } - - binmode($write_fh, $args->{'binmode'}) if $args->{'binmode'}; - } - - sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ; - - -#print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ; - -# fix up newline to write cr/lf if this is a windows text file - - if ( $is_win32 && !$args->{'binmode'} ) { - -# copy the write data if it was passed by ref so we don't clobber the -# caller's data - $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ; - ${$buf_ref} =~ s/\n/\015\012/g ; - } - -#print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ; - -# get the size of how much we are writing and init the offset into that buffer - - my $size_left = length( ${$buf_ref} ) ; - my $offset = 0 ; - -# loop until we have no more data left to write - - do { - -# do the write and track how much we just wrote - - my $write_cnt = syswrite( $write_fh, ${$buf_ref}, - $size_left, $offset ) ; - - unless ( defined $write_cnt ) { - -# the write failed - @_ = ( $args, "write_file '$file_name' - syswrite: $!"); - goto &_error ; - } - -# track much left to write and where to write from in the buffer - - $size_left -= $write_cnt ; - $offset += $write_cnt ; - - } while( $size_left > 0 ) ; - -# we truncate regular files in case we overwrite a long file with a shorter file -# so seek to the current position to get it (same as tell()). - - truncate( $write_fh, - sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ; - - close( $write_fh ) ; - -# handle the atomic mode - move the temp file to the original filename. - - rename( $file_name, $orig_file_name ) if $args->{'atomic'} ; - - 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 args hash ref - my $args = $_[1] ; - if ( ref $args eq 'HASH' ) { - -# we were passed an args ref so just mark the append mode - - $args->{append} = 1 ; - } - else { - -# no args 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 -} - -# basic wrapper around opendir/readdir - -sub read_dir { - - my ($dir, %args ) = @_; - -# this handle will be destroyed upon return - - local(*DIRH); - -# open the dir and handle any errors - - unless ( opendir( DIRH, $dir ) ) { - - @_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ; - goto &_error ; - } - - my @dir_entries = readdir(DIRH) ; - - @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries ) - unless $args{'keep_dot_dot'} ; - - 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( $args, $err_msg ) = @_ ; - -# get the error function to use - - my $func = $err_func{ $args->{'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) ; - -# 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 - Efficient Reading/Writing of Complete Files - -=head1 SYNOPSIS - - use File::Slurp; - - my $text = read_file( 'filename' ) ; - my @lines = read_file( 'filename' ) ; - - write_file( 'filename', @lines ) ; - - use File::Slurp qw( slurp ) ; - - my $text = slurp( 'filename' ) ; - - -=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 other than C<.> and C<..> - -These slurp/spew subs work for files, pipes and -sockets, and stdio, pseudo-files, and DATA. - -=head2 B - -This sub reads in an entire file and returns its contents to the -caller. In list context it will return a list of lines (using the -current value of $/ as the separator including support for paragraph -mode when it is set to ''). In scalar context it returns the entire -file as a single scalar. - - my $text = read_file( 'filename' ) ; - my @lines = read_file( 'filename' ) ; - -The first argument to C is the filename and the rest of the -arguments are key/value pairs which are optional and which modify the -behavior of the call. Other than binmode the options all control how -the slurped file is returned to the caller. - -If the first argument is a file handle reference or I/O object (if ref -is true), then that handle is slurped in. This mode is supported so -you slurp handles such as C, C. See the test handle.t -for an example that does C and child process spews data -to the parant which slurps it in. All of the options that control how -the data is returned to the caller still work in this case. - -NOTE: as of version 9999.06, read_file works correctly on the C -handle. It used to need a sysseek workaround but that is now handled -when needed by the module itself. - -You can optionally request that C is exported to your code. This -is an alias for read_file and is meant to be forward compatible with -Perl 6 (which will have slurp() built-in). - -The options are: - -=head3 binmode - -If you set the binmode option, then the file will be slurped in binary -mode. - - my $bin_data = read_file( $bin_file, binmode => ':raw' ) ; - # Or - my $bin_data = read_file( $bin_file, binmode => ':utf8' ) ; - -=head3 array_ref - -If this boolean option is set, the return value (only in scalar -context) will be an array reference which contains the lines of the -slurped file. The following two calls are equivalent: - - my $lines_ref = read_file( $bin_file, array_ref => 1 ) ; - my $lines_ref = [ read_file( $bin_file ) ] ; - -=head3 scalar_ref - -If this boolean option is set, the return value (only in scalar -context) will be an scalar reference to a string which is the contents -of the slurped file. This will usually be faster than returning the -plain scalar. - - my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ; - -=head3 buf_ref - -You can use this option to pass in a scalar reference and the slurped -file contents will be stored in the scalar. This can be used in -conjunction with any of the other options. - - my $text_ref = read_file( $bin_file, buf_ref => \$buffer, - array_ref => 1 ) ; - my @lines = read_file( $bin_file, buf_ref => \$buffer ) ; - -=head3 blk_size - -You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB. - - my $text_ref = read_file( $bin_file, blk_size => 10_000_000, - array_ref => 1 ) ; - -=head3 err_mode - -You can use this option to control how read_file behaves when an error -occurs. This option defaults to 'croak'. You can set it to 'carp' or -to 'quiet to have no error handling. This code wants to carp and then -read abother file if it fails. - - my $text_ref = read_file( $file, err_mode => 'carp' ) ; - unless ( $text_ref ) { - - # read a different file but croak if not found - $text_ref = read_file( $another_file ) ; - } - - # process ${$text_ref} - -=head2 B - -This sub writes out an entire file in one call. - - write_file( 'filename', @data ) ; - -The first argument to C is the filename. The next argument -is an optional hash reference and it contains key/values that can -modify the behavior of C. The rest of the argument list is -the data to be written to the file. - - write_file( 'filename', {append => 1 }, @data ) ; - write_file( 'filename', {binmode => ':raw' }, $buffer ) ; - -As a shortcut if the first data argument is a scalar or array -reference, it is used as the only data to be written to the file. Any -following arguments in @_ are ignored. This is a faster way to pass in -the output to be written to the file and is equivilent to the -C option. These following pairs are equivilent but the pass -by reference call will be faster in most cases (especially with larger -files). - - write_file( 'filename', \$buffer ) ; - write_file( 'filename', $buffer ) ; - - write_file( 'filename', \@lines ) ; - write_file( 'filename', @lines ) ; - -If the first argument is a file handle reference or I/O object (if ref -is true), then that handle is slurped in. This mode is supported so -you spew to handles such as \*STDOUT. See the test handle.t for an -example that does C and child process spews data to the -parant which slurps it in. All of the options that control how the -data is passes into C still work in this case. - -C returns 1 upon successfully writing the file or undef if -it encountered an error. - -The options are: - -=head3 binmode - -If you set the binmode option, then the file will be written in binary -mode. - - write_file( $bin_file, {binmode => ':raw'}, @data ) ; - # Or - write_file( $bin_file, {binmode => ':utf8'}, @data ) ; - -=head3 buf_ref - -You can use this option 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 @_ will be ignored. These are -equivilent: - - write_file( $bin_file, { buf_ref => \$buffer } ) ; - write_file( $bin_file, \$buffer ) ; - write_file( $bin_file, $buffer ) ; - -=head3 atomic - -If you set this boolean option, the file will be written to in an -atomic fashion. A temporary file name is created by appending the pid -($$) to the file name argument and that file is spewed to. After the -file is closed it is renamed to the original file name (and rename is -an atomic operation on most OS's). If the program using this were to -crash in the middle of this, then the file with the pid suffix could -be left behind. - -=head3 append - -If you set this boolean option, the data will be written at the end of -the current file. - - write_file( $file, {append => 1}, @data ) ; - -C croaks if it cannot open the file. It returns true if it -succeeded in writing out the file and undef if there was an -error. (Yes, I know if it croaks it can't return anything but that is -for when I add the options to select the error handling mode). - -=head3 no_clobber - -If you set this boolean option, an existing file will not be overwritten. - - write_file( $file, {no_clobber => 1}, @data ) ; - -=head3 err_mode - -You can use this option to control how C behaves when an -error occurs. This option defaults to 'croak'. You can set it to -'carp' or to 'quiet' to have no error handling other than the return -value. If the first call to C fails it will carp and then -write to another file. If the second call to C fails, it -will croak. - - unless ( write_file( $file, { err_mode => 'carp', \$data ) ; - - # write a different file but croak if not found - write_file( $other_file, \$data ) ; - } - -=head2 overwrite_file - -This sub is just a typeglob alias to write_file since write_file -always overwrites an existing file. This sub is supported for -backwards compatibility with the original version of this module. See -write_file for its API and behavior. - -=head2 append_file - -This sub will write its data to the end of the file. It is a wrapper -around write_file and it has the same API so see that for the full -documentation. These calls are equivilent: - - append_file( $file, @data ) ; - write_file( $file, {append => 1}, @data ) ; - -=head2 read_dir - -This sub reads all the file names from directory and returns them to -the caller but C<.> and C<..> are removed by default. - - my @files = read_dir( '/path/to/dir' ) ; - -It croaks if it cannot open the directory. - -In a list context C returns a list of the entries in the -directory. In a scalar context it returns an array reference which has -the entries. - -=head3 keep_dot_dot - -If this boolean option is set, C<.> and C<..> are not removed from the -list of files. - - my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ; - -=head2 EXPORT - - read_file write_file overwrite_file append_file read_dir - -=head2 SEE ALSO - -An article on file slurping in extras/slurp_article.pod. There is -also a benchmarking script in extras/slurp_bench.pl. - -=head2 BUGS - -If run under Perl 5.004, slurping from the DATA handle will fail as -that requires B.pm which didn't get into core until 5.005. - -=head1 AUTHOR - -Uri Guttman, Euri@stemsystems.comE - -=cut