Изменение поведения хэша с использованием функции tie

FETCH

STORE

DELETE

CLEAR

EXISTS

FIRSTKEY

NEXTKEY

UNTIE

DESTROY

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

Первый пример: Tie::Hash::FixedKeys

Давайте посмотрим на реализацию модуля Tie::Hash::FixedKeys. Данный модуль доступен на CPAN ( http://cpan.org ), если вы хотите ознакомиться с ним более подробно.

Написание модуля существенно упрощается, если мы будем использовать существующий модуль Tie::StdHash. Это – связанный хэш, который имитирует поведение обычного хэша. Данный модуль находится внутри Tie::Hash. Попросту говоря, это означает то, что если вы пишите код, как в следующем примере, то имеете связанный хэш, ведущий себя как обычный хэш.

    use Tie::Hash;

    my %hash;

    tie %hash, 'Tie::StdHash';

Отлично. Но если честно, то многого мы пока не добились. Хэш %hash теперь связанный объект, но мы пока ничего не изменили в его функциональности. Tie::StdHash работает гораздо лучше в качестве базового класса, от которого объекты наследуют своё поведение. Например, начало класса Tie::Hash::FixedKeys выглядит так:

    package Tie::Hash::FixedKeys;

    use strict;

    use Tie::Hash;

    use Carp;

    use vars qw(@ISA);

    @ISA = qw(Tie::StdHash);

Это стандартное начало для объектов Perl, но заметьте, что мы загрузили модуль Tie::Hash (используя use Tie::Hash) и «сказали» нашему модулю наследовать поведение от Tie::StdHash, добавив в его @ISA.

Если бы мы остановились на достигнутом, то наш Tie::Hash::FixedKeys имел бы одинаковое поведение с обычным хэшем Perl. Это является следствием того, что каждый раз, когда Perl пытается найти стандартные методы tie (такие как FETCH или STORE) в нашем модуле, он терпит неудачу и вызывает методы из родительского класса, т.е. из Tie::StdHash.

Начиная с этого момента, мы можем начать менять обычное поведение хэша, путём переопределения методов, которые бы мы хотели изменить. Начнём с реализации изменённого метода TIEHASH.

    sub TIEHASH {

      my $class = shift;

      my %hash;

      @hash{@_} = (undef) x @_;

      bless %hash, $class;

    }

Функция TIEHASH передаёт имя класса в качестве первого параметра, мы внесём его в переменную $class. Остальными параметрами, переданными в @_, можно располагать как угодно, в данном случае мы использовали их как ключи в хэше. Таким образом, мы взяли список ключей и (используя срез хэша) инициализировали хэш, поставив значением каждого ключа undef. В заключении, мы взяли ссылку на хэш и привели (bless) его к заданному классу, после чего возвратили ссылку.

Однако стоит напомнить об одной тонкости при использовании Tie::StdHash. Для корректного использования стандартного поведения, ваш новый класс обязан основываться на ссылке на хэш, и этот хэш обязан содержать только реальные данные. Мы не можем, к примеру, выдумать ключ с названием _keys, который бы содержал список правильных названий ключей и выдавал его при вызове пользователем метода keys.

Итак, сейчас мы имеем хэш, со списком фиксированных ключей и этот хэш инициализирован (все значения – undef). Но пока это не спасёт нас от добавления новых ключей, для этого необходимо переписать метод STORE.

    sub STORE {

      my ($self, $key, $val) = @_;

      unless (exists $self->{$key}) {

        croak "invalid key [$key] in hashn";

        return;

      }

      $self->{$key} = $val;

    }

Три следующих параметра передаются методу STORE: ссылка на связанный объект и пара ключ-значение. Нам необходимо предотвратить добавление новых ключей в базовый хэш, этого мы добьёмся проверкой каждого добавляемого значения ключа путём сверки его со списком допустимых (уже существующих) ключей. Отметьте, что наш базовый объект является хэшем, поэтому мы можем проверить существование ключа простым вызовом метода exists. Если ключ не существует, то мы напечатаем ошибку и вернём неизменённый хэш.

Теперь мы защитили хэш от добавления новых ключей, но все ещё остаётся возможность удаления ключа из хэша (и наш новый STORE будет препятствовать добавлению новых ключей, даже тех, которые были только что удалены), поэтому надо переписать и реализацию метода DELETE.

    sub DELETE {

      my ($self, $key) = @_;

      return unless exists $self->{$key};

      my $ret = $self->{$key};

      $self->{$key} = undef;

      return $ret;

    }

Повторяю ещё раз, мы не хотим менять список существующих ключей, поэтому сначала проверяем, существует ли заданный ключ, если нет, то сразу же возвращаем 0. Если же ключ существует, то мы не хотим его удалять, поэтому присваиваем ему значение undef и возвращаем как результат метода старое значение ключа, имитируя работу «настоящей» функции delete. Есть ещё один способ оказать влияние на ключи нашего хэша:

   %hash = ();

Исполнение данной строки приведёт к вызову метода CLEAR. Стандартное поведение этого метода состоит в удалении всех данных из хэша. Необходимо заменить такое поведение на заменяющее все значения ключей на undef, без удаления ключей.

    sub CLEAR {

      my $self = shift;

      $self->{$_} = undef foreach keys %$self;

    }

Это всё, что нам надо было сделать. Остальная необходимая функциональность наследуется автоматически из Tie::StdHash. Вы можете делать выборку значений ключей из хэша как всегда, без написания единой дополнительной строки кода. Встроенные функции вроде like и each работают как с обычным хэшем.

Другой пример: Tie::Hash::Regex

Давайте взглянем на другой пример. Этот модуль был написан в ходе обсуждения на сайте Perlmonks ( http://www.perlmonks.org/ ). Кто-то спросил, возможно, ли проверять соответствие ключей приблизительно. Я предложил, что хэши, которые проверяют совпадения ключей через регулярные выражения могут решить эту проблему и тут же написал черновой вариант такого модуля. Я благодарен Джеффу Пиньяну, который помог мне улучшить работу модуля.

Для изменения поведения нам необходимо переписать следующие методы: FETCH, EXISTS и DELETE. Вот реализация метода FETCH:

  sub FETCH {

    my $self = shift;

    my $key = shift;	

    my $is_re = (ref $key eq 'Regexp');

    return $self->{$key} if !$is_re && exists $self->{$key};

    $key = qr/$key/ unless $is_re;

    /$key/ and return $self->{$_} for keys %$self;

    return;

  }

Зная то, что мы уже изучили по связанным объектам, чрезвычайно просто разобрать предыдущий пример. Сначала мы получили ссылку на связанный объект (это ссылка на хэш) и требуемый ключ. Далее мы проверяем, является ли ключ ссылкой на прекомпилированное регулярное выражение (которые было откомпилировано с помощью qr//). Если ключ не является регулярным выражением, тогда мы проверяем, существует ли такой ключ в хэше. Если существует – мы вернём значение ключа. Если ключ не найден, в таком случае мы предположим, что это регулярное выражение, которое надо искать. Теперь мы компилируем регулярное выражение, если оно ещё не было откомпилировано. Потом мы проверяем каждый ключ на совпадение с заданным регулярным выражением, в случае совпадения мы возвращаем значение соответствующего ключа. Если совпадения не найдены, то возвращается 0.

Здесь вы, должно быть поняли, что было бы совсем неплохо возвращать все совпадения, вместо одного, как если бы мы вызвали метод FETCH в скалярном контексте для каждого подходящего ключа (т.е. получали бы назад список значений). Это отличная идея, но в текущей версии Perl строка $hash{$key} всегда вызывает FETCH в скалярном контексте (а строка @hash{@keys} вызывает FETCH единожды для каждого элемента @keys), поэтому ничего не получится. Чтобы обойти этот подводный риф можно использовать достаточно странную, на первый взгляд, строку – @vals = tied(%hash) - FETCH($pattern) и это сработает с данным модулем из CPAN.

Метод EXISTS использует похожую обработку, но в данном случае необходимо возвращать 1, вместо значения ключа.

  sub EXISTS {

    my $self = shift;

    my $key = shift;

    my $is_re = (ref $key eq 'Regexp');

    return 1 if !$is_re && exists $self->{$key};

    $key = qr/$key/ unless $is_re;

    /$key/ && return 1 for keys %$key;

    return;

  }

Метод DELETE кое-что другое. В данном случае, мы можем удалить все совпадающие пары ключ-значение, что мы и реализуем следующим кодом:

  sub DELETE {

    my $self = shift;

    my $key = shift;

    my $is_re = (ref $key eq 'Regexp');

    return delete $self->{$key} if !$is_re && exists $self->{$key};

    $key = qr/$key/ unless $is_re;

     for (keys %$self) {

      if (/$key/) {

        delete $self->{$_};

      }

    }

  }

Существует ещё один похожий модуль, который доступен на CPAN – Tie::RegexpHash, написанный Робертом Ротенбергом (Robert Rothenberg). Несмотря на то, что модули предназначены для схожих целей, модуль Tie::RegexpHash делает обратную вещь: при сохранении значения в хэше ключ становится регулярным выражением и когда вы смотрите значение ключа, вы получите обратно значение ключа, которое соответствует первому подходящему регулярному выражению-ключу. Интересный факт, но Tie::RegexpHash не основывается на Tie::StdHash и как следствие – имеет значительно больше кода.

Ещё одно добавление на CPAN – Tie::Hash::Approx, написанное Бриаком Пильпре (Briac Pilpre). Модуль решает те же проблемы, что и наш модуль, однако вместо использования регулярных выражений опирается на модуль String::Approx Яркко Хиетаниеми (Jarkko Hietaniemi).

Вместо эпилога: Tie::Hash::Cannabinol

В качестве последнего примера рассмотрим «пьяный» модуль. Этот хэш будет забывать практически всё, что мы будем сдавать ему на хранение. Функции exists лучше тоже не доверять.

    package Tie::Hash::Cannabinol;

    use strict;

    use vars qw(@ISA);

    use Tie::Hash;

    $VERSION = '0.01';

    @ISA = qw(Tie::StdHash);




    sub STORE {

      my ($self, $key, $val) = @_;

      return if rand > .75;

      $self->{$key} = $val;

    }



    sub FETCH {

      my ($self, $key) = @_;

      return if rand > .75;

      return $self->{rand keys %$self};

    }



    sub EXISTS {

      return rand > .5;

    }

Как вы видите, не так уж сложно внести радикальные изменения в поведение хэшей в Perl используя функцию tie и класс Tie::StdHash, в качестве базового. Как я уже сказал в начале статьи – это позволяет с легкостью создавать новые «объекты» без полного перехода к объектной модели программирования.

Причём изменять можно не только поведение хэшей. В стандартном дистрибутиве Perl идут такие модули как Tie::StdArray, Tie::StdHandle и Tie::StdScalar.

Желаю вам удачи с ними.