WebshopApi: Syntax in Tests
[kivitendo-erp.git] / modules / fallback / File / Slurp.pm
1 package File::Slurp;
2
3 use strict;
4
5 use Carp ;
6 use POSIX qw( :fcntl_h ) ;
7 use Fcntl qw( :DEFAULT ) ;
8 use Symbol ;
9
10 my $is_win32 = $^O =~ /win32/i ;
11
12 # Install subs for various constants that aren't set in older perls
13 # (< 5.005).  Fcntl on old perls uses Exporter to define subs without a
14 # () prototype These can't be overridden with the constant pragma or
15 # we get a prototype mismatch.  Hence this less than aesthetically
16 # appealing BEGIN block:
17
18 BEGIN {
19         unless( eval { defined SEEK_SET() } ) {
20                 *SEEK_SET = sub { 0 };
21                 *SEEK_CUR = sub { 1 };
22                 *SEEK_END = sub { 2 };
23         }
24
25         unless( eval { defined O_BINARY() } ) {
26                 *O_BINARY = sub { 0 };
27                 *O_RDONLY = sub { 0 };
28                 *O_WRONLY = sub { 1 };
29         }
30
31         unless ( eval { defined O_APPEND() } ) {
32
33                 if ( $^O =~ /olaris/ ) {
34                         *O_APPEND = sub { 8 };
35                         *O_CREAT = sub { 256 };
36                         *O_EXCL = sub { 1024 };
37                 }
38                 elsif ( $^O =~ /inux/ ) {
39                         *O_APPEND = sub { 1024 };
40                         *O_CREAT = sub { 64 };
41                         *O_EXCL = sub { 128 };
42                 }
43                 elsif ( $^O =~ /BSD/i ) {
44                         *O_APPEND = sub { 8 };
45                         *O_CREAT = sub { 512 };
46                         *O_EXCL = sub { 2048 };
47                 }
48         }
49 }
50
51 # print "OS [$^O]\n" ;
52
53 # print "O_BINARY = ", O_BINARY(), "\n" ;
54 # print "O_RDONLY = ", O_RDONLY(), "\n" ;
55 # print "O_WRONLY = ", O_WRONLY(), "\n" ;
56 # print "O_APPEND = ", O_APPEND(), "\n" ;
57 # print "O_CREAT   ", O_CREAT(), "\n" ;
58 # print "O_EXCL   ", O_EXCL(), "\n" ;
59
60 use base 'Exporter' ;
61 use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
62
63 %EXPORT_TAGS = ( 'all' => [
64         qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
65
66 @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
67 @EXPORT_OK = qw( slurp ) ;
68
69 $VERSION = '9999.13';
70
71 *slurp = \&read_file ;
72
73 sub read_file {
74
75         my( $file_name, %args ) = @_ ;
76
77 # set the buffer to either the passed in one or ours and init it to the null
78 # string
79
80         my $buf ;
81         my $buf_ref = $args{'buf_ref'} || \$buf ;
82         ${$buf_ref} = '' ;
83
84         my( $read_fh, $size_left, $blk_size ) ;
85
86 # check if we are reading from a handle (glob ref or IO:: object)
87
88         if ( ref $file_name ) {
89
90 # slurping a handle so use it and don't open anything.
91 # set the block size so we know it is a handle and read that amount
92
93                 $read_fh = $file_name ;
94                 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
95                 $size_left = $blk_size ;
96
97 # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
98 # glob/handle. only the DATA handle is untainted (since it is from
99 # trusted data in the source file). this allows us to test if this is
100 # the DATA handle and then to do a sysseek to make sure it gets
101 # slurped correctly. on some systems, the buffered i/o pointer is not
102 # left at the same place as the fd pointer. this sysseek makes them
103 # the same so slurping with sysread will work.
104
105                 eval{ require B } ;
106
107                 if ( $@ ) {
108
109                         @_ = ( \%args, <<ERR ) ;
110 Can't find B.pm with this Perl: $!.
111 That module is needed to slurp the DATA handle.
112 ERR
113                         goto &_error ;
114                 }
115
116                 if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
117
118 # set the seek position to the current tell.
119
120                         sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
121                                 croak "sysseek $!" ;
122                 }
123         }
124         else {
125
126 # a regular file. set the sysopen mode
127
128                 my $mode = O_RDONLY ;
129
130 #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
131
132 # open the file and handle any error
133
134                 $read_fh = gensym ;
135                 unless ( sysopen( $read_fh, $file_name, $mode ) ) {
136                         @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
137                         goto &_error ;
138                 }
139
140                 binmode($read_fh, $args{'binmode'}) if $args{'binmode'};
141
142 # get the size of the file for use in the read loop
143
144                 $size_left = -s $read_fh ;
145
146                 unless( $size_left ) {
147
148                         $blk_size = $args{'blk_size'} || 1024 * 1024 ;
149                         $size_left = $blk_size ;
150                 }
151         }
152
153 # infinite read loop. we exit when we are done slurping
154
155         while( 1 ) {
156
157 # do the read and see how much we got
158
159                 my $read_cnt = sysread( $read_fh, ${$buf_ref},
160                                 $size_left, length ${$buf_ref} ) ;
161
162                 if ( defined $read_cnt ) {
163
164 # good read. see if we hit EOF (nothing left to read)
165
166                         last if $read_cnt == 0 ;
167
168 # loop if we are slurping a handle. we don't track $size_left then.
169
170                         next if $blk_size ;
171
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 ;
175                         next ;
176                 }
177
178 # handle the read error
179
180                 @_ = ( \%args, "read_file '$file_name' - sysread: $!");
181                 goto &_error ;
182         }
183
184 # fix up cr/lf to be a newline if this is a windows text file
185
186         ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
187
188 # this is the 5 returns in a row. each handles one possible
189 # combination of caller context and requested return type
190
191         my $sep = $/ ;
192         $sep = '\n\n+' if defined $sep && $sep eq '' ;
193
194 # caller wants to get an array ref of lines
195
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'}  ;
201
202 # caller wants a list of lines (normal list context)
203
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 : ()
207                 if wantarray ;
208
209 # caller wants a scalar ref to the slurped text
210
211         return $buf_ref if $args{'scalar_ref'} ;
212
213 # caller wants a scalar with the slurped text (normal scalar context)
214
215         return ${$buf_ref} if defined wantarray ;
216
217 # caller passed in an i/o buffer by reference (normal void context)
218
219         return ;
220 }
221
222 sub write_file {
223
224         my $file_name = shift ;
225
226 # get the optional argument hash ref from @_ or an empty hash ref.
227
228         my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
229
230         my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
231
232 # get the buffer ref - it depends on how the data is passed into write_file
233 # after this if/else $buf_ref will have a scalar ref to the data.
234
235         if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {
236
237 # a scalar ref passed in %args has the data
238 # note that the data was passed by ref
239
240                 $buf_ref = $args->{'buf_ref'} ;
241                 $data_is_ref = 1 ;
242         }
243         elsif ( ref $_[0] eq 'SCALAR' ) {
244
245 # the first value in @_ is the scalar ref to the data
246 # note that the data was passed by ref
247
248                 $buf_ref = shift ;
249                 $data_is_ref = 1 ;
250         }
251         elsif ( ref $_[0] eq 'ARRAY' ) {
252
253 # the first value in @_ is the array ref to the data so join it.
254
255                 ${$buf_ref} = join '', @{$_[0]} ;
256         }
257         else {
258
259 # good old @_ has all the data so join it.
260
261                 ${$buf_ref} = join '', @_ ;
262         }
263
264 # see if we were passed a open handle to spew to.
265
266         if ( ref $file_name ) {
267
268 # we have a handle. make sure we don't call truncate on it.
269
270                 $write_fh = $file_name ;
271                 $no_truncate = 1 ;
272         }
273         else {
274
275 # spew to regular file.
276
277                 if ( $args->{'atomic'} ) {
278
279 # in atomic mode, we spew to a temp file so make one and save the original
280 # file name.
281                         $orig_file_name = $file_name ;
282                         $file_name .= ".$$" ;
283                 }
284
285 # set the mode for the sysopen
286
287                 my $mode = O_WRONLY | O_CREAT ;
288                 $mode |= O_APPEND if $args->{'append'} ;
289                 $mode |= O_EXCL if $args->{'no_clobber'} ;
290
291 #printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
292
293 # open the file and handle any error.
294
295                 $write_fh = gensym ;
296                 unless ( sysopen( $write_fh, $file_name, $mode ) ) {
297                         @_ = ( $args, "write_file '$file_name' - sysopen: $!");
298                         goto &_error ;
299                 }
300
301                 binmode($write_fh, $args->{'binmode'}) if $args->{'binmode'};
302         }
303
304         sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;
305
306
307 #print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
308
309 # fix up newline to write cr/lf if this is a windows text file
310
311         if ( $is_win32 && !$args->{'binmode'} ) {
312
313 # copy the write data if it was passed by ref so we don't clobber the
314 # caller's data
315                 $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
316                 ${$buf_ref} =~ s/\n/\015\012/g ;
317         }
318
319 #print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
320
321 # get the size of how much we are writing and init the offset into that buffer
322
323         my $size_left = length( ${$buf_ref} ) ;
324         my $offset = 0 ;
325
326 # loop until we have no more data left to write
327
328         do {
329
330 # do the write and track how much we just wrote
331
332                 my $write_cnt = syswrite( $write_fh, ${$buf_ref},
333                                 $size_left, $offset ) ;
334
335                 unless ( defined $write_cnt ) {
336
337 # the write failed
338                         @_ = ( $args, "write_file '$file_name' - syswrite: $!");
339                         goto &_error ;
340                 }
341
342 # track much left to write and where to write from in the buffer
343
344                 $size_left -= $write_cnt ;
345                 $offset += $write_cnt ;
346
347         } while( $size_left > 0 ) ;
348
349 # we truncate regular files in case we overwrite a long file with a shorter file
350 # so seek to the current position to get it (same as tell()).
351
352         truncate( $write_fh,
353                   sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
354
355         close( $write_fh ) ;
356
357 # handle the atomic mode - move the temp file to the original filename.
358
359         rename( $file_name, $orig_file_name ) if $args->{'atomic'} ;
360
361         return 1 ;
362 }
363
364 # this is for backwards compatibility with the previous File::Slurp module. 
365 # write_file always overwrites an existing file
366
367 *overwrite_file = \&write_file ;
368
369 # the current write_file has an append mode so we use that. this
370 # supports the same API with an optional second argument which is a
371 # hash ref of options.
372
373 sub append_file {
374
375 # get the optional args hash ref
376         my $args = $_[1] ;
377         if ( ref $args eq 'HASH' ) {
378
379 # we were passed an args ref so just mark the append mode
380
381                 $args->{append} = 1 ;
382         }
383         else {
384
385 # no args hash so insert one with the append mode
386
387                 splice( @_, 1, 0, { append => 1 } ) ;
388         }
389
390 # magic goto the main write_file sub. this overlays the sub without touching
391 # the stack or @_
392
393         goto &write_file
394 }
395
396 # basic wrapper around opendir/readdir
397
398 sub read_dir {
399
400         my ($dir, %args ) = @_;
401
402 # this handle will be destroyed upon return
403
404         local(*DIRH);
405
406 # open the dir and handle any errors
407
408         unless ( opendir( DIRH, $dir ) ) {
409
410                 @_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ;
411                 goto &_error ;
412         }
413
414         my @dir_entries = readdir(DIRH) ;
415
416         @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
417                 unless $args{'keep_dot_dot'} ;
418
419         return @dir_entries if wantarray ;
420         return \@dir_entries ;
421 }
422
423 # error handling section
424 #
425 # all the error handling uses magic goto so the caller will get the
426 # error message as if from their code and not this module. if we just
427 # did a call on the error code, the carp/croak would report it from
428 # this module since the error sub is one level down on the call stack
429 # from read_file/write_file/read_dir.
430
431
432 my %err_func = (
433         'carp'  => \&carp,
434         'croak' => \&croak,
435 ) ;
436
437 sub _error {
438
439         my( $args, $err_msg ) = @_ ;
440
441 # get the error function to use
442
443         my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
444
445 # if we didn't find it in our error function hash, they must have set
446 # it to quiet and we don't do anything.
447
448         return unless $func ;
449
450 # call the carp/croak function
451
452         $func->($err_msg) ;
453
454 # return a hard undef (in list context this will be a single value of
455 # undef which is not a legal in-band value)
456
457         return undef ;
458 }
459
460 1;
461 __END__
462
463 =head1 NAME
464
465 File::Slurp - Efficient Reading/Writing of Complete Files
466
467 =head1 SYNOPSIS
468
469   use File::Slurp;
470
471   my $text = read_file( 'filename' ) ;
472   my @lines = read_file( 'filename' ) ;
473
474   write_file( 'filename', @lines ) ;
475
476   use File::Slurp qw( slurp ) ;
477
478   my $text = slurp( 'filename' ) ;
479
480
481 =head1 DESCRIPTION
482
483 This module provides subs that allow you to read or write entire files
484 with one simple call. They are designed to be simple to use, have
485 flexible ways to pass in or get the file contents and to be very
486 efficient.  There is also a sub to read in all the files in a
487 directory other than C<.> and C<..>
488
489 These slurp/spew subs work for files, pipes and
490 sockets, and stdio, pseudo-files, and DATA.
491
492 =head2 B<read_file>
493
494 This sub reads in an entire file and returns its contents to the
495 caller. In list context it will return a list of lines (using the
496 current value of $/ as the separator including support for paragraph
497 mode when it is set to ''). In scalar context it returns the entire
498 file as a single scalar.
499
500   my $text = read_file( 'filename' ) ;
501   my @lines = read_file( 'filename' ) ;
502
503 The first argument to C<read_file> is the filename and the rest of the
504 arguments are key/value pairs which are optional and which modify the
505 behavior of the call. Other than binmode the options all control how
506 the slurped file is returned to the caller.
507
508 If the first argument is a file handle reference or I/O object (if ref
509 is true), then that handle is slurped in. This mode is supported so
510 you slurp handles such as C<DATA>, C<STDIN>. See the test handle.t
511 for an example that does C<open( '-|' )> and child process spews data
512 to the parant which slurps it in.  All of the options that control how
513 the data is returned to the caller still work in this case.
514
515 NOTE: as of version 9999.06, read_file works correctly on the C<DATA>
516 handle. It used to need a sysseek workaround but that is now handled
517 when needed by the module itself.
518
519 You can optionally request that C<slurp()> is exported to your code. This
520 is an alias for read_file and is meant to be forward compatible with
521 Perl 6 (which will have slurp() built-in).
522
523 The options are:
524
525 =head3 binmode
526
527 If you set the binmode option, then the file will be slurped in binary
528 mode.
529
530         my $bin_data = read_file( $bin_file, binmode => ':raw' ) ;
531         # Or
532         my $bin_data = read_file( $bin_file, binmode => ':utf8' ) ;
533
534 =head3 array_ref
535
536 If this boolean option is set, the return value (only in scalar
537 context) will be an array reference which contains the lines of the
538 slurped file. The following two calls are equivalent:
539
540         my $lines_ref = read_file( $bin_file, array_ref => 1 ) ;
541         my $lines_ref = [ read_file( $bin_file ) ] ;
542
543 =head3 scalar_ref
544
545 If this boolean option is set, the return value (only in scalar
546 context) will be an scalar reference to a string which is the contents
547 of the slurped file. This will usually be faster than returning the
548 plain scalar.
549
550         my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ;
551
552 =head3 buf_ref
553
554 You can use this option to pass in a scalar reference and the slurped
555 file contents will be stored in the scalar. This can be used in
556 conjunction with any of the other options.
557
558         my $text_ref = read_file( $bin_file, buf_ref => \$buffer,
559                                              array_ref => 1 ) ;
560         my @lines = read_file( $bin_file, buf_ref => \$buffer ) ;
561
562 =head3 blk_size
563
564 You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB.
565
566         my $text_ref = read_file( $bin_file, blk_size => 10_000_000,
567                                              array_ref => 1 ) ;
568
569 =head3 err_mode
570
571 You can use this option to control how read_file behaves when an error
572 occurs. This option defaults to 'croak'. You can set it to 'carp' or
573 to 'quiet to have no error handling. This code wants to carp and then
574 read abother file if it fails.
575
576         my $text_ref = read_file( $file, err_mode => 'carp' ) ;
577         unless ( $text_ref ) {
578
579                 # read a different file but croak if not found
580                 $text_ref = read_file( $another_file ) ;
581         }
582         
583         # process ${$text_ref}
584
585 =head2 B<write_file>
586
587 This sub writes out an entire file in one call.
588
589   write_file( 'filename', @data ) ;
590
591 The first argument to C<write_file> is the filename. The next argument
592 is an optional hash reference and it contains key/values that can
593 modify the behavior of C<write_file>. The rest of the argument list is
594 the data to be written to the file.
595
596   write_file( 'filename', {append => 1 }, @data ) ;
597   write_file( 'filename', {binmode => ':raw' }, $buffer ) ;
598
599 As a shortcut if the first data argument is a scalar or array
600 reference, it is used as the only data to be written to the file. Any
601 following arguments in @_ are ignored. This is a faster way to pass in
602 the output to be written to the file and is equivilent to the
603 C<buf_ref> option. These following pairs are equivilent but the pass
604 by reference call will be faster in most cases (especially with larger
605 files).
606
607   write_file( 'filename', \$buffer ) ;
608   write_file( 'filename', $buffer ) ;
609
610   write_file( 'filename', \@lines ) ;
611   write_file( 'filename', @lines ) ;
612
613 If the first argument is a file handle reference or I/O object (if ref
614 is true), then that handle is slurped in. This mode is supported so
615 you spew to handles such as \*STDOUT. See the test handle.t for an
616 example that does C<open( '-|' )> and child process spews data to the
617 parant which slurps it in.  All of the options that control how the
618 data is passes into C<write_file> still work in this case.
619
620 C<write_file> returns 1 upon successfully writing the file or undef if
621 it encountered an error.
622
623 The options are:
624
625 =head3 binmode
626
627 If you set the binmode option, then the file will be written in binary
628 mode.
629
630         write_file( $bin_file, {binmode => ':raw'}, @data ) ;
631         # Or
632         write_file( $bin_file, {binmode => ':utf8'}, @data ) ;
633
634 =head3 buf_ref
635
636 You can use this option to pass in a scalar reference which has the
637 data to be written. If this is set then any data arguments (including
638 the scalar reference shortcut) in @_ will be ignored. These are
639 equivilent:
640
641         write_file( $bin_file, { buf_ref => \$buffer } ) ;
642         write_file( $bin_file, \$buffer ) ;
643         write_file( $bin_file, $buffer ) ;
644
645 =head3 atomic
646
647 If you set this boolean option, the file will be written to in an
648 atomic fashion. A temporary file name is created by appending the pid
649 ($$) to the file name argument and that file is spewed to. After the
650 file is closed it is renamed to the original file name (and rename is
651 an atomic operation on most OS's). If the program using this were to
652 crash in the middle of this, then the file with the pid suffix could
653 be left behind.
654
655 =head3 append
656
657 If you set this boolean option, the data will be written at the end of
658 the current file.
659
660         write_file( $file, {append => 1}, @data ) ;
661
662 C<write_file> croaks if it cannot open the file. It returns true if it
663 succeeded in writing out the file and undef if there was an
664 error. (Yes, I know if it croaks it can't return anything but that is
665 for when I add the options to select the error handling mode).
666
667 =head3 no_clobber
668
669 If you set this boolean option, an existing file will not be overwritten.
670
671         write_file( $file, {no_clobber => 1}, @data ) ;
672
673 =head3 err_mode
674
675 You can use this option to control how C<write_file> behaves when an
676 error occurs. This option defaults to 'croak'. You can set it to
677 'carp' or to 'quiet' to have no error handling other than the return
678 value. If the first call to C<write_file> fails it will carp and then
679 write to another file. If the second call to C<write_file> fails, it
680 will croak.
681
682         unless ( write_file( $file, { err_mode => 'carp', \$data ) ;
683
684                 # write a different file but croak if not found
685                 write_file( $other_file, \$data ) ;
686         }
687
688 =head2 overwrite_file
689
690 This sub is just a typeglob alias to write_file since write_file
691 always overwrites an existing file. This sub is supported for
692 backwards compatibility with the original version of this module. See
693 write_file for its API and behavior.
694
695 =head2 append_file
696
697 This sub will write its data to the end of the file. It is a wrapper
698 around write_file and it has the same API so see that for the full
699 documentation. These calls are equivilent:
700
701         append_file( $file, @data ) ;
702         write_file( $file, {append => 1}, @data ) ;
703
704 =head2 read_dir
705
706 This sub reads all the file names from directory and returns them to
707 the caller but C<.> and C<..> are removed by default.
708
709         my @files = read_dir( '/path/to/dir' ) ;
710
711 It croaks if it cannot open the directory.
712
713 In a list context C<read_dir> returns a list of the entries in the
714 directory. In a scalar context it returns an array reference which has
715 the entries.
716
717 =head3 keep_dot_dot
718
719 If this boolean option is set, C<.> and C<..> are not removed from the
720 list of files.
721
722         my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ;
723
724 =head2 EXPORT
725
726   read_file write_file overwrite_file append_file read_dir
727
728 =head2 SEE ALSO
729
730 An article on file slurping in extras/slurp_article.pod. There is
731 also a benchmarking script in extras/slurp_bench.pl.
732
733 =head2 BUGS
734
735 If run under Perl 5.004, slurping from the DATA handle will fail as
736 that requires B.pm which didn't get into core until 5.005.
737
738 =head1 AUTHOR
739
740 Uri Guttman, E<lt>uri@stemsystems.comE<gt>
741
742 =cut