Вернуть объект базового класса из объекта производного класса

Question

Я знаю, что Perl не является статически типизированным, когда я хочу применить этот механизм к Perl объекту производного класса:

Скажем, у меня есть базовый класс B и производный класс D наследуется от B. Также у меня есть объект $obj, который содержит D объект. Функция Bf() ожидает параметр типа B.

Очевидно (по правилам полиморфизма) я могу передать $obj в Bf() как Bf($obj), но в отличие от состояния c -типированный язык Bf() увидит весь объект D (а не только элементы B).

Есть ли (довольно чистое и простое) решение этой проблемы в Perl? Решение должно «скрывать» атрибуты (и методы), которые B не имеет от D в Bf(), не ограничивая модификации оригинального B (что на самом деле D).

Только для взрослых программистов (добавлено 2020-03-06)

Хорошо, люди хотели более конкретного описания. К сожалению (как указывалось), исходная программа очень сложна и использует отражающие механизмы для автоматической генерации методов получения, установки и форматирования, поскольку я действительно не могу привести здесь минимальный рабочий пример, поскольку она не быть минимальным.

Сначала у меня есть класс MessageHandler, который обрабатывает сообщения (не удивительно!). Тогда у меня есть функция log_message($$$), которая ожидает (среди прочего) объект MessageHandler в качестве первого аргумента.

Тогда у меня есть эта иерархия классов (в реальности она намного сложнее):

MessageHandler
ControlMessageHandler (ISA: MessageHandler)
ControlMessageResponseHandler (ISA: ControlMessageHandler)

Теперь, если log_message хочет MessageHandler, я могу передать ControlMessageResponseHandler, поскольку оно соответствует MessageHandler. Но при этом открываются все атрибуты от ControlMessageResponseHandler до log_message, которых нет в MessageHandler.

Опасность заключается в том, что log_message может (по ошибке) получить доступ к атрибуту ControlMessageResponseHandler этого нет в MessageHandler. Чтобы предотвратить ошибки, я хотел бы предотвратить это или, по крайней мере, получить предупреждение (как если бы я получал статически типизированный язык как Eiffel).

Грязные детали внутри

На всякий случай это важно, я обрисую, как строятся мои объекты массива (для рабочего примера потребуется много дополнительного кода):

Сначала индексы массива распределяются автоматически следующим образом:

use constant I_VERBOSITY    => IS_NEXT->(); # verbosity level
use constant I_TAG          => IS_NEXT->(); # additional tag
use constant I_TAG_STACK    => IS_NEXT->(); # tag stack
use constant I_MSG_DEBUG    => IS_NEXT->(); # handler for debug messages
...
use constant I_LAST         => IS_LAST->(); # last index (must be last)

I_LAST необходим для наследования. Атрибуты определяются следующим образом:

use constant ATTRIBUTES => (
    ['verbosity', I_VERBOSITY, undef],
    ['tag', I_TAG, \&Class::_format_string],
    ['tag_stack', I_TAG_STACK, undef],
    ['msg_debug', I_MSG_DEBUG, \&Class::_format_code],
...
);

Определение содержит подсказку, как форматировать каждый атрибут. Эта информация используется для настройки средств форматирования для форматирования каждого атрибута следующим образом:

use constant FORMATTERS =>
    (map { Class::_attribute_string($_->[0], $_->[1], undef, $_->[2]) }
     ATTRIBUTES);           # attribute formatters

Получатели и установщики автоматически определяются следующим образом:

BEGIN {
    foreach (ATTRIBUTES) {
    Class::_assign_gs_ai(__PACKAGE__, $_->[0], $_->[1]);
    }
}

Конструктор будет использовать следующие строки:

my $self = [];

$#$self = I_LAST;
$self->[I_VERBOSITY] = $verbosity;
...

И, наконец, моя процедура печати объекта выглядит следующим образом:

sub as_string($)
{
    my $self = shift;
    my $a_sep = ', ';

    return join($a_sep, map { $_->($self, $a_sep) } FORMATTERS);
}

С наследованием это выглядит так:

sub as_string($)
{
    my $self = shift;
    my $a_sep = ', ';

    return join($a_sep, $self->SUPER::as_string(),
        map { $_->($self, $a_sep) } FORMATTERS);
}

Answer 1

По какой-то причине ваш D объект должен вести себя как объект B, но в то же время не , как D объект. Как указывают существующие ответы и комментарии, очень распространено использование подкласса, где ожидается базовый класс, и большинству алгоритмов не нужно заботиться о том, что вы фактически передали: D или B. Единственная причина, по которой я могу подумать, почему вы захотите иначе, заключается в том, что D переопределяет (переопределяет) некоторые методы несовместимым способом, и вместо этого вам нужны методы из B.

package Dog;
sub new {
  my ($class, %args) = @_;
  return bless \%args, $class;
}
sub bark { print "Bark!\n"; }

package Dingo;
use parent 'Dog';
sub bark { print "...\n"; }

package main;
my $dingo = Dingo->new;
$dingo->bark; # "..."

(примечание Я остановил рекомендуемые use strict; и use warnings; для краткости, они должны использоваться во всех пакетах)

Возможно, вы прочитали perldoc perlootut и perldoc perlobj, что объект в Perl - это просто bless ред. Ссылка; в приведенном выше примере мы используем ссылку ha sh. Если вы пытаетесь получить «атрибуты», которые существуют только в B, я думаю, вам придется написать какой-то метод перевода. Но, если вам небезразличны методы, существующие в B, все, что вам нужно сделать, это повторно bless передать его в родительский класс.

my $dingo = Dingo->new;
$dingo->bark; # "..."
bless $dingo, "Dog";
$dingo->bark; # "Bark!"

Обратите внимание, что bless не возвращает новая ссылка, но изменяет эту ссылку на месте; если вы хотите, чтобы он снова вел себя как Dingo, вам нужно bless вернуть его назад.

Возможно, вам будет удобнее определить метод, который создаст для вас копию и благословит ее в соответствующем классе:

package Dog;
sub as_dog {
  my ($self) = @_;

  # The {} below create a shallow copy, i.e., a new reference
  return bless { %{$self} }, __PACKAGE__;
}

#...
package main;
my $dingo = Dingo->new;
$dingo->bark; # ...
$dingo->as_dog->bark; # Bark!
$dingo->bark; # ...

Answer 2

Я не уверен, в чем ваша проблема, хотя я думаю, что вы долго говорили: «У меня есть функция, которая ожидает объект B, и я хочу передать ей объект D».

Если вам нужны только объекты определенного точного типа, больше ничего не принимайте:

use Carp qw(croak);
sub Bf {
    croak "Bad object! I only like B" unless ref $_[0] eq 'B';
    ...
    }

Но это плохая идея. Производный класс должен быть таким же хорошим, как и базовый класс. Чистое решение - не заботиться о том, какой тип вы получаете.

sub Bf {
    croak "Bad object! Doesn't respond to foo!" unless $_[0]->can('foo');
    ...
    }

Поскольку этот метод Bf работает с базовым классом, почему он ищет что-то в некотором производном классе, о котором он не знает? Если производный класс изменил интерфейс и больше не действует как родительский, то, возможно, он не подходит для наследования. Есть много подобных проблем, которые решаются с помощью другой архитектуры.

Я думаю, вам нужно будет привести конкретный пример, где производный класс не будет работать.

Answer 3

Хотя кажется, что не существует идеального решения, временное «повторное благословение» объекта, похоже, довольно близко к тому, о чем просят:

sub Bf($) # expects a "B" object (or descendant of "B" (like "D"))
{
    my $B = shift;
    my $type = ref($B);  # save original type

    die "unexpected type $type" unless ($B->isa('B'));
    bless $B, 'B';       # restrict to "B"'s features
    $B->whatever(...);
    #...
    bless $B, $type;     # restore original type
}