home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Tie / Handle.pm < prev    next >
Text File  |  2000-03-12  |  4KB  |  227 lines

  1. package Tie::Handle;
  2.  
  3. use 5.005_64;
  4. our $VERSION = '1.0';
  5.  
  6. =head1 NAME
  7.  
  8. Tie::Handle, Tie::StdHandle  - base class definitions for tied handles
  9.  
  10. =head1 SYNOPSIS
  11.  
  12.     package NewHandle;
  13.     require Tie::Handle;
  14.  
  15.     @ISA = (Tie::Handle);
  16.  
  17.     sub READ { ... }        # Provide a needed method
  18.     sub TIEHANDLE { ... }    # Overrides inherited method
  19.  
  20.  
  21.     package main;
  22.  
  23.     tie *FH, 'NewHandle';
  24.  
  25. =head1 DESCRIPTION
  26.  
  27. This module provides some skeletal methods for handle-tying classes. See
  28. L<perltie> for a list of the functions required in tying a handle to a package.
  29. The basic B<Tie::Handle> package provides a C<new> method, as well as methods
  30. C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. 
  31.  
  32. For developers wishing to write their own tied-handle classes, the methods
  33. are summarized below. The L<perltie> section not only documents these, but
  34. has sample code as well:
  35.  
  36. =over
  37.  
  38. =item TIEHANDLE classname, LIST
  39.  
  40. The method invoked by the command C<tie *glob, classname>. Associates a new
  41. glob instance with the specified class. C<LIST> would represent additional
  42. arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
  43. complete the association.
  44.  
  45. =item WRITE this, scalar, length, offset
  46.  
  47. Write I<length> bytes of data from I<scalar> starting at I<offset>.
  48.  
  49. =item PRINT this, LIST
  50.  
  51. Print the values in I<LIST>
  52.  
  53. =item PRINTF this, format, LIST
  54.  
  55. Print the values in I<LIST> using I<format>
  56.  
  57. =item READ this, scalar, length, offset
  58.  
  59. Read I<length> bytes of data into I<scalar> starting at I<offset>.
  60.  
  61. =item READLINE this
  62.  
  63. Read a single line
  64.  
  65. =item GETC this
  66.  
  67. Get a single character
  68.  
  69. =item CLOSE this
  70.  
  71. Close the handle
  72.  
  73. =item OPEN this, filename
  74.  
  75. (Re-)open the handle
  76.  
  77. =item BINMODE this
  78.  
  79. Specify content is binary
  80.  
  81. =item EOF this
  82.  
  83. Test for end of file.
  84.  
  85. =item TELL this
  86.  
  87. Return position in the file.
  88.  
  89. =item SEEK this, offset, whence
  90.  
  91. Position the file.
  92.  
  93. Test for end of file.
  94.  
  95. =item DESTROY this
  96.  
  97. Free the storage associated with the tied handle referenced by I<this>.
  98. This is rarely needed, as Perl manages its memory quite well. But the
  99. option exists, should a class wish to perform specific actions upon the
  100. destruction of an instance.
  101.  
  102. =back
  103.  
  104. =head1 MORE INFORMATION
  105.  
  106. The L<perltie> section contains an example of tying handles.
  107.  
  108. =cut
  109.  
  110. use Carp;
  111. use warnings::register;
  112.  
  113. sub new {
  114.     my $pkg = shift;
  115.     $pkg->TIEHANDLE(@_);
  116. }
  117.  
  118. # "Grandfather" the new, a la Tie::Hash
  119.  
  120. sub TIEHANDLE {
  121.     my $pkg = shift;
  122.     if (defined &{"{$pkg}::new"}) {
  123.     warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
  124.         if warnings::enabled();
  125.     $pkg->new(@_);
  126.     }
  127.     else {
  128.     croak "$pkg doesn't define a TIEHANDLE method";
  129.     }
  130. }
  131.  
  132. sub PRINT {
  133.     my $self = shift;
  134.     if($self->can('WRITE') != \&WRITE) {
  135.     my $buf = join(defined $, ? $, : "",@_);
  136.     $buf .= $\ if defined $\;
  137.     $self->WRITE($buf,length($buf),0);
  138.     }
  139.     else {
  140.     croak ref($self)," doesn't define a PRINT method";
  141.     }
  142. }
  143.  
  144. sub PRINTF {
  145.     my $self = shift;
  146.     
  147.     if($self->can('WRITE') != \&WRITE) {
  148.     my $buf = sprintf(shift,@_);
  149.     $self->WRITE($buf,length($buf),0);
  150.     }
  151.     else {
  152.     croak ref($self)," doesn't define a PRINTF method";
  153.     }
  154. }
  155.  
  156. sub READLINE {
  157.     my $pkg = ref $_[0];
  158.     croak "$pkg doesn't define a READLINE method";
  159. }
  160.  
  161. sub GETC {
  162.     my $self = shift;
  163.     
  164.     if($self->can('READ') != \&READ) {
  165.     my $buf;
  166.     $self->READ($buf,1);
  167.     return $buf;
  168.     }
  169.     else {
  170.     croak ref($self)," doesn't define a GETC method";
  171.     }
  172. }
  173.  
  174. sub READ {
  175.     my $pkg = ref $_[0];
  176.     croak "$pkg doesn't define a READ method";
  177. }
  178.  
  179. sub WRITE {
  180.     my $pkg = ref $_[0];
  181.     croak "$pkg doesn't define a WRITE method";
  182. }
  183.  
  184. sub CLOSE {
  185.     my $pkg = ref $_[0];
  186.     croak "$pkg doesn't define a CLOSE method";
  187.  
  188. package Tie::StdHandle; 
  189. our @ISA = 'Tie::Handle';       
  190. use Carp;
  191.  
  192. sub TIEHANDLE 
  193. {
  194.  my $class = shift;
  195.  my $fh    = do { \local *HANDLE};
  196.  bless $fh,$class;
  197.  $fh->OPEN(@_) if (@_);
  198.  return $fh;
  199. }         
  200.  
  201. sub EOF     { eof($_[0]) }
  202. sub TELL    { tell($_[0]) }
  203. sub FILENO  { fileno($_[0]) }
  204. sub SEEK    { seek($_[0],$_[1],$_[2]) }
  205. sub CLOSE   { close($_[0]) }
  206. sub BINMODE { binmode($_[0]) }
  207.  
  208. sub OPEN
  209. {         
  210.  $_[0]->CLOSE if defined($_[0]->FILENO);
  211.  open($_[0],$_[1]);
  212. }
  213.  
  214. sub READ     { read($_[0],$_[1],$_[2]) }
  215. sub READLINE { my $fh = $_[0]; <$fh> }
  216. sub GETC     { getc($_[0]) }
  217.  
  218. sub WRITE
  219. {        
  220.  my $fh = $_[0];
  221.  print $fh substr($_[1],0,$_[2])
  222. }
  223.  
  224.  
  225. 1;
  226.