第十四章 捆绑(tie)变量(下)

package Tie::AppendHash;
use Tie::Hash;
our @ISA = ("Tie::StdHash");
sub STORE {
        my ($self, $key, $value) = @_;
        push @{$self->{key}}, $value;
}
1;

use DotFiles;
tie %dot, "DotFiles";
if ( $dot{profile}  =~ /MANPATH/ or
$dot{login}   =~ /MANPATH/ or
$dot{cshrc}  =~ /MANPATH/ ) {
        print "you seem to set your MANPATH\n";
}

# 第三个参数是用户名，我们准备把他的点文件捆绑上去。
tie %him,  "DotFiels", "daemon";
foreach $f (keys %him) {
        printf "daemon dot file %s is size %d\n", $f, length $him{$f};
}

package DotFiles;
use Carp;
sub whowasi   { (caller(1))[3]. "()" }
my $DEBUG = 0;
sub debug { $DEBUGA = @_ ? shift: 1}

sub TIEHASH {
        my $self = shift;
        my $user = shift || 
gt;;
        my $dotdir = shift || "";
        
        croak "usage: @{[ &whowasi ] }  [ USER [DOTDIR]]" if @_;
        
        $user = getpwuid($user) if $user =~ /^\d+$/;
        my $dir = (getpwname($user))[7]
        or corak "@{ [&whowasi] }: no user $user";
        $dir  .= "/$dotdir" if $dotdir;
        
        my $node = {
                USER => $user,
                HOME => $dir,
                CONTENTS => {},
                CLOBBER => 0,
        };
        
        opendir DIR, $dir
        or croak "@{[&whowasi]}: can't opendir $dir: $!";
        for my $dot ( grep /^\./ && -f "$dir/$_", readdir(DIR)) {
                $dot =~ s/^\.//;
                $node->{CONTENTS}{$dot} = undef;
        }
        closedir DIR;
        
        return bless $node, $self;
}

sub FETCH {
        carp &whowasi if $DEBUG;
        my $self = shift;
        my $dot = shift;
        my $dir = $self->{HOME};
        my $file = "$dir/.$dot";
        
        unless (exists $self->{CONTENTS}->{$dot} || -f $file ) {
                carp "@{[&whowasi]}: no $dot file"  if $DEBUG;
                return undef;
        }
        
        # 实现一个缓冲
        if (defined $self->{CONTENTS}->{$dot} ) {
                return $self->{CONTENTS}->{$dot};
        } else {
                return $self->{CONTENTS}->{$dot} = `cat $dir/.$dot`;
        }
}

sub STORE {
        carp &whowasi if $DEBUG;
        my $self = shift;
        my $dot = shift;
        my $value = shift;
        my $file = $self->{HOME} . "/.$dot";
        
        croak "@{[&whowasi]}: $file not clobberable"
        unless $self->{CLOBBER};
        
        open(F, "> $file") or croak "cna't open $file: $!";
        print F $vale;
        close(F);
}

$ob = tie %daemon_dots, "daemon";
$ob->clobber(1);
$daemon_dot{signature} = "A true daemon\n";

不过，它们可以用 tied 设置 {CLOBBER}：

tie %daemon_dots, "Dotfiles", "daemon";
tied(%daemon_dots)->clobber(1);

或者用一条语句：

(tie %daemon_dots, "DotFiles", "daemon")->clobber(1);

clobber 方法只是简单的几行：

sub clobber{
        my $self  = shift;
        $self->{CLOBBER} = @_ ? shift : 1;
}

sub DELETE {
        carp &whowasi if $DEBUG;
        my $self = shift;
        my $dot = shift;
        my $file = $self->{HOME} . "./$dot";
        croak "@{[&whowasi]}: won't remove file $file"
        unless $self->{CLOBBER};
        delete $self->{CONTENTS}->{$dot};
        unlink $file or carp "@{[&whowasi]}: can't unlink $file: $!";
}

sub CLEAR {
        carp &whowasi if $DEBUG;
        my $self = shift;
        croak "@{[&whowasi]}: won't remove all dotfiles for $self->{USER}"
        unless $self->{CLOBBER} > 1;
        for my $dot (key % {$self->{COTENTS}}) {
                $self->DELETE($dot);
        }
}

sub EXISTS {
        carp &whowasi if $DEBUG;
        my $self = shift;
        my $dot = sfhit;
        return exists $self->{CONTENTS}->{$dot};
} 

sub FIRSTKEY {
        
        carp &whowasi if $DEBUG;
        my $self = shift;
        my $temp = keys %{$self->{CONTENTS}};
        return scalar each %{$self->{CONTENTS}};
}

sub NEXTKEY {
        carp &whowasi if $DEBUG;
        my $self = shift;
        return scalar each %{ $self->{CONTENTS}}
}

sub DESTROY{
        carp &whowasi if $DEBUG;
}

package ReversePrint;
use strict;
sub TIEHANDLE {
        my $class = shift;
        bless [], $class;
}
sub PRINT {
        my $self = shift;
        push @$self, join ' ', @_
}
sub PRINTF {
        my $self = shift;
        my $fmt = shift;
        push @$self, sprintf $fmt, @_;
}
sub READLINE {
        my $self = shift;
        pop @$self;
}

package main;
my $m = "--MORE--\n";
tie *REV, "ReversePrint";

# 做一些 print 和 printf。
print REV "The fox is now dead. $m";
printf REV <<"END", int rand 10000000;
The quick brown fox jumps over
over the lazy dog %d times!
END

print REV <<"END";
The quick brown fox jumps
over the lazy dog.
END

# 现在从同一个句柄中读回来
print while <REV>;

sub TIEHANDLE {
        my $class = shift;
        my $form = shift;
        open my $self, $form, @_ or croak "can't open $form@_: $!";
        if ($form =~ />/) {
                print $self "<SHOUT>\n";
                $self->{WRITING} = 1;   # 记得写结束标记
        }
        returnbless $self, $class;   # $self 是一个全局引用
}

sub OPEN {
        my $self = shift;
        my $form = shift;
        my $name = "$form@_";
        $self->CLOSE;
        open($self, $form, @_)   or croak "can't reopen $name: $!";
        if ($form =~ />/) {
                print $self "<SHOU>\n" or croak "can't start print: $!";
                $self->{WRITING} = 1;      # 记得写结束标记
        }
        else {
                $self->{WRITING} = 0;      # 记得不要写结束标记
        }
        return 1;
}

sub CLOSE {
        my $self = shift;
        if ($self->{WRITING}) {
                $self->SEEK(0,2)   or return;
                $self->PRINT("</SHOUT>\n")   or return;
        }
        return close $self;
}

sub SEEK {
        my $self = shift;
        my ($offset, $whence) = @_;
        return seek($self, $offset, $whence);
}

sub TELL {
        my $self = shift;
        return tell $self;
}

sub PRINTF {
        my $self = shift;
        my $template = shift;
        return $self->PRINT(sprintf $template, @_);
}

sub READ {
        my ($self, undef, $length, $offset) = @_;
        my $bufref = \$_[1];
        return read($self, $bufref, $length, $offset);
}

sub WRITE {
        my $self = shift;
        my $string = uc(shift);
        my $length = shift || length $string;
        my $offset = shift || 0;
        return syswrite $self, $string, $length, $offset;
}

sub EOF {
        my $self = shift;
        return eof $self;
}

sub BINMODE {
        my $self = shift;
        my $disc = shift || ":raw";
        return binmode $self, $disc;
}

sub FILENO {
        my $self = shift;
        return fileno $self;
}

sub DESTROY {
        my $self = shift;
        $self->CLOSE;      # 用 Shout 的 CLOSE 方法关闭文件
}

#! /usr/bin/perl
use Shout;
tie(*FOO, Shout::, ">filename");
print FOO "hello\n";      # 打印 HELLO。
seek FOO, 0, 0;         # 退回到开头
@lines = <FOO>;         # 调用 READLINE 方法。
close FOO;         # 明确关闭文件。
open(FOO, "+<", "filename");   # 重新打开 FOO，调用 OPEN。
seek(FOO, 8, 0);      # 忽略 "<SHOUT>\n"。
sysread(FOO, $inbuf, 5)      # 从 FOO 读取 5 个字节到 $inbuf。
print "found $inbuf\n";      # 应该打印 "hello"。
seek(FOO, -5, 1);      # 退回 "hello"之前。
syswrite(FOO, "ciao!\n", 6);   # 写 6 个字节到 FOO。
untie(*FOO);         # 明确调用 CLOSE 方法

# 这就是所有酷玩叶儿
use overload q(" ") => sub {$_[0]->pathname };

# 这里是放你想跟踪的函数的存根。
sub trace {
        my $self = shift;
        local $Carp::CarpLevel = 1;
        Carp::cluck("\ntrace magical method") if $self->debug;
}

# 重载句柄以打印出我们的路径
sub pathname {
        my $self = shift;
        confess "i am not a class method" unless ref $self;
        $self->{PATHNAME} = shift if @_;
        return $self->{PATHNAME};
}

# 双重模式
sub debug {
        my $self = shift;
        my $var = ref $self ? \$self->{DEBUG} : \our $Debug;
        $var = shift if @_;
        return ref $self ? $self->{DEBUG} || $Debug : $Debug;
}

sub GETC { $_[0]->trace;   # 新的
        my($self) = @_;
        getc($self);
}

sub TIEHANDLE {
        my $class    = shift;
        my $form = shift;
        my $name = "$form@_";          # NEW
        open my $self, $form, @_   or croak "can't open $name: $!";
        if ($form =~ />/) {
                print $self  "<SHOUT>\n";
                $self->{WRITING} = 1;     # Remember to do end tag
        }
        bless $self, $class;           # $fh is a glob ref
        $self->pathname($name);        # NEW
        return $self;
}

sub OPEN { $_[0]->trace;           # NEW
        my $self = shift;
        my $form = shift;
        my $name = "$form@_";          
        $self->CLOSE;
        open($self, $form, @_)      or croak "can't reopen $name: $!";
        $self->pathname($name);        # NEW
        if ($form =~ />/) {
                print $self "<SHOUT>\n" or croak "can't start print: $!";
                $self->{WRITING} = 1;     # Remember to do end tag
        }
        else {
                $self->{WRITING} = 0;     # Remember not to do end tag
        }
        return 1;
}

use Tie::Open2;

tie *CALC, 'Tie::Open2', "bc -l";
$sum = 2;
for (1 .. 7) {
        print CALC "$sum * $sum\n";
        $sum = <CALC>;
        print "$_: $sum";
        chomp $sum;
}
close CALC;

package Tie::Open2;
use strict;
use Carp;
use Tie::Handle;      # 不要从这里继承
use IPC::Open2;

sub TIEHANDLE {
        my ($class, @cmd) = @_;
        no warnings 'once';
        my @fhpair = \do { local(*RDR, *WTR) };
        bless $_, 'Tie::StdHandle' for @fhpair;
        bless(\@fhpair => $class)->OPEN(@cmd) || die;
        return \@fhpair;
}

sub OPEN {
        my ($self, @cmd) = @_;
        $self->CLOSE if grep {defined} @{ $self->FILENO };
        open2(@$self, @cmd);
}

sub FILENO {
        my $self = shift;
        [ map { fileno $self->[$_] } 0, 1];
}

for my $outmeth (qw(PRINT PRINTF WRITE) ) {
        no strict 'refs';
        *$outmeth = sub {
                my $self = shift;
                $self->[1]->$outmeth(@_);
        };
}

for my $inmeth (qw(READ READLINE GETC) ) {
        no strict 'refs';
        *$inmeth = sub {
                my $self = shift;
                $self->[0]->$inmeth(@_);
        };
}

for my $doppelmeth (qw(BINMODE CLOSE EOF)) {
        no strict 'refs';
        *$doppelmeth = sub {
                my $self = shift;
                $self->[0]->$doppelmeth(@_)  && $self->[1]->$doppelmeth(@_);
        };
}

for my $deadmeth (qw(SEEK TELL)) {
        no strict 'refs';
        *$deadmeth = sub {
                craok("can't $deadmeth a pipe");
        };
}
1;

use strict;
package Tie::DevNull

sub TIEHANDLE {
        my $class = shift;
        my $fh = local *FH;
        bless \$fh, $class;
}
for (qw(READ READLINE GETC PRINT PRINTF WRITE)) {
        no strict 'refs';
        *$_ = sub { return };
}

package Tie::DevRandom;

sub READLINE { rand() . "\n"; }
sub TIEHANDLE {
        my $class = shift;
        my $fh = local *FH;
        bless \$fh, $class;
}
sub FETCH { rand() }
sub TIESCALAR {
        my $class = shift;
        bless \my $self, $class;
}

package Tie::Tee;

sub TIEHANDLE {
        my $class = shift;
        my @handles;
        for my $path (@_) {
                open(my $fh, ">$path") || die "can't write $path";
                push @handles, $fh;
        }
        bless \@handles, $class;
}

sub PRINT {
        my $self = shift;
        my $ok = 0;
        for my $fh (@$self) {
                $ok += print $fh @_;
        }
        return $ok = @$self;
}

package main;

tie *SCATTER,    "Tie::Tee", qw(tmp1 - tmp2 >tmp3 tmp4);
tie *RANDOM,   "Tie::DevRandom";
tie *NULL,   "Tie::DevNull";
tiemy $randy, "Tie::DevRandom";

for my $i (1..10) {
        my $line = <RANDOM>;
        chomp $line;
        for my $fh ( *NULL, *SCATTER) {
                print $fh "$i: $line $randy\n";
        }
}

package Remember;

sub TIESCALAR {
        my $class = shift;
        my $filename = shift;
        open (my $handle, ">", $filename)
        or die "Cannot open $filename: $!\n";
        print $handle "The Start\n";
        bless {FH => $handle, VALUE  => 0}, $class;
}

sub FETCH {
        my $self = shift;
        return $self->{VALUE};
}

sub STORE{
        my $self = shift;
        my $value = shift;
        my $handle = $self->{FH};
        print $handle "$value\n";
        $self->{VALUE} = $value;
}

sub DESTROY {
        my $self = shift;
        my $handle = $self->{FH};
        print $handle "The End\n";
        close $handle;
}

1;

use strict;
use Remember;

my $fred;
$x = tie $fred, "Remember", "camel.log";
$fred = 1;
$fred = 4;
$fred = 5;
untie $fred;
system "cat camel.log";

sub comment {
        my $self = shift;
        my $message = shift;
        print {$self->{FH}} $handle $message, "\n";
}

use strict;
use Remember;

my ($fred, $x);
$x = tie $fred, "Remember", "camel.log";
$fred = 1;
$fred = 4;
comment $x "changing...";
$fred = 5;
untie $fred;
system "cat camel.log";