Приглашаем посетить
13.6. Клонирование объектов
Проблема
Вы хотите написать конструктор, который может вызываться для существующего объекта.
Решение
Начните свой конструктор примерно так:
my $proto = shift;
mу $class = ref($proto) || $proto;
mу $parent = ref($proto) && $proto;
Переменная $class содержит класс, к которому выполняется приведение, а переменная $parent либо равна false, либо ссылается на клонируемый объект.
Комментарий
Иногда требуется создать объект, тип которого совпадает с типом другого, существующего объекта. Вариант:
$ob1 = SomeClass->new();
# Далее
$ob2 = (ref $ob1)->new();
выглядит не очень понятно. Вместо этого хотелось бы иметь конструктор, который может вызываться для класса или существующего объекта. В качестве метода класса он возвращает новый объект, инициализированный по умолчанию, В качестве метода экземпляра он возвращает новый объект, инициализированный данными объекта, для которого он был вызван:
$ob1 = widget->new();
$ob2 = $ob1->new();
Следующая версия new учитывает эти соображения:
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $parent = ref($proto) && $proto;
my $self;
# Проверить, переопределяется ли new из @ISA
if (@ISA && $proto->SUPER::can('new') {
$self = $proto->SUPER: :new((">_);
} else {
$self = {};
bless ($self, $proto);
} bless($self, $class);
$self->{PARENT} = $parent;
$self->{START} = time(); # Инициализировать поля данных
$self->{AGE} = 0;
return $self;
}
Инициализация не сводится к простому копированию данных из объекта-ири-тотппа. Если вы пишете класс связанного списка или бинарного дерева, при вызове в качестве метода экземпляра ваш конструктор может вернуть новый объект, включенный в дерево или список.
> Смотри также -------------------------------
perlobj(1); рецепты 13.1; 13.9; 13.13.
Проблема
Требуется вызвать метод по имени, которое станет известно лишь во время выполнения программы.
Решение
Сохраните имя метода в строковом виде в скалярной переменной и укажите имя переменной там, где обычно указывается имя метода - справа от оператора ->:
$methname = "flicker";
$obj->$methname(10); # Вызывает
$ob->riicker(10);
# Три метода объекта вызываются по именам
foreach $m ( qw(start run stop) ) { $obj->$m();
}
Комментарий
Имя метода не всегда известно на стадии компиляции. Как известно, получить адрес метода нельзя, но можно сохранить его имя. Если имя хранится в скалярной переменной $meth, то для объекта $crystal этот метод вызывается так:
$crystal->$meth().
@methods = qw(name rank serno);
%his_info = map { $_ => $ob->$_() } @methods:
# Эквивалентно:
%his_info = (
'name' => $ob->name(),
'rank' => $ob->rank(),
'serno' => $ob->serno(), );
Если вам никак не обойтись без получения адреса метода, попробуйте переосмыслить свой алгоритм. Например, вместо неправильной записи \$ob->method(), при которой применяется к возвращаемому значению или значениям метода, поступите следующим образом:
my $fnref = sub { $ob->method(@_) };
Когда придет время косвенного вызова этого метода, напишите:
$fnref->(10, "fred");
# это даст правильный вызов метода:
$obj->method(10, "fred");
Такое решение работает даже в том случае, если $ob находится вне области действия и потому является предпочтительным.
Ссылку на код, возвращаемую методом сап() класса UNIVERSAL, вероятно, не следует использовать для косвенного вызова методов. Нельзя быть уверенным в том, что она будет соответствовать правильному методу для объекта произвольного класса.
Например, следующий фрагмент крайне сомнителен:
$obj->can('method_name')->($obj_target, arguments)
vif $obj_target->isa( ref $obj );
Ссылка, возвращаемая can, может и не соответствовать правильному методу для $obj2. Вероятно, разумнее ограничиться проверкой метода сап() в логическом условии.
> Смотри также -------------------------------
perlobj(1); рецепт 11.8.
Проблема
Требуется узнать, является ли объект экземпляром некоторого класса или одной i из его субклассов. Например, надо выяснить, можно ли вызвать для объекта неко торый метод.
Решение
Воспользуйтесь методами специального класса UNIVERSAL:
$obj->isa("HTTP::Message"); # Как метод объекта
HTTP::Response->isa("HTTP::Message"); # Как метод класса
if ($obj->can("method_name")) {....} # Проверка метода
Комментарий
Для нас было бы очень удобно, чтобы все объекты в конечном счете происходили от общего базового класса. Тогда их можно было бы наделить общими методами, не дополняя по отдельности каждый массив @>ISA. В действительности такая возможность существует. Хотя вы этого не видите, но Perl считает, что в конце @ISA находится один дополнительный элемент - пакет с именем NIVERSAL.
В версии 5.003 класс UNIVERSAL не содержал ни одного стандартного метода, но вы могли занести в него все, что считали нужным. Однако в версии 5.004 UNIVERSA1 уже содержит несколько методов. Они встроены непосредственно в двоичный файл Perl и потому на их загрузку не расходуется дополнительное время. К числу стандартных методов относятся isa, can и VERSION. Метод isa сообщает, "является ли" (is а) объект или класс чем-то другим, избавляя вас от необходимости самостоятельно просматривать иерархию:
$has_io = $fd->isa("IO::Handle");
$itza_handle = IO::socket->isa("IO::Handle");
Также существует мнение, что обычно лучше попробовать вызвать метод. Считается, что явные проверки типов вроде показанной выше слишком ограничивают свободу действий.
Метод can вызывается для объекта или класса и сообщает, соответствует ли его строковый аргумент допустимому имени метода для данного класса. Он возвращает ссылку на функцию данного метода:
$his_print_method = $obj->can(' as_string');
Наконец, метод VERSION проверяет, содержит ли класс (или класс объекта) пакетную глобальную переменную $VERSION с достаточно высоким значением:
Some_Module->VERSION(3.0);
$his_vers = $obj->VERSION();
Тем не менее нам обычно не приходится вызывать VERSION самим. Вспомните:
имена функций, записанные в верхнем регистре, означают, что функция вызывается Perl автоматически. В нашем случае это происходит, когда в программе встречается строка вида:
use Some_Module 3.0;
Если вам захочется включить проверку версии в класс Person, описанный выше, юбавьте в файл Person.pm следующий фрагмент:
use vars qw($VERSION);
$VERSION = '1.01';
Затем в пользовательской программе ставится команда use Person 1.01; -это позволяет проверить версию и убедиться в том, что она равна указанной или превышает ее. Помните, что версия не обязана точно совпадать с указанной, а должна быть не меньше ее. Впрочем, в настоящее время параллельная установка нескольких версий одного модуля не поддерживается.
> Смотри также --------------------------------
Документация но стандартному модулю UNIVERSAL. Ключевое слово use описано Qperlfunc(\).
Проблема
Вы не уверены в том, правильно ли вы спроектировали свой класс и может ли он использоваться в наследовании.
Решение
Воспользуйтесь "проверкой пустого субкласса".
Комментарий
Допустим, вы реализовали класс Person с конструктором new и методами аде и name. Тривиальная реализация выглядит так:
package Person;
sub new {
my $class = shift;
my $self = { };
return bless $self, $class;
}
SUD name {
my $.self = shift;
$self->{NAME} = shift if @_;
return $self->{NAME};
} sub age {
my $self = shift;
$self->{AGE} = shift if @_;
return $self->{AGE};
}
Пример использования класса может выглядеть так:
use Person;
my $dude = person->new.();
$dude->name("Jason");
$dude->age(23);
printf "%s is age %d.\n", $dude->name, $dude->age;
Теперь рассмотрим другой класс с именем Employee:
package Employee;
use Person;
@ISA = ("person");
1;
Ничего особенно интересного. Класс всего лишь загружает класс Person и заявляет, что все необходимые методы Employee наследует от Person. Поскольку Employee не имеет собственных методов, он получит от Person все методы.
Мы хотим, чтобы поведение класса Person полностью воспроизводилось в Employee.
Создание подобных пустых классов называется "проверкой пустого субкласса"; иначе говоря, мы создаем производный класс, который не делает ничего, кроме наследования от базового. Если базовый класс спроектирован нормально, то производный класс в точности воспроизведет его поведение. Это означает, что при простой замене имени класса все остальное будет работать:
use Employee;
my $empl = employee->new();
$empl->name("Jason");
$empl->age(23);
printf "%s is age %d.\n",
$empl->name, $empl->age;
Под "нормальным проектированием" имеется в виду использование только двухаргументной формы bless, отказ от прямого доступа к данным класса и отсутствие экспортирования. В определенной выше функции Person:: new() мы проявили необходимую осторожность: в конструкторе используются некоторые пакетные данные, но ссылка на них хранится в самом объекте. Другие методы обращаются к пакетным данным через эту ссылку, поэтому проблем быть не должно.
Но почему мы сказали "функции Person ::new()" - разве это не метод? Дело в том, что метод представляет собой функцию, первый аргумент которой определяет имя класса (пакет) или объект (приведенную ссылку). Person:: new - это функция, которая в конечном счете вызывается методами Person->new и Employee->new. Хотя вызов метода очень похож на вызов функции, они все же отличаются. Если вы начнете путать функции с методами, то очень скоро у вас не останется ничего, кроме неработающих программ. Во-первых, функции отличаются от методов фактическими конвенциями вызова - метод вызывается с дополнительным аргументом. Во-вторых, вызовы функций не поддерживают наследования, а методы - поддерживают.
Если вы привыкнете к вызовам вида:
Вызов метода Вызов функции Person->new()
Person::new("Pcrson") Employee->new()
Person::new("Employee")
$him = person::new(); # НЕВЕРНО
в программе возникнет нетривиальная проблема, поскольку функция не получит ожидаемого аргумента "Person" и не сможет привести его к переданному классу. Еще хуже, если вам захочется вызвать функцию Employee:: new(). Такой функции не существует! Это всего лишь вызов унаследованного метода. Мораль: не вызывайте функции там, где нужно вызывать методы.
> Смотри также --------------------------------
perltoot(1),perlobj(1) и perlbot{1); рецепты 13.1; 13.10.
Проблема
Конструктор переопределяет конструктор суперкласса. Вы хотите вызвать конструктор суперкласса из своего конструктора.
Решение
Используйте специальный класс, SUPER:
sub meth {
my $self = shift;
$self->SUPER::meth():
}
Комментарий
В таких языках, как C++, где конструкторы не выделяют память, а ограничиваются инициализацией объекта, конструкторы базовых классов вызываются автоматически. В таких языках, как Java и Perl, приходится вызывать их самостоятельно.
Для вызова методов конкретного класса используется формулировка $self-SUPER: :meth(). Она представляет собой расширение обычной записи с началом поиска в определенном базовом классе и допустима только в переопределенных методах. Сравните несколько вариантов:
$self->meth(); # Вызвать первый найденный meth
$self->Where::meth(); # Начать поиск с пакета "Where"
$self->SUPER::meth(); # Вызвать переопределенную версию
Вероятно, простым пользователям класса следует ограничиться первым вариантом. Второй вариант возможен, но не рекомендуется. Последний вариант м.',1:ст вызываться только в переопределенном методе.
Переопределяющий конструктор должен вызвать конструктор своего к.чагса SUPER, в котором выполняется выделение памяти и приведение объекта, и ограничиться инициализацией нолей данных. В данном случае код выделения памяти желательно отделять от кода инициализации объекта. Пусть имя начинается с символа подчеркивания - условного обозначения номинально закрытого метода, аналога таблички "Руками не трогать".
sub new {
my $classname = shift; # Какой класс мы конструируем?
my $self = $classname->SUPER::new(@>_);
$self->_init(@_):
return $self; # Вернуть
}
sub _init {
my $self = shift;
$self->{START} = time(); # Инициализировать поля данных
$self->{AGE} = 0;
$self->{EXTRA} = { @_ }; # Прочее
}
И SUPER: : new и _init вызываются со всеми остальными аргументами, что позволяет передавать другие инициализаторы полей:
$obj = widget->new( haircolor => red, freckles => 121 );
Стоит ли сохранять пользовательские параметры в отдельном хэше - решайте сами.
Обратите внимание: SUPER работает только для первого переопределенного метода. Если в массиве @ISA перечислено несколько классов, будет обработан только первый. Ручной перебор @ISA возможен, но, вероятно, не оправдывает затраченных усилий.
my $self = bless {}, $class;
for my $class (@ISA) {
my $meth = $class . "::_init";
$self->$meth(@_) if $class->can("_init");
}
В этом ненадежном фрагменте предполагается, что все суперклассы инициализируют свои объекты не в конструкторе, а в _init. Кроме того, предполагается, что объект реализуется через ссылку на хэш.
> Смотри также -------------------------------
Класс SUPER рассматривается в perltoot( 1) nperlobj(i).
Проблема
Для работы с полями данных объекта нужны методы доступа, а вам не хочется писать повторяющийся код.
Решение
Воспользуйтесь механизмом AUTOLOAD для автоматического построения методов доступа - это позволит обойтись без самостоятельного написания методов при добавлении новых полей данных.
Комментарий
Механизм AUTOLOAD перехватывает вызовы неопределенных методов. Чтобы ограничиться обращениями к полям данных, мы сохраним список допустимых полей в хэше. Метод AUTOLOAD будет проверять, присутствует ли в хэше запрашиваемое поле.
package Person;
use strict;
use Carp;
use vars qw($AUTOLOAD %ok_field);
# Проверка четырех атрибутов
for my $attr ( qw(name age peers parent))
sub AUTOLOAD {
my $self = shift;
my $attr = $autoload;
$attr =~ s/.*:://;
return unless $attr =~ /["a-z]/;
# Пропустить DESTROY и другие
# методы, имена которых
# записаны в верхнем регистре
croak "invalid attribute method:->$attr()" unless $ok_field{$attr};
br>$self->{uc $attr} = shift if @_;
return $self->{uc $attr};
}
sub new{
my $proto=shift;
my $class =ref($proto) || $proto;
my $parent =ref($proto) && $proto;
my $self = {}
bless($self, $class);
$self->parent($parent)
return $self;
}
Класс содержит конструктор new и четыре метода атрибутов: name, age, peers и parent. Модуль используется следующим образом:
use Person;
my ($dad, $kid);
$dad = person->new;
$dad->name("Jason");
$dad->age(23);
Skid = $dad->new;
$kid->name("Rachel");
$kid->age(2);
printf "Kid's parent is %s\n", $kid->parent->name;
Jason
В иерархиях наследования это решение вызывает некоторые затруднения, Предположим, вам понадобился класс Employee, который содержит все атрибуты данных класса Person и еще два атрибута (например, salary и boss). Класс Employee не может определять методы своих атрибутов с помощью унаследова ного варианта Person: : AUTOLOAD - следовательно, каждому классу нужна собстве| ная функция AUTOLOAD. Она проверяет атрибуты данного класса, но вместо вызов croak при отсутствии атрибута вызывает переопределенную версию суперкла
С учетом этого AUTOLOAD может выглядеть так:
sub AUTOLOAD {
my $self = shift;
my $attr = $autoload;
$attr =' s/.*:://;
return if $attr eq 'DESTROY';
if ($ok_field{$attr}) {
$self->{uc $attr} = shift if @i_;
return $self->{uc $attr};
} else {
my $superlor = "super::$attr";
$self->$superlor(@_);
}
}
Если атрибут отсутствует в списке, мы передаем его суперклассу, надеясь, что он справится с его обработкой. Однако такой вариант AUTOLOAD наследовать нельзя;
каждый класс должен иметь собственную версию, поскольку работа с данными осуществляется напрямую, а не через объект.
Еще худшая ситуация возникает, если класс А наследует от классов В и С, каждый из которых определяет собственную версию AUTOLOAD - в этом случае при вызове неопределенного метода А будет вызвана функция AUTOLOAD лишь одного из двух родительских классов.
С этими ограничениями можно было бы справиться, но всевозможные заплатки, исправления и обходные пути вскоре начинают громоздиться друг на друге. Для сложных ситуаций существуют более удачные решения.
> Смотри также ------------------------------
Рецепты 10.15; 13.12. Пример использования AUTOLOAD приведен vperltoot{\).
Проблема
Вы хотите унаследовать от существующего класса и дополнить его несколькими новыми методами, но не знаете, какие поля данных используются родительским классом. Как безопасно дополнить хэш объекта новым пространством имен и не ювредить данные предков?
Решение
Снабдите каждое имя поля префиксом, состоящим из имени класса и разделителя, - например, одного или двух подчеркиваний.
Комментарий
В недрах стандартной объектно-ориентированной стратегии Perl спрятана одна неприятная проблема: знание точного представления класса нарушает иллюзию абстракции. Субкласс должен находиться в чрезвычайно близких отношениях со своими базовыми классами.
Давайте сделаем вид, что все мы входим в одну счастливую объектно-ориентированную семью и объекты всегда реализуются с помощью хэшей - мы попросту игнорируем классы, в чьих представлениях используются массивы, и наследуем лишь от классов на основе модели хэша (как показано в perlbot(1), эта проблема решается с помощью агрегирования и делегирования). Но даже с таким предположением наследующий класс не может с абсолютной уверенностью работать с ключами хэша. Даже если мы согласимся ограничиваться методами доступа для работы с атрибутами, значения которых задавались не нами, как узнать, что устанавливаемый нами ключ не используется родительским классом? Представьте себе, что в вашем классе используется поле count, но поле с таким же именем встречается в одном из пра-пра-правнуков. Имя "count (подчеркивание обозначает номинальную закрытость) не поможет, поскольку потомки могут сделать то же самое.
Одно из возможных решений - использовать для атрибутов префиксы, совпадающие с именем пакета. Следовательно, если вы хотите создать поле аде в классе Employee, для обеспечения безопасности можно воспользоваться Employee_age. Метод доступа может выглядеть так:
sub Employee::age {
my $self = shift;
$self->{Employee_age} = shift if @_;
return $self->{Employee_age};
}
Модуль Class::Spirit, описанный в рецепте 13.5, предоставляет еще более радикальное решение. Представьте себе один файл:
package Person;
>
use Class: attributes; # Объясняется ниже
mkattr qw(name age peers parent):
# другой файл:
package Employee;
@ISA = qw(person);
use Class: attributes;
mkattr qw(salary age boss);
Вы обратили внимание на общий атрибут age? Если эти атрибуты должны быть логически раздельными, то мы не сможем использовать $self->{age} даже для текущего объекта внутри модуля! Проблема решается следующей реализацией функции Class::Attributes::mkattr:
package Class:attributes;
use strict;
use Carp;
use Exporter ();
use vars qw(@ISA EXPORT);
@ISA = qw(exporter);
@EXPORT = qw(mkattr);
sub mkattr {
my $hispack = caller();
for my $attr ((a>_) {
my($field, $method);
$method = "${hispack}::$attr";
($field = $method) =~ s/:/_/g;
no strict 'refs';
*$method = sub {
my $self = shift;
confess "too many arguments" if @_ > 1 $self->{$field} = shift if @_;
return $self->{$field};
};
}
}
1;
В этом случае $self->{Person_age} и $self->{Employee_age} остаются раздельными. Единственная странность заключается в том, что $obj->age даст лишь первый из двух атрибутов. В принципе атрибуты можно было бы различать с помощью формулировок $obj->Person: :age и $obj->Employee:: age, но грамотно написанный код Perl не должен ссылаться на конкретный пакет с помощью : :, за исключением крайних случаев. Если это оказывается неизбежным, вероятно, ваша библиотека спроектирована не лучшим образом.
Если вам не нравится подобная запись, то внутри класса Person достаточно использовать age($self), и вы всегда получите age класса Person, тогда как в классе Employee age($self) дает версию age класса Employee. Это объясняется тем, что мы вызываем функцию, а не метода.
Смотри также: Документация по директивам use fields и use base для Perl версии 5.005; рецепт 10.14.
Проблема
Имеется структура данных, построенная на циклических ссылках. Система сборки мусора Perl, использующая подсчет ссылок, не заметит, когда данная структура перестает использоваться. Вы хотите предотвратить утечки памяти в программе.
Решение
Создайте не-циклический объект-контейнер, содержащий указатель на структуру данных с циклическими ссылками. Определите для объекта-контейнера метод DESTROY, который вручную уничтожает циклические ссылки.
Комментарий
Многие интересные структуры данных содержат ссылки на самих себя. Например, это может происходить в простейшем коде:
$node->{NEXT-} = $node;
Как только в вашей программе встречается такая команда, возникает цикличность, которая скрывает структуру данных от системы сборки мусора Perl с подсчетом ссылок. В итоге деструкторы будут вызваны при выходе из программы, но иногда ждать долго не хочется.
Связанный список также обладает циклической структурой: каждый узел со держит указатель на следующий узел, указатель на предыдущий узел и значение текущего узла. Если реализовать его на Perl с применением ссылок, появится циклический набор ссылок, которые также не будут автоматически уничтожаться с исчезновением внешних ссылок на узлы.
Проблема не решается и созданием узлов, представляющих собой экземпляры специального класса Ring. На самом деле мы хотим, чтобы данная структура уничтожалась Perl по общим правилам - а это произойдет в том случае, если объект реализуется в виде структуры, содержащей ссылку на цикл. В следующем примере ссылка хранится в поле "DUMMY":
package Ring;
# Вернуть пустую циклическую структуру
sub new {
my $class = shift;
my $node = { };
$node->{NEXT} = $node->{PREV} = $node;
my $self = { dummy => $node, COUNT => 0 };
bless $self, $class;
return $self;
}
Цикличностью обладают узлы кольца, но не сам возвращаемый объект-кольцо Следовательно, следующий фрагмент не вызовет утечек памяти:
use Ring;
$COUNT = 1000;
for (1 ., 20) {
my $r = ring->new();
for ($i =0; $i < $COUNT; $i++) { $r->insert($i) } }
Даже если мы создадим двадцать колец по тысяче узлов, то перед созданием нового кольца старое будет уничтожено. Пользователю класса не придется o"oсс-
покоиться об освобождении памяти в большей степени, чем для простых строк. Иначе говоря, все происходит автоматически, как и должно происходить.
Однако при реализации класса необходимо написать деструктор, который вручную уничтожает узлы:
# При уничтожении Ring уничтожить содержащуюся в нем кольцевую структуру
sub DESTROY {
my $ring = shift;
my $node;
for ( $node = $nng->{DUMMY}->{NEXT};
$node != $ring->{DUMMY}:
$node = $node->{NEXT} ) {
$ring->delete_node($node);
} $node->{PREV} = $node->{NEXT} = undef:
}
# Удалить узел из циклической структуры
sub delete_node {
my ($ring, $node) = @_;
$node->{PREV}->{NEXT} = $node->{NEXT};
$node->{NEXT}->{PREV} = $node->{PREV};
--$ring->{COUNT};
}
Ниже приведено еще несколько методов, которые следовало бы включить в класс. Обратите внимание на то, что вся реальная работа выполняется с помощью циклических ссылок, скрытых внутри объекта:
# $node = $ring->search( $value ) : найти $value в структуре $ring
sub search {
my ($ring, $value) = @_;
my $node = $ring->{DUMMY}->{NEXT};
while ($node != $ring->{DUMMY} && $node->{VALUE} != $value)
{ $node = $node->{NEXT};
}
return $node;
}
# $ring->insert( $value ) : вставить $value в структуру $ring
sub insert_value {
my ($ring, $value) = @_;
my $node = { value => $value };
$node->{NEXT} = $ring->{DUMMY}->{NEXT}:
$ring->{DUMMY}->{NEXT}->{PREV} = $node;
$ring->{DUMMY}->{NEXT} = $node;
$node->{PREV} = $ring->{DUMMY},
++$ring->{COUNT};
}
# $ring->delete_value( $value ) : удалить узел по значению
sub delete_value {
my ($ring, $value) = @_;
my $node = $ring->search($value);
return if $node == $ring->{DUMMY};
$ring->delete_node($node);
}
1;
> Смотри также
Раздел "Garbage Collection" perlobj(1).
