home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / FileHandle.pm < prev    next >
Text File  |  1995-07-03  |  5KB  |  224 lines

  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.     print
  25.     autoflush
  26.     output_field_separator
  27.     output_record_separator
  28.     input_record_separator
  29.     input_line_number
  30.     format_page_number
  31.     format_lines_per_page
  32.     format_lines_left
  33.     format_name
  34.     format_top_name
  35.     format_line_break_characters
  36.     format_formfeed
  37.  
  38. The cacheout() function will make sure that there's a filehandle
  39. open for writing available as the pathname you give it.  It automatically
  40. closes and re-opens files if you exceed your system file descriptor maximum.
  41.  
  42. =head1 BUGS
  43.  
  44. F<sys/param.h> lies with its C<NOFILE> define on some systems,
  45. so you may have to set $cacheout::maxopen yourself.
  46.  
  47. Due to backwards compatibility, all filehandles resemble objects
  48. of class C<FileHandle>, or actually classes derived from that class.
  49. They actually aren't.  Which means you can't derive your own 
  50. class from C<FileHandle> and inherit those methods.
  51.  
  52. =cut
  53.  
  54. require 5.000;
  55. use English;
  56. use Exporter;
  57.  
  58. @ISA = qw(Exporter);
  59. @EXPORT = qw(
  60.     print
  61.     autoflush
  62.     output_field_separator
  63.     output_record_separator
  64.     input_record_separator
  65.     input_line_number
  66.     format_page_number
  67.     format_lines_per_page
  68.     format_lines_left
  69.     format_name
  70.     format_top_name
  71.     format_line_break_characters
  72.     format_formfeed
  73.     cacheout
  74. );
  75.  
  76. sub print {
  77.     local($this) = shift;
  78.     print $this @_;
  79. }
  80.  
  81. sub autoflush {
  82.     local($old) = select($_[0]);
  83.     local($prev) = $OUTPUT_AUTOFLUSH;
  84.     $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
  85.     select($old);
  86.     $prev;
  87. }
  88.  
  89. sub output_field_separator {
  90.     local($old) = select($_[0]);
  91.     local($prev) = $OUTPUT_FIELD_SEPARATOR;
  92.     $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
  93.     select($old);
  94.     $prev;
  95. }
  96.  
  97. sub output_record_separator {
  98.     local($old) = select($_[0]);
  99.     local($prev) = $OUTPUT_RECORD_SEPARATOR;
  100.     $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  101.     select($old);
  102.     $prev;
  103. }
  104.  
  105. sub input_record_separator {
  106.     local($old) = select($_[0]);
  107.     local($prev) = $INPUT_RECORD_SEPARATOR;
  108.     $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
  109.     select($old);
  110.     $prev;
  111. }
  112.  
  113. sub input_line_number {
  114.     local($old) = select($_[0]);
  115.     local($prev) = $INPUT_LINE_NUMBER;
  116.     $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
  117.     select($old);
  118.     $prev;
  119. }
  120.  
  121. sub format_page_number {
  122.     local($old) = select($_[0]);
  123.     local($prev) = $FORMAT_PAGE_NUMBER;
  124.     $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
  125.     select($old);
  126.     $prev;
  127. }
  128.  
  129. sub format_lines_per_page {
  130.     local($old) = select($_[0]);
  131.     local($prev) = $FORMAT_LINES_PER_PAGE;
  132.     $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
  133.     select($old);
  134.     $prev;
  135. }
  136.  
  137. sub format_lines_left {
  138.     local($old) = select($_[0]);
  139.     local($prev) = $FORMAT_LINES_LEFT;
  140.     $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
  141.     select($old);
  142.     $prev;
  143. }
  144.  
  145. sub format_name {
  146.     local($old) = select($_[0]);
  147.     local($prev) = $FORMAT_NAME;
  148.     $FORMAT_NAME = $_[1] if @_ > 1;
  149.     select($old);
  150.     $prev;
  151. }
  152.  
  153. sub format_top_name {
  154.     local($old) = select($_[0]);
  155.     local($prev) = $FORMAT_TOP_NAME;
  156.     $FORMAT_TOP_NAME = $_[1] if @_ > 1;
  157.     select($old);
  158.     $prev;
  159. }
  160.  
  161. sub format_line_break_characters {
  162.     local($old) = select($_[0]);
  163.     local($prev) = $FORMAT_LINE_BREAK_CHARACTERS;
  164.     $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
  165.     select($old);
  166.     $prev;
  167. }
  168.  
  169. sub format_formfeed {
  170.     local($old) = select($_[0]);
  171.     local($prev) = $FORMAT_FORMFEED;
  172.     $FORMAT_FORMFEED = $_[1] if @_ > 1;
  173.     select($old);
  174.     $prev;
  175. }
  176.  
  177.  
  178. # --- cacheout functions ---
  179.  
  180. # Open in their package.
  181.  
  182. sub cacheout_open {
  183.     my $pack = caller(1);
  184.     open(*{$pack . '::' . $_[0]}, $_[1]);
  185. }
  186.  
  187. sub cacheout_close {
  188.     my $pack = caller(1);
  189.     close(*{$pack . '::' . $_[0]});
  190. }
  191.  
  192. # But only this sub name is visible to them.
  193.  
  194. sub cacheout {
  195.     ($file) = @_;
  196.     if (!$cacheout_maxopen){
  197.     if (open(PARAM,'/usr/include/sys/param.h')) {
  198.         local($.);
  199.         while (<PARAM>) {
  200.         $cacheout_maxopen = $1 - 4
  201.             if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
  202.         }
  203.         close PARAM;
  204.     }
  205.     $cacheout_maxopen = 16 unless $cacheout_maxopen;
  206.     }
  207.     if (!$isopen{$file}) {
  208.     if (++$cacheout_numopen > $cacheout_maxopen) {
  209.         local(@lru) = sort {$isopen{$a} <=> $isopen{$b};} keys(%isopen);
  210.         splice(@lru, $cacheout_maxopen / 3);
  211.         $cacheout_numopen -= @lru;
  212.         for (@lru) { &cacheout_close($_); delete $isopen{$_}; }
  213.     }
  214.     &cacheout_open($file, ($saw{$file}++ ? '>>' : '>') . $file)
  215.         || croak("Can't create $file: $!");
  216.     }
  217.     $isopen{$file} = ++$cacheout_seq;
  218. }
  219.  
  220. $cacheout_seq = 0;
  221. $cacheout_numopen = 0;
  222.  
  223. 1;
  224.