[Melbourne-pm] overloading 'print'
Mathew Robertson
mathew.robertson at netratings.com.au
Tue Mar 21 14:56:56 PST 2006
Hi folks,
I asked the question of how to overload 'print' - here are the relevant
parts of the implementation, for those that my be interested:
package MyPrint;
use strict;
use warnings;
use Symbol;
use Exporter;
use base qw(Exporter);
our $STDOUT;
our $filehandle;
our $print = 1;
our $println = 1;
our $this;
# Install a println handler to handle println'ing to a filehandle or STDOUT
sub IO::Handle::println { my $FH = shift; print $FH (@_,$/); }
sub main::println { CORE::print (@_,$/); }
sub import {
my $class = shift;
my $caller = caller;
my $sym = gensym;
$STDOUT = select unless (defined $STDOUT);
my %options;
get_options('use',\%options, at _) if @_;
$filehandle = (@_ > 0) ? shift : (defined $filehandle ? $filehandle :
$STDOUT);
die "Invalid filehandle specification" unless (defined $filehandle);
$this = tie *$sym, $class, $filehandle;
bless $sym, $class;
if ($print) { select $sym; }
if ($println) { no strict 'refs'; *{$caller."::println"} =
\&{$class."::LM_println"}; }
return $class;
}
sub unimport {
my $class = shift;
my $caller = caller;
if ($print) { select $STDOUT; }
if ($println) { no strict 'refs'; *{$caller."::println"} =
\&{$class."::CORE_println"}; }
return $class;
}
sub TIEHANDLE {
my $class = shift;
my $self = bless {}, $class;
if (@_ > 0) {
$self->{fh} = shift or die "No filehandle specified in constructor.";
} else {
$self->{fh} = select;
}
return $self;
}
sub PRINT {
my $self = shift;
my $fh = *{ $self->{fh} };
CORE::print $fh (mp(@_));
}
sub PRINTLN {
my $self = shift;
my $fh = *{ $self->{fh} };
CORE::print $fh (mp(@_).$/);
}
no warnings 'once';
*new = *TIEHANDLE;
*print = *PRINT;
*println = *PRINTLN;
use warnings 'once';
sub CORE_println { CORE::print $STDOUT @_,$/; }
sub LM_println { PRINTLN $this, @_; }
sub mp { ...do funky stuff... }
1;
Thanks for all the suggestions,
Mathew
More information about the Melbourne-pm
mailing list