Глава 13 Классы, объекты и связи

13.14. Перегрузка операторов

Проблема

Решение

Комментарий

values are Red, Black, RedBlack, and 0
Red is GE Black
Исходный текст класса приведен в примере 13.1.
Пример 13.1. StrNum
package StrNum;
use Exporter ();
@ISA = 'Exporter';
@EXPORT = qw(StrNum); # Необычно
use overload (
'<=>' => \&spaceship, 'cmp' => \&spaceship,
'""'=> \&stringify,
'bool' => \&boolify,
'0+' => \&numify,
'+' => \&concat,
'*' => \&repeat,
);
# Конструктор
sub StrNum($) {
my ($value) = @_; vreturn bless \$value;
}
sub stringify { ${ $_[0] } }
sub numify { ${ $_[0] } }
sub boolify { ${ $_[0] } }
# Наличие <=> дает нам <, == и т. д.
sub spaceship {
my ($s1, $s2, $inverted) = @_;
return $inverted '' $$s2 cmp $$s1 : $$s1 cmp $$s2;
}
# Использует stringify
sub concat {
my ($s1, $s2, $inverted) = @_,
return StrNum $inverted ? ($s2 . $s1) : ($s1 . $s2);
}
# Использует stringify
sub repeat {
my ($s1, $s2, $inverted) = @_;
return StrNum $inverted ? ($s2 x $s1) : ($s1 x $s2):
}
1;

Пример. Перегруженный класс FixNum В этом классе перегрузка оператора позволяет управлять количеством десятичных позиций при выводе. При этом во всех операциях используется полная точность. Метод places () вызывается для класса или конкретного объекта и задает количество выводимых позиций справа от десятичной точки.
#!/usr/bin/perl
# demo_fixnum - show operator overloading
use FixNum;
FixNum->places(5);
$x = FixNum->new(40):
$у = FixNum->new(12);
print "sum of $x and $y is ", $x + $y, "\n";
print "product of $x and $y is ", $x * $y, "\n";
$z = $x / $y;
printf "$z has %d places\n", $z->places;
$z->places(2) unless $z->places;
print "div of $x by $y is $z\n";
print "square of that is ", $z * $z, "\n";
sum of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 52 product of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 480 STRFixNum: 3 has 0 places div of STRFixNum: 40 by STRFixNum: 12 is STRFixNum: 3.33 square of that is STRFixNum: 11.11 Исходный текст класса приведен в примере 13.2. Из математических операции в нем перегружаются только операторы сложения, умножения и деления. Также перегружен оператор <=>, обеспечивающий выполнение всех сравнений, оператор строковой интерполяции и оператор числового преобразования. Оператор строковой интерполяции выглядит необычно, но это было сделано для удобства отладки. Пример. 13.2 FixNum
package FixNum;
use strict;
my $PLACES = 0;
sub new {
my $proto = shift;
my $class = ref($proto) | | $proto;
my $parent = ref($proto) && $proto;
my $v = shift;
my $self = {
VALUE => $v,
PLACES => undef, };
if ($parent && defined $parent->{PLACES}) {
$self->{PLACES} = $parent->{PLACES};
} elsif ($v =~ /(\.\d*)/) {
$self->{PLACES} = length($1) - 1;
} else {
$self->{PLACES} = 0;
} return bless $self, $class;
}
sub places {
my $proto = shift;
my $self = ref($proto) && $proto;
my $type = ref($proto) || $proto:
if (@_) {
my $places = shift;
($self ? $self->{PLACES} : $PLACES) = $places;
} return $self ? $self->{PLACES} : $PLACES:
}
sub _max { $_[0] > $_[1] 7 $_[Q] : $_[1] }
use overload '+' => \&add,
'*'=> \&multiply,
'/' => \?,
'<=>' => \&spaceship,
'""' => \&as_string,
'0+' => \&as_number;
sub add {
my ($this, $that, $flipped) = @_;
my $result = $this->new( $this->{VALUE} + $that->{VALUE} :
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub multiply {
my ($this, $that, $flipped) = @_;
my $result = $this->new( $this->{VALUE} * $that->{VALUE} );
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub divide {
my ($this, $that, $flipped) = @>_;
my $result = $this->new( $this->{VALUE} / $that->{VALUE} );
$result->places( _max($this->{PLACES}, $that->{PLACES} ));
return $result;
}
sub as_string {
my $self = shift;
return sprintf("STR%s: %.*f", ref($self),
defined($self->{PLACES}) ? $self->{PLACES} : $PLACES, $self->{VALUE});
}
sub as_number {
my $self = shift;
return $self->{VALUE};
}
sub spaceship {
my ($this, $that, $flipped) = @>_;
$this->{VALUE} <=> $that->{VALUE};
}
1;

> Смотри также ------------------------------
Документация по стандартной директиве use overload, а также модулям Math::BigInt и Math::Complex.

13.15. Создание "магических" переменных функцией tie

Проблема

Решение

Комментарий

Пример 13.3. ValueRing
package ValueRing;
# Конструктор для связывания скаляров
sub TIESCALAR {
my ($class, ©values) = @>_;
bless \@>values, $class;
return \@values;
}
# Перехватывает чтение
sub FETCH {
my $self = shift;
push(@$self, shirt(@$self));
return $self->[-1];
}
# Перехватывает запись
sub STORE {
my ($self, $value) = @>_;
unshift (S$self, $value;
return $value;
}
1;
Вероятно, такой пример кажется надуманным, но он показывает, как легко со-aTb связь произвольной сложности. Для пользователя $со1ог остается старой доб-)ii переменной, а не объектом. Все волшебство спрятано под связью. При связывании скалярной переменной совсем не обязательно использовать скалярную ссылку; мы использовали ссылку па массив, но вы можете выбрать любой другой вариант. Обычно при связывании любых переменных используется ссылка на nil, поскольку она обеспечивает наиболее гибкое представление объекта.
Для массивов и хэшей возможны и более сложные операции. Связывание манипуляторов появилось лишь в версии 5.004, а до появления версии 5.005 возможности применения связанных массивов были несколько ограничены, но связывание хэшей всегда поддерживалось на высоком уровне. Поскольку полноценная поддержка связанных хэшей требует реализации множества методов объекта, многие пользователи предпочитали наследовать от стандартного модуля Tie::Hash, в котором существуют соответствующие методы по умолчанию.
Ниже приведены некоторые интересные примеры связывания.
Пример связывания. Запрет $_
Этот любопытный связываемый класс подавляет использование неявной переменной $_. Вместо того чтобы подключать его командой use, что приведет к косвенному вызову метода import () класса, воспользуйтесь командой по для вызова редко используемого метода unimport(). Пользователь включает в программу следующую команду: no Underscore;
После этого любые попытки использования нелокализованной глобальной ж -ременной $_ приводят к инициированию исключения.
Рассмотрим применение модуля на небольшом тестовом примере:
#!/usr/bin/perl
# nounder_demo - запрет использования $_ в программе
no Underscore;
@tests = (
"Assignment" => sub { $_ = "Bad" },
"Reading" => sub { print },
"Matching" => sub { $x = /badness/ },
"Chop" => sub { chop },
"Filetest" => sub { -x },
"Nesting" => sub { for (1..3) { print } },
);
while ( ($name, $code) = splice(@>tests, 0, 2) ) {
print "Testing $name: ";
eval { &$code };
print $@ ? "detected" : "missed!";
print "\n";
}
Результат выглядит так: Testing Assignment: detected Testing Reading: detected Testing Matching: detected Testing Chop: detected Testing Filetest: detected Testing Nesting: 123missed! В последнем случае обращение к переменной не было перехвачено, поскольку она была локализована в цикле for.
Исходный текст модуля Underscore приведен в примере 13.4. Обратите внимание, каким маленьким он получился. Функция tie вызывается модулем в инициализирующем коде. Пример 13.4. Underscore
package Underscore;
use Carp;
sub TIESCALAR {
my $class = shift;
my $dummy;
return bless \$dummy => $class;
}
sub FETCH { croak "Read access to \$_ forbidden" }
sub STORE { croak "Write access to \$_ forbidden" }
sub unimport { tie($_, __PACKAGE__) }
sub import { untie $_ }
tie($_, __PACKAGE__) unless tied $_;
1;
Чередование вызовов use и по для этого класса в программе не принесет никакой пользы, поскольку они обрабатываются во время компиляции, а не во время выполнения. Чтобы снова воспользоваться переменной $_, локализуйте ее. Пример связывания. Хэш с автоматическим дополнением
Следующий класс создает хэш, который автоматически накапливает повторяющиеся ключи в массиве вместо их замены. v
#!/usr/bin/perl
# appendhash_demo - хэш с автоматическим дополнением
use Tie::AppendHash;
tie %tab, 'Tie::AppendHash';
$tab{beer} = "guinness";
$tab{food} = "potatoes";
$tab{food} = "peas";
while (my($k, $v) = each %tab) { print "$k => [@$v]\n";
}
Результат выглядит так:
food => [potatoes peas] beer => [guinness]
Простоты ради мы воспользовались шаблоном модуля для связывания хэша, входящим в стандартную поставку (см. пример 13.5). Для этого мы загружаем модуль Tie::Hash и затем наследуем от класса Tie::StdHash (да, это действительно разные имена - файл Tie/Hash.pm содержит классы Tie::Hash и Tie::StdHash, несколько отличающиеся друг от друга). Пример 13.5. Tie::AppendHash
package Tie::AppendHash;
use strict;
use Tie::Hash;
use Carp;
use vars qw(@ISA);
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
push @){$self->{key}}, $value;
} 1;
Пример связывания. Хэш без учета регистра символов Ниже приведен другой, более хитроумный пример связываемого хэша. На этот р;и хэш автоматически преобразует ключи к нижнему регистру.
#!/usr/bin/perl
# folded_demo - хэш с автоматическим преобразованием регистра
use Tie::Folded;
tie %tab, 'Tie::Folded';
$tab{VILLAIN} = "big ";
$tab{her0ine} = "red riding hood";
$tab{villain} = "bad wolf";
while ( my($k, $v) = each %tab ) { print "$k is $v\n";
}
Результат демонстрационной программы выглядит так: heroine is red riding hood villain is big bad wolf Поскольку на этот раз перехватывается большее количество обращении, из примера 13.6 получился более сложным, чем в примере 13.5. Пример 13.6. Tie: :Folded
package Tie::Folded;
use strict;
use Tie::Hash;
use vars qw(@ISA);
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @>_;
return $self->{lc $key} = $value;
} sub FETCH {
my ($self, $key) = @_;
return $self->{lc $key};
} sub EXISTS {
my ($self, $key) = @_;
return exists $self->{lc $key};
} sub DEFINED {
my ($self, $key) = @_;
return defined $self->{lc $key};
}
1;
Пример. Хэш с возможностью поиска по ключу и по значению Следующий хэш позволяет искать элементы как по ключу, так и по значению. Для этого метод STORE заносит в хэш не только значение по ключу, но и обратную пару - ключ по значению. Если сохраняемое значение представляет собой ссылку, возникают затруднения, поскольку обычно ссылка не может использоваться в качестве ключа хэша. Проблема решается классом Tie::RefHash, входящим в стандартную поставку. Мы унаследуем от него.
#!/usr/bin/perl -w
# revhash_demo - хэш с возможностью поиска по ключу *или* по значению
use strict;
use Tie::RevHash;
my %tab;
tie %tab, 'Tie::RevHash';
%tab = qw{
Red Rojo
Blue Azul
Green Verde };
$tab{EVIL} = [ "No way!", "Way!!" ];
while ( my($k, $v) = each %tab ) {
print ref($k) ? "[@$k]" : $k, " => ", ref($v) ? "[@$v]" : $v, "\n":
}
При запуске программа revhash_demo выдает следующий результат:
[No way! Way! ! ] = EVIL>
EVIL => [No way! Way!!]
Blue => Azul
Green => Verde
Rojo => Red
Red => Rojo
Azul => Blue
Verde => Green
Исходный текст модуля приведен в примере 13.7. Оцените размеры!
package Tie::RevHash;
use Tie::RefHash;
use vars qw(@ISA);
@ISA = qw(Tie::RefHash);
sub STORE {
my ($self, $key, $value) = @_;
$self->SUPER::STORE($key, $value);
$self->SUPER::STORE($value, $key);
}
sub DELETE {
my ($self, $key) = @_;
my $value = $self->SUPER::FETCH($key) $self->SUPER::DELETE($key);
$self->SUPER::DELETE($value);
}
1;
Пример связывания. Манипулятор с подсчетом обращений
Пример связывания для файлового манипулятора выглядит так:
use Counter;
tie *CH, 'Counter';
while () {
print "Got $_\n";
}
При запуске эта программа выводит Got 1, Got 2 и так далее - пока вы не прервете ее, не перезагрузите компьютер или не наступит конец света (все зависит от того, что случится раньше). Простейшая реализация приведена в примере 13.8. Пример 13.8. Counter
package Counter;
sub TIEHANDLE {
my $class = shift;
my $start = shift;
return bless \$start => $class;
} sub READLINE {
my $self = shift;
return ++$$self;
}
1;
Пример связывания. Дублирование вывода по нескольким манипуляторам Напоследок мы рассмотрим пример связанного манипулятора, который обладает tee-подобными возможностями - он объединяет STDOUT и STDERR:
use Tie::Tee;
tie *TEE, 'Tie::Tee', *STDOUT, *STDERR;
print TEE "This line goes both places.\n";
Или более подробно:
#!/usr/bin/perl
# demo_tietee
use Tie::Tee;
use Symbol;
(Shandies = (*STDOUT);
for $i ( 1 .. 10 ) {
push(@ihandles, $handle = gensym());
open($handle, ">/tmp/teetest.$i");
}
tie *TEE, 'Tie: :Tee', @>handles;
print TEE "This lines goes many places.\n";
Содержимое файла Tie/Tee.pm показано в примере 13.9.
Пример 13.9. Tie: :Tee
package Tie::Tee;
sub TIEHANDLE {
my $class = shift;
my $handles = [@_];
bless $handles, $class;
return $handles
};
SUB PRINT 1
my $nrer = smrr;
my $handle;
my $success = 0;
foreach $handle (@$href) {
$success += print $handle @_
}
return $success == @$href
}
1

> Смотри также
Функция tie описана в perlfunc(1) perltie(1). 

© copyright 2000 Soft group