[ Pobierz całość w formacie PDF ]
.Example 9.3: Monitor.pm #----------------------------------------------------------------------package Monitor;require Exporter;@ISA = ("Exporter");@EXPORT = qw(monitor unmonitor);use strict;sub monitor {my ($r_var, $name) = @_;my ($type) = ref($r_var);if ($type =~ /SCALAR/) {return tie $$r_var, 'Monitor::Scalar', $r_var, $name;} elsif ($type =~ /ARRAY/) {return tie @$r_var, 'Monitor::Array', $r_var, $name;} elsif ($type =~ /HASH/) {return tie %$r_var, 'Monitor::Hash', $r_var, $name;} else {print STDERR "require ref.to scalar, array or hash" unless $type;}}sub unmonitor {my ($r_var) = @_;my ($type) = ref($r_var);my $obj;if ($type =~ /SCALAR/) {Monitor::Scalar->unmonitor($r_var);} elsif ($type =~ /ARRAY/) {Monitor::Array->unmonitor($r_var);} elsif ($type =~ /HASH/) {Monitor::Hash->unmonitor($r_var);} else {print STDERR "require ref.to scalar, array or hash" unless $type;}}#------------------------------------------------------------------------package Monitor::Scalar;sub TIESCALAR {my ($pkg, $rval, $name) = @_;my $obj = [$name, $$rval];bless $obj, $pkg;return $obj;}sub FETCH {my ($obj) = @_;my $val = $obj->[1]; print STDERR 'Read $', $obj->[0], ".$val \n";return $val;}sub STORE {my ($obj, $val) = @_;print STDERR 'Wrote $', $obj->[0], ".$val \n";$obj->[1] = $val;return $val;}sub unmonitor {my ($pkg, $r_var) = @_;my $val;{my $obj = tied $$r_var;$val = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie $$r_var;$$r_var = $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died $', $obj->[0];}}#------------------------------------------------------------------------package Monitor::Array;sub TIEARRAY {my ($pkg, $rarray, $name) = @_;my $obj = [$name, [@$rarray]];bless $obj, $pkg;return $obj;}sub FETCH {my ($obj, $index) = @_;my $val = $obj->[1]->[$index];print STDERR 'Read $', $obj->[0], "[$index].$val\n";return $val;}sub STORE {my ($obj, $index, $val) = @_; print STDERR 'Wrote $', $obj->[0], "[$index].$val\n";$obj->[1]->[$index] = $val;return $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died %', $obj->[0];}}sub unmonitor {my ($pkg, $r_var) = @_;my $r_array;{my $obj = tied @$r_var;$r_array = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie @$r_var;@$r_var = @$r_array;}#------------------------------------------------------------------------package Monitor::Hash;sub TIEHASH {my ($pkg, $rhash, $name) = @_;my $obj = [$name, {%$rhash}];return (bless $obj, $pkg);}sub CLEAR {my ($obj) = @_;print STDERR 'Cleared %', $obj->[0], "\n";}sub FETCH {my ($obj, $index) = @_;my $val = $obj->[1]->{$index};print STDERR 'Read $', $obj->[0], "{$index}.$val\n";return $val;}sub STORE {my ($obj, $index, $val) = @_;print STDERR 'Wrote $', $obj->[0], "{$index}.$val\n"; $obj->[1]->{$index} = $val;return $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died %', $obj->[0];}}sub unmonitor {my ($pkg, $r_var) = @_;my $r_hash;{my $obj = tied %$r_var;$r_hash = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie %$r_var;%$r_var = %$r_hash;}1;unmonitor is slightly tricky.We want to do an untie, but Perl restores the variable's value to that held by itjust before tie was invoked.Clearly, this is undesirable.We want this operation to go on without thevariable's user being affected in any way.Since we have the variable's current value as an attribute of the tiedobject, we can attempt to restore the value after the untie.Unfortunately, the following code doesn't quitework:# For a tied scalarmy $obj = tied $$r_var; # Get the object tied to the variable$latest_value = $obj->[1]; # Extract the latest valueuntie $$r_var; # untie$$r_var = $latest_value; # Restore the variable to the latest# valuePerl complains, "Can't untie: 1 inner references still exist." if the -w flag is turned on.The problem is thatthe local variable $obj bumps up the reference count of the tied object, so an untie is not able to DESTROYthe tied object.The solution is fairly straightforward: extract the value in an inner block and let $obj go outof scope, like this:my $latest_value;{my $obj = tied $$r_var;$latest_value = $obj->[1]; # Extract the latest value.# Note that $latest_value is defined# outside this inner block}# $obj is no longer in scope, so we can peacefully untie. untie $$r_var;$$r_var = $latest_value;Previous: 9.4 Tying Advanced Perl Next: 9.6 Comparisons withFilehandles Programming Other Languages9.4 Tying Filehandles 9 [ Pobierz całość w formacie PDF ]
zanotowane.pl doc.pisz.pl pdf.pisz.pl odbijak.htw.pl
.Example 9.3: Monitor.pm #----------------------------------------------------------------------package Monitor;require Exporter;@ISA = ("Exporter");@EXPORT = qw(monitor unmonitor);use strict;sub monitor {my ($r_var, $name) = @_;my ($type) = ref($r_var);if ($type =~ /SCALAR/) {return tie $$r_var, 'Monitor::Scalar', $r_var, $name;} elsif ($type =~ /ARRAY/) {return tie @$r_var, 'Monitor::Array', $r_var, $name;} elsif ($type =~ /HASH/) {return tie %$r_var, 'Monitor::Hash', $r_var, $name;} else {print STDERR "require ref.to scalar, array or hash" unless $type;}}sub unmonitor {my ($r_var) = @_;my ($type) = ref($r_var);my $obj;if ($type =~ /SCALAR/) {Monitor::Scalar->unmonitor($r_var);} elsif ($type =~ /ARRAY/) {Monitor::Array->unmonitor($r_var);} elsif ($type =~ /HASH/) {Monitor::Hash->unmonitor($r_var);} else {print STDERR "require ref.to scalar, array or hash" unless $type;}}#------------------------------------------------------------------------package Monitor::Scalar;sub TIESCALAR {my ($pkg, $rval, $name) = @_;my $obj = [$name, $$rval];bless $obj, $pkg;return $obj;}sub FETCH {my ($obj) = @_;my $val = $obj->[1]; print STDERR 'Read $', $obj->[0], ".$val \n";return $val;}sub STORE {my ($obj, $val) = @_;print STDERR 'Wrote $', $obj->[0], ".$val \n";$obj->[1] = $val;return $val;}sub unmonitor {my ($pkg, $r_var) = @_;my $val;{my $obj = tied $$r_var;$val = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie $$r_var;$$r_var = $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died $', $obj->[0];}}#------------------------------------------------------------------------package Monitor::Array;sub TIEARRAY {my ($pkg, $rarray, $name) = @_;my $obj = [$name, [@$rarray]];bless $obj, $pkg;return $obj;}sub FETCH {my ($obj, $index) = @_;my $val = $obj->[1]->[$index];print STDERR 'Read $', $obj->[0], "[$index].$val\n";return $val;}sub STORE {my ($obj, $index, $val) = @_; print STDERR 'Wrote $', $obj->[0], "[$index].$val\n";$obj->[1]->[$index] = $val;return $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died %', $obj->[0];}}sub unmonitor {my ($pkg, $r_var) = @_;my $r_array;{my $obj = tied @$r_var;$r_array = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie @$r_var;@$r_var = @$r_array;}#------------------------------------------------------------------------package Monitor::Hash;sub TIEHASH {my ($pkg, $rhash, $name) = @_;my $obj = [$name, {%$rhash}];return (bless $obj, $pkg);}sub CLEAR {my ($obj) = @_;print STDERR 'Cleared %', $obj->[0], "\n";}sub FETCH {my ($obj, $index) = @_;my $val = $obj->[1]->{$index};print STDERR 'Read $', $obj->[0], "{$index}.$val\n";return $val;}sub STORE {my ($obj, $index, $val) = @_;print STDERR 'Wrote $', $obj->[0], "{$index}.$val\n"; $obj->[1]->{$index} = $val;return $val;}sub DESTROY {my ($obj) = @_;if ($obj->[0] ne '_UNMONITORED_') {print STDERR 'Died %', $obj->[0];}}sub unmonitor {my ($pkg, $r_var) = @_;my $r_hash;{my $obj = tied %$r_var;$r_hash = $obj->[1];$obj->[0] = "_UNMONITORED_";}untie %$r_var;%$r_var = %$r_hash;}1;unmonitor is slightly tricky.We want to do an untie, but Perl restores the variable's value to that held by itjust before tie was invoked.Clearly, this is undesirable.We want this operation to go on without thevariable's user being affected in any way.Since we have the variable's current value as an attribute of the tiedobject, we can attempt to restore the value after the untie.Unfortunately, the following code doesn't quitework:# For a tied scalarmy $obj = tied $$r_var; # Get the object tied to the variable$latest_value = $obj->[1]; # Extract the latest valueuntie $$r_var; # untie$$r_var = $latest_value; # Restore the variable to the latest# valuePerl complains, "Can't untie: 1 inner references still exist." if the -w flag is turned on.The problem is thatthe local variable $obj bumps up the reference count of the tied object, so an untie is not able to DESTROYthe tied object.The solution is fairly straightforward: extract the value in an inner block and let $obj go outof scope, like this:my $latest_value;{my $obj = tied $$r_var;$latest_value = $obj->[1]; # Extract the latest value.# Note that $latest_value is defined# outside this inner block}# $obj is no longer in scope, so we can peacefully untie. untie $$r_var;$$r_var = $latest_value;Previous: 9.4 Tying Advanced Perl Next: 9.6 Comparisons withFilehandles Programming Other Languages9.4 Tying Filehandles 9 [ Pobierz całość w formacie PDF ]