lib/FileHandle.pm

   1 package FileHandle;
   2
   3 # Note that some additional FileHandle methods are defined in POSIX.pm.
   4
   5 =head1 NAME
   6
   7 FileHandle - supply object methods for filehandles
   8
   9 cacheout - keep more files open than the system permits
  10
  11 =head1 SYNOPSIS
  12
  13     use FileHandle;
  14     autoflush STDOUT 1;
  15
  16     cacheout($path);
  17     print $path @data;
  18
  19 =head1 DESCRIPTION
  20
  21 See L<perlvar> for complete descriptions of each of the following supported C<FileHandle>
  22 methods:
  23
  24     autoflush
  25     output_field_separator
  26     output_record_separator
  27     input_record_separator
  28     input_line_number
  29     format_page_number
  30     format_lines_per_page
  31     format_lines_left
  32     format_name
  33     format_top_name
  34     format_line_break_characters
  35     format_formfeed
  36
  37 Furthermore, for doing normal I/O you might need these:
  38
  39 =over
  40
  41 =item $fh->print
  42
  43 See L<perlfunc/print>.
  44
  45 =item $fh->printf
  46
  47 See L<perlfunc/printf>.
  48
  49 =item $fh->getline
  50
  51 This works like <$fh> described in L<perlop/"I/O Operators"> except that it's more readable
  52 and can be safely called in an array context but still
  53 returns just one line.
  54
  55 =item $fh->getlines
  56
  57 This works like <$fh> when called in an array context to
  58 read all the remaining lines in a file, except that it's more readable.
  59 It will also croak() if accidentally called in a scalar context.
  60
  61 =back
  62
  63 =head2 The cacheout() Library
  64
  65 The cacheout() function will make sure that there's a filehandle
  66 open for writing available as the pathname you give it.  It automatically
  67 closes and re-opens files if you exceed your system file descriptor maximum.
  68
  69 =head1 SEE ALSO
  70
  71 L<perlfunc>,
  72 L<perlop/"I/O Operators">,
  73 L<POSIX/"FileHandle">
  74
  75 =head1 BUGS
  76
  77 F<sys/param.h> lies with its C<NOFILE> define on some systems,
  78 so you may have to set $cacheout::maxopen yourself.
  79
  80 Some of the methods that set variables (like format_name()) don't
  81 seem to work.
  82
  83 The POSIX functions that create FileHandle methods should be
  84 in this module instead.
  85
  86 Due to backwards compatibility, all filehandles resemble objects
  87 of class C<FileHandle>, or actually classes derived from that class.
  88 They actually aren't.  Which means you can't derive your own
  89 class from C<FileHandle> and inherit those methods.
  90
  91 =cut
  92
  93 require 5.000;
  94 use English;
  95 use Carp;
  96 use Exporter;
  97
  98 @ISA = qw(Exporter);
  99 @EXPORT = qw(
 100     autoflush
 101     output_field_separator
 102     output_record_separator
 103     input_record_separator
 104     input_line_number
 105     format_page_number
 106     format_lines_per_page
 107     format_lines_left
 108     format_name
 109     format_top_name
 110     format_line_break_characters
 111     format_formfeed
 112
 113     print
 114     printf
 115     getline
 116     getlines
 117
 118     cacheout
 119 );
 120
 121 sub print {
 122     local($this) = shift;
 123     print $this @_;
 124 }
 125
 126 sub printf {
 127     local($this) = shift;
 128     printf $this @_;
 129 }
 130
 131 sub getline {
 132     local($this) = shift;
 133     croak "usage: FileHandle::getline()" if @_;
 134     return scalar <$this>;
 135 }
 136
 137 sub getlines {
 138     local($this) = shift;
 139     croak "usage: FileHandle::getline()" if @_;
 140     croak "can't call FileHandle::getlines in a scalar context" if wantarray;
 141     return <$this>;
 142 }
 143
 144 sub autoflush {
 145     local($old) = select($_[0]);
 146     local($prev) = $OUTPUT_AUTOFLUSH;
 147     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
 148     select($old);
 149     $prev;
 150 }
 151
 152 sub output_field_separator {
 153     local($old) = select($_[0]);
 154     local($prev) = $OUTPUT_FIELD_SEPARATOR;
 155     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
 156     select($old);
 157     $prev;
 158 }
 159
 160 sub output_record_separator {
 161     local($old) = select($_[0]);
 162     local($prev) = $OUTPUT_RECORD_SEPARATOR;
 163     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
 164     select($old);
 165     $prev;
 166 }
 167
 168 sub input_record_separator {
 169     local($old) = select($_[0]);
 170     local($prev) = $INPUT_RECORD_SEPARATOR;
 171     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
 172     select($old);
 173     $prev;
 174 }
 175
 176 sub input_line_number {
 177     local($old) = select($_[0]);
 178     local($prev) = $INPUT_LINE_NUMBER;
 179     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
 180     select($old);
 181     $prev;
 182 }
 183
 184 sub format_page_number {
 185     local($old) = select($_[0]);
 186     local($prev) = $FORMAT_PAGE_NUMBER;
 187     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
 188     select($old);
 189     $prev;
 190 }
 191
 192 sub format_lines_per_page {
 193     local($old) = select($_[0]);
 194     local($prev) = $FORMAT_LINES_PER_PAGE;
 195     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
 196     select($old);
 197     $prev;
 198 }
 199
 200 sub format_lines_left {
 201     local($old) = select($_[0]);
 202     local($prev) = $FORMAT_LINES_LEFT;
 203     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
 204     select($old);
 205     $prev;
 206 }
 207
 208 sub format_name {
 209     local($old) = select($_[0]);
 210     local($prev) = $FORMAT_NAME;
 211     $FORMAT_NAME = $_[1] if @_ > 1;
 212     select($old);
 213     $prev;
 214 }
 215
 216 sub format_top_name {
 217     local($old) = select($_[0]);
 218     local($prev) = $FORMAT_TOP_NAME;
 219     $FORMAT_TOP_NAME = $_[1] if @_ > 1;
 220     select($old);
 221     $prev;
 222 }
 223
 224 sub format_line_break_characters {
 225     local($old) = select($_[0]);
 226     local($prev) = $FORMAT_LINE_BREAK_CHARACTERS;
 227     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
 228     select($old);
 229     $prev;
 230 }
 231
 232 sub format_formfeed {
 233     local($old) = select($_[0]);
 234     local($prev) = $FORMAT_FORMFEED;
 235     $FORMAT_FORMFEED = $_[1] if @_ > 1;
 236     select($old);
 237     $prev;
 238 }
 239
 240
 241 # --- cacheout functions ---
 242
 243 # Open in their package.
 244
 245 sub cacheout_open {
 246     my $pack = caller(1);
 247     open(*{$pack . '::' . $_[0]}, $_[1]);
 248 }
 249
 250 sub cacheout_close {
 251     my $pack = caller(1);
 252     close(*{$pack . '::' . $_[0]});
 253 }
 254
 255 # But only this sub name is visible to them.
 256
 257 sub cacheout {
 258     ($file) = @_;
 259     if (!$cacheout_maxopen){
 260         if (open(PARAM,'/usr/include/sys/param.h')) {
 261             local($.);
 262             while (<PARAM>) {
 263                 $cacheout_maxopen = $1 - 4
 264                     if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
 265             }
 266             close PARAM;
 267         }
 268         $cacheout_maxopen = 16 unless $cacheout_maxopen;
 269     }
 270     if (!$isopen{$file}) {
 271         if (++$cacheout_numopen > $cacheout_maxopen) {
 272             local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
 273             splice(@lru, $cacheout_maxopen / 3);
 274             $cacheout_numopen -= @lru;
 275             for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
 276         }
 277         &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
 278             || croak("Can't create $file: $!");
 279     }
 280     $isopen{$file} = ++$cacheout_seq;
 281 }
 282
 283 $cacheout_seq = 0;
 284 $cacheout_numopen = 0;
 285
 286 1;