+++ /dev/null
-package FileSlurp_12;
-
-use strict;
-
-use Carp ;
-use Fcntl qw( :DEFAULT ) ;
-use POSIX qw( :fcntl_h ) ;
-use Symbol ;
-
-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';
-
-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" ;
-
-
-*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, <<ERR ) ;
-Can't find B.pm with this Perl: $!.
-That module is needed to slurp the DATA handle.
-ERR
- goto &_error ;
- }
-
- if ( B::svref_2object( $read_fh )->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 ;
- $mode |= O_BINARY if $args{'binmode'} ;
-
-#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 ;
- }
-
-# 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 ;
-}
-
-
-# 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;
projects / urisagit/Perl-Docs.git / blobdiff