lib/FileHandle.pm

   1 package FileHandle;
   2
   3 # Note that some additional FileHandle methods are defined in POSIX.pm.
   4
   5 require 5.000;
   6 use English;
   7 use Exporter;
   8
   9 @ISA = qw(Exporter);
  10 @EXPORT = qw(
  11     print
  12     autoflush
  13     output_field_separator
  14     output_record_separator
  15     input_record_separator
  16     input_line_number
  17     format_page_number
  18     format_lines_per_page
  19     format_lines_left
  20     format_name
  21     format_top_name
  22     format_line_break_characters
  23     format_formfeed
  24     cacheout
  25 );
  26
  27 sub print {
  28     local($this) = shift;
  29     print $this @_;
  30 }
  31
  32 sub autoflush {
  33     local($old) = select($_[0]);
  34     local($prev) = $OUTPUT_AUTOFLUSH;
  35     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
  36     select($old);
  37     $prev;
  38 }
  39
  40 sub output_field_separator {
  41     local($old) = select($_[0]);
  42     local($prev) = $OUTPUT_FIELD_SEPARATOR;
  43     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
  44     select($old);
  45     $prev;
  46 }
  47
  48 sub output_record_separator {
  49     local($old) = select($_[0]);
  50     local($prev) = $OUTPUT_RECORD_SEPARATOR;
  51     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  52     select($old);
  53     $prev;
  54 }
  55
  56 sub input_record_separator {
  57     local($old) = select($_[0]);
  58     local($prev) = $INPUT_RECORD_SEPARATOR;
  59     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  60     select($old);
  61     $prev;
  62 }
  63
  64 sub input_line_number {
  65     local($old) = select($_[0]);
  66     local($prev) = $INPUT_LINE_NUMBER;
  67     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
  68     select($old);
  69     $prev;
  70 }
  71
  72 sub format_page_number {
  73     local($old) = select($_[0]);
  74     local($prev) = $FORMAT_PAGE_NUMBER;
  75     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
  76     select($old);
  77     $prev;
  78 }
  79
  80 sub format_lines_per_page {
  81     local($old) = select($_[0]);
  82     local($prev) = $FORMAT_LINES_PER_PAGE;
  83     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
  84     select($old);
  85     $prev;
  86 }
  87
  88 sub format_lines_left {
  89     local($old) = select($_[0]);
  90     local($prev) = $FORMAT_LINES_LEFT;
  91     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
  92     select($old);
  93     $prev;
  94 }
  95
  96 sub format_name {
  97     local($old) = select($_[0]);
  98     local($prev) = $FORMAT_NAME;
  99     $FORMAT_NAME = $_[1] if @_ > 1;
 100     select($old);
 101     $prev;
 102 }
 103
 104 sub format_top_name {
 105     local($old) = select($_[0]);
 106     local($prev) = $FORMAT_TOP_NAME;
 107     $FORMAT_TOP_NAME = $_[1] if @_ > 1;
 108     select($old);
 109     $prev;
 110 }
 111
 112 sub format_line_break_characters {
 113     local($old) = select($_[0]);
 114     local($prev) = $FORMAT_LINE_BREAK_CHARACTERS;
 115     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
 116     select($old);
 117     $prev;
 118 }
 119
 120 sub format_formfeed {
 121     local($old) = select($_[0]);
 122     local($prev) = $FORMAT_FORMFEED;
 123     $FORMAT_FORMFEED = $_[1] if @_ > 1;
 124     select($old);
 125     $prev;
 126 }
 127
 128
 129 # --- cacheout functions ---
 130
 131 # Open in their package.
 132
 133 sub cacheout_open {
 134     my $pack = caller(1);
 135     open(*{$pack . '::' . $_[0]}, $_[1]);
 136 }
 137
 138 sub cacheout_close {
 139     my $pack = caller(1);
 140     close(*{$pack . '::' . $_[0]});
 141 }
 142
 143 # But only this sub name is visible to them.
 144
 145 sub cacheout {
 146     ($file) = @_;
 147     if (!$cacheout_maxopen){
 148         if (open(PARAM,'/usr/include/sys/param.h')) {
 149             local($.);
 150             while (<PARAM>) {
 151                 $cacheout_maxopen = $1 - 4
 152                     if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
 153             }
 154             close PARAM;
 155         }
 156         $cacheout_maxopen = 16 unless $cacheout_maxopen;
 157     }
 158     if (!$isopen{$file}) {
 159         if (++$cacheout_numopen > $cacheout_maxopen) {
 160             local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
 161             splice(@lru, $cacheout_maxopen / 3);
 162             $cacheout_numopen -= @lru;
 163             for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
 164         }
 165         &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
 166             || croak("Can't create $file: $!");
 167     }
 168     $isopen{$file} = ++$cacheout_seq;
 169 }
 170
 171 $cacheout_seq = 0;
 172 $cacheout_numopen = 0;
 173
 174 1;