Commit | Line | Data |
3fea05b9 |
1 | package PerlIO::via::dynamic; |
2 | use strict; |
3 | our $VERSION = '0.13'; |
4 | |
5 | =head1 NAME |
6 | |
7 | PerlIO::via::dynamic - dynamic PerlIO layers |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | open $fh, $fname; |
12 | $p = PerlIO::via::dynamic->new |
13 | (translate => |
14 | sub { $_[1] =~ s/\$Filename[:\w\s\-\.\/\\]*\$/\$Filename: $fname\$/e}, |
15 | untranslate => |
16 | sub { $_[1] =~ s/\$Filename[:\w\s\-\.\/\\]*\$/\$Filename\$/}); |
17 | $p->via ($fh); |
18 | binmode $fh, $p->via; # deprecated |
19 | |
20 | =head1 DESCRIPTION |
21 | |
22 | C<PerlIO::via::dynamic> is used for creating dynamic L<PerlIO> |
23 | layers. It is useful when the behavior or the layer depends on |
24 | variables. You should not use this module as via layer directly (ie |
25 | :via(dynamic)). |
26 | |
27 | Use the constructor to create new layers, with two arguments: |
28 | translate and untranslate. Then use C<$p->via ($fh)> to wrap the |
29 | handle. Once <$fh> is destroyed, the temporary namespace for the IO |
30 | layer will be removed. |
31 | |
32 | Note that PerlIO::via::dynamic uses the scalar fields to reference to |
33 | the object representing the dynamic namespace. |
34 | |
35 | =head1 OPTIONS |
36 | |
37 | =over |
38 | |
39 | =item translate |
40 | |
41 | A function that translate buffer upon I<write>. |
42 | |
43 | =item untranslate |
44 | |
45 | A function that translate buffer upon I<read>. |
46 | |
47 | =item use_read |
48 | |
49 | Use C<READ> instead of C<FILL> for the layer. Useful when caller |
50 | expect exact amount of data from read, and the C<untranslate> function |
51 | might return different length. |
52 | |
53 | By default C<PerlIO::via::dynamic> creates line-based layer to make |
54 | C<translate> implementation easier. |
55 | |
56 | =back |
57 | |
58 | =cut |
59 | |
60 | use Symbol qw(delete_package gensym); |
61 | use Scalar::Util qw(weaken); |
62 | use IO::Handle; |
63 | |
64 | sub PUSHED { |
65 | die "this should not be via directly" |
66 | if $_[0] eq __PACKAGE__; |
67 | my $p = bless gensym(), $_[0]; |
68 | |
69 | if ($] == 5.010000 && ref($_[-1]) eq 'GLOB') { |
70 | # This is to workaround a core bug in perl 5.10.0, see |
71 | # http://rt.perl.org/rt3/Public/Bug/Display.html?id=54934 |
72 | require Internals; |
73 | Internals::SetRefCount($_[-1], Internals::GetRefCount($_[-1])+1); |
74 | } |
75 | no strict 'refs'; |
76 | # make sure the blessed glob is destroyed |
77 | # earlier than the object representing the namespace. |
78 | ${*$p} = ${"$_[0]::EGO"}; |
79 | |
80 | return $p; |
81 | } |
82 | |
83 | sub translate { |
84 | } |
85 | |
86 | sub untranslate { |
87 | } |
88 | |
89 | sub _FILL { |
90 | my $line = readline( $_[1] ); |
91 | $_[0]->untranslate ($line) if defined $line; |
92 | $line; |
93 | } |
94 | |
95 | sub READ { |
96 | my $ret = read $_[3], $_[1], $_[2]; |
97 | return $ret unless $ret > 0; |
98 | $_[0]->untranslate ($_[1]); |
99 | return length ($_[1]); |
100 | } |
101 | |
102 | sub WRITE { |
103 | my $buf = $_[1]; |
104 | $_[0]->translate($buf); |
105 | $_[2]->autoflush (1); |
106 | (print {$_[2]} $buf) ? length ($buf) : -1; |
107 | } |
108 | |
109 | sub SEEK { |
110 | seek ($_[3], $_[1], $_[2]); |
111 | } |
112 | |
113 | sub new { |
114 | my ($class, %arg) = @_; |
115 | my $self = {}; |
116 | my $package = 'PerlIO::via::dynamic'.substr("$self", 7, -1); |
117 | eval qq| |
118 | package $package; |
119 | our \@ISA = qw($class); |
120 | |
121 | 1; |
122 | | or die $@; |
123 | |
124 | no strict 'refs'; |
125 | for (qw/translate untranslate/) { |
126 | *{"$package\::$_"} = delete $arg{$_} |
127 | if exists $arg{$_} |
128 | } |
129 | %$self = %arg; |
130 | unless ($self->{use_read}) { |
131 | *{"$package\::FILL"} = *PerlIO::via::dynamic::_FILL; |
132 | } |
133 | bless $self, $package; |
134 | ${"$package\::EGO"} = $self; |
135 | weaken ${"$package\::EGO"}; |
136 | return $self; |
137 | } |
138 | |
139 | sub via { |
140 | my ($self, $fh) = @_; |
141 | my $via = ':via('.ref ($_[0]).')'; |
142 | unless ($fh) { |
143 | # 0.01 compatibility |
144 | $self->{nogc} = 1; |
145 | return $via; |
146 | } |
147 | binmode ($fh, $via) or die $!; |
148 | if (defined ${*$fh}) { |
149 | if (defined @{*$fh}) { |
150 | warn "handle $fh cannot hold references, namespace won't be cleaned"; |
151 | $self->{nogc} = 1; |
152 | } |
153 | else { |
154 | ${*$fh}[0] = $self; |
155 | } |
156 | } |
157 | else { |
158 | ${*$fh} = $self; |
159 | } |
160 | } |
161 | |
162 | sub DESTROY { |
163 | my ($self) = @_; |
164 | return unless UNIVERSAL::isa ($self, 'HASH'); |
165 | return if $self->{nogc}; |
166 | |
167 | no strict 'refs'; |
168 | my $ref = ref($self); |
169 | my ($leaf) = ($ref =~ /([^:]+)$/); |
170 | $leaf .= '::'; |
171 | |
172 | for my $sym (keys %{$ref.'::'}) { |
173 | undef ${$ref.'::'}{$sym} |
174 | if $sym; |
175 | } |
176 | |
177 | delete $PerlIO::via::{$leaf}; |
178 | } |
179 | |
180 | =head1 AUTHORS |
181 | |
182 | Chia-liang Kao E<lt>clkao@clkao.orgE<gt> |
183 | |
184 | =head1 COPYRIGHT |
185 | |
186 | Copyright 2004 by Chia-liang Kao E<lt>clkao@clkao.orgE<gt>. |
187 | |
188 | This program is free software; you can redistribute it and/or modify it |
189 | under the same terms as Perl itself. |
190 | |
191 | See L<http://www.perl.com/perl/misc/Artistic.html> |
192 | |
193 | =cut |
194 | |
195 | 1; |