local-lib5/lib/perl5/PerlIO/via/dynamic.pm

   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;