6 use Fcntl qw( :DEFAULT ) ;
7 use POSIX qw( :fcntl_h ) ;
11 use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
13 %EXPORT_TAGS = ( 'all' => [
14 qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
16 @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
17 @EXPORT_OK = qw( slurp ) ;
21 my $is_win32 = $^O =~ /win32/i ;
23 # Install subs for various constants that aren't set in older perls
24 # (< 5.005). Fcntl on old perls uses Exporter to define subs without a
25 # () prototype These can't be overridden with the constant pragma or
26 # we get a prototype mismatch. Hence this less than aesthetically
27 # appealing BEGIN block:
30 unless( eval { defined SEEK_SET() } ) {
31 *SEEK_SET = sub { 0 };
32 *SEEK_CUR = sub { 1 };
33 *SEEK_END = sub { 2 };
36 unless( eval { defined O_BINARY() } ) {
37 *O_BINARY = sub { 0 };
38 *O_RDONLY = sub { 0 };
39 *O_WRONLY = sub { 1 };
42 unless ( eval { defined O_APPEND() } ) {
44 if ( $^O =~ /olaris/ ) {
45 *O_APPEND = sub { 8 };
46 *O_CREAT = sub { 256 };
47 *O_EXCL = sub { 1024 };
49 elsif ( $^O =~ /inux/ ) {
50 *O_APPEND = sub { 1024 };
51 *O_CREAT = sub { 64 };
52 *O_EXCL = sub { 128 };
54 elsif ( $^O =~ /BSD/i ) {
55 *O_APPEND = sub { 8 };
56 *O_CREAT = sub { 512 };
57 *O_EXCL = sub { 2048 };
62 # print "OS [$^O]\n" ;
64 # print "O_BINARY = ", O_BINARY(), "\n" ;
65 # print "O_RDONLY = ", O_RDONLY(), "\n" ;
66 # print "O_WRONLY = ", O_WRONLY(), "\n" ;
67 # print "O_APPEND = ", O_APPEND(), "\n" ;
68 # print "O_CREAT ", O_CREAT(), "\n" ;
69 # print "O_EXCL ", O_EXCL(), "\n" ;
72 *slurp = \&read_file ;
76 my( $file_name, %args ) = @_ ;
78 # set the buffer to either the passed in one or ours and init it to the null
82 my $buf_ref = $args{'buf_ref'} || \$buf ;
85 my( $read_fh, $size_left, $blk_size ) ;
87 # check if we are reading from a handle (glob ref or IO:: object)
89 if ( ref $file_name ) {
91 # slurping a handle so use it and don't open anything.
92 # set the block size so we know it is a handle and read that amount
94 $read_fh = $file_name ;
95 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
96 $size_left = $blk_size ;
98 # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
99 # glob/handle. only the DATA handle is untainted (since it is from
100 # trusted data in the source file). this allows us to test if this is
101 # the DATA handle and then to do a sysseek to make sure it gets
102 # slurped correctly. on some systems, the buffered i/o pointer is not
103 # left at the same place as the fd pointer. this sysseek makes them
104 # the same so slurping with sysread will work.
110 @_ = ( \%args, <<ERR ) ;
111 Can't find B.pm with this Perl: $!.
112 That module is needed to slurp the DATA handle.
117 if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
119 # set the seek position to the current tell.
121 sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
127 # a regular file. set the sysopen mode
129 my $mode = O_RDONLY ;
130 $mode |= O_BINARY if $args{'binmode'} ;
132 #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
134 # open the file and handle any error
137 unless ( sysopen( $read_fh, $file_name, $mode ) ) {
138 @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
142 # get the size of the file for use in the read loop
144 $size_left = -s $read_fh ;
146 unless( $size_left ) {
148 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
149 $size_left = $blk_size ;
153 # infinite read loop. we exit when we are done slurping
157 # do the read and see how much we got
159 my $read_cnt = sysread( $read_fh, ${$buf_ref},
160 $size_left, length ${$buf_ref} ) ;
162 if ( defined $read_cnt ) {
164 # good read. see if we hit EOF (nothing left to read)
166 last if $read_cnt == 0 ;
168 # loop if we are slurping a handle. we don't track $size_left then.
172 # count down how much we read and loop if we have more to read.
173 $size_left -= $read_cnt ;
174 last if $size_left <= 0 ;
178 # handle the read error
180 @_ = ( \%args, "read_file '$file_name' - sysread: $!");
184 # fix up cr/lf to be a newline if this is a windows text file
186 ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
188 # this is the 5 returns in a row. each handles one possible
189 # combination of caller context and requested return type
192 $sep = '\n\n+' if defined $sep && $sep eq '' ;
194 # caller wants to get an array ref of lines
196 # this split doesn't work since it tries to use variable length lookbehind
197 # the m// line works.
198 # return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'} ;
199 return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
200 if $args{'array_ref'} ;
202 # caller wants a list of lines (normal list context)
204 # same problem with this split as before.
205 # return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
206 return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
209 # caller wants a scalar ref to the slurped text
211 return $buf_ref if $args{'scalar_ref'} ;
213 # caller wants a scalar with the slurped text (normal scalar context)
215 return ${$buf_ref} if defined wantarray ;
217 # caller passed in an i/o buffer by reference (normal void context)
223 # error handling section
225 # all the error handling uses magic goto so the caller will get the
226 # error message as if from their code and not this module. if we just
227 # did a call on the error code, the carp/croak would report it from
228 # this module since the error sub is one level down on the call stack
229 # from read_file/write_file/read_dir.
239 my( $args, $err_msg ) = @_ ;
241 # get the error function to use
243 my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
245 # if we didn't find it in our error function hash, they must have set
246 # it to quiet and we don't do anything.
248 return unless $func ;
250 # call the carp/croak function
254 # return a hard undef (in list context this will be a single value of
255 # undef which is not a legal in-band value)