File Coverage

inc/IO/WrapTie.pm
Criterion Covered Total %
statement 21 56 37.5
branch n/a
condition n/a
subroutine 7 23 30.4
pod 1 2 50.0
total 29 81 35.8


line stmt bran cond sub pod time code
1             #line 1
2             # SEE DOCUMENTATION AT BOTTOM OF FILE
3              
4              
5             #------------------------------------------------------------
6             package IO::WrapTie;
7             #------------------------------------------------------------
8 5     5   27 require 5.004; ### for tie
  5         8  
  5         191  
9 5     5   24 use strict;
  5         10  
  5         323  
10 5     5   26 use vars qw(@ISA @EXPORT $VERSION);
  5         9  
  5         676  
11             use Exporter;
12              
13             # Inheritance, exporting, and package version:
14             @ISA = qw(Exporter);
15             @EXPORT = qw(wraptie);
16             $VERSION = "2.110";
17              
18             # Function, exported.
19 0     0 1 0 sub wraptie {
20             IO::WrapTie::Master->new(@_);
21             }
22              
23             # Class method; BACKWARDS-COMPATIBILITY ONLY!
24 0     0 0 0 sub new {
25 0         0 shift;
26             IO::WrapTie::Master->new(@_);
27             }
28              
29              
30              
31             #------------------------------------------------------------
32             package IO::WrapTie::Master;
33             #------------------------------------------------------------
34 5     5   22  
  5         10  
  5         178  
35 5     5   26 use strict;
  5         10  
  5         214  
36 5     5   42 use vars qw(@ISA $AUTOLOAD);
  5         12  
  5         1651  
37             use IO::Handle;
38              
39             # We inherit from IO::Handle to get methods which invoke i/o operators,
40             # like print(), on our tied handle:
41             @ISA = qw(IO::Handle);
42              
43             #------------------------------
44             # new SLAVE, TIEARGS...
45             #------------------------------
46             # Create a new subclass of IO::Handle which...
47             #
48             # (1) Handles i/o OPERATORS because it is tied to an instance of
49             # an i/o-like class, like IO::Scalar.
50             #
51             # (2) Handles i/o METHODS by delegating them to that same tied object!.
52             #
53             # Arguments are the slave class (e.g., IO::Scalar), followed by all
54             # the arguments normally sent into that class's TIEHANDLE method.
55             # In other words, much like the arguments to tie(). :-)
56             #
57             # NOTE:
58             # The thing $x we return must be a BLESSED REF, for ($x->print()).
59             # The underlying symbol must be a FILEHANDLE, for (print $x "foo").
60             # It has to have a way of getting to the "real" back-end object...
61             #
62 0     0   0 sub new {
63 0         0 my $master = shift;
64 0         0 my $io = IO::Handle->new; ### create a new handle
65 0         0 my $slave = shift;
66 0         0 tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE
67             bless $io, $master; ### return a master
68             }
69              
70             #------------------------------
71             # AUTOLOAD
72             #------------------------------
73             # Delegate method invocations on the master to the underlying slave.
74             #
75 0     0   0 sub AUTOLOAD {
76 0         0 my $method = $AUTOLOAD;
77 0         0 $method =~ s/.*:://;
  0         0  
78             my $self = shift; tied(*$self)->$method(\@_);
79             }
80              
81             #------------------------------
82             # PRELOAD
83             #------------------------------
84             # Utility.
85             #
86             # Most methods like print(), getline(), etc. which work on the tied object
87             # via Perl's i/o operators (like 'print') are inherited from IO::Handle.
88             #
89             # Other methods, like seek() and sref(), we must delegate ourselves.
90             # AUTOLOAD takes care of these.
91             #
92             # However, it may be necessary to preload delegators into your
93             # own class. PRELOAD will do this.
94             #
95 5     5   10 sub PRELOAD {
96 5         14 my $class = shift;
97 50     0   2151 foreach (@_) {
  0     0      
  0     0      
  0     0      
  0     0      
  0     0      
  0     0      
  0     0      
  0     0      
  0     0      
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
98             eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }";
99             }
100             }
101              
102             # Preload delegators for some standard methods which we can't simply
103             # inherit from IO::Handle... for example, some IO::Handle methods
104             # assume that there is an underlying file descriptor.
105             #
106             PRELOAD IO::WrapTie::Master
107             qw(open opened close read clearerr eof seek tell setpos getpos);
108              
109              
110              
111             #------------------------------------------------------------
112             package IO::WrapTie::Slave;
113             #------------------------------------------------------------
114             # Teeny private class providing a new_tie constructor...
115             #
116             # HOW IT ALL WORKS:
117             #
118             # Slaves inherit from this class.
119             #
120             # When you send a new_tie() message to a tie-slave class (like IO::Scalar),
121             # it first determines what class should provide its master, via TIE_MASTER.
122             # In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master.
123             # Then, we create a new master (an IO::Scalar::Master) with the same args
124             # sent to new_tie.
125             #
126             # In general, the new() method of the master is inherited directly
127             # from IO::WrapTie::Master.
128             #
129 0     0     sub new_tie {
130 0           my $self = shift;
131             $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_)
132             }
133              
134             # Default class method for new_tie().
135             # All your tie-slave class (like IO::Scalar) has to do is override this
136             # method with a method that returns the name of an appropriate "master"
137             # class for tying that slave.
138 0     0     #
139             sub TIE_MASTER { 'IO::WrapTie::Master' }
140              
141             #------------------------------
142             1;
143             __END__