Если вы собираетесь заняться разбором HTML или XML, то класс Perl, который мы разработаем в этой статье, может помочь вам в этом деле.

Не буду здесь грузить про то, зачем нужно грабить и парсить. Остановимся на том, что у нас есть текст, который очень похож на XML. И нам нужно его быстро и грамотно распарсить.

Постановка задачи

Написать класс, предназначенный для выполнения типовых задач, встающих при разборе xml-подбных текстов.

Почему я говорю xml-подобных? Ну, если вы хоть раз пробовали парсить текст html-странички с помощью методов DOM, то вы, наверняка упирались в то, что далеко не каждая html-страничка — это правильный DOM-документ. Банальный пример — незакрытые теги <p>.

Поэтому, нужно дать возможность передавать нужный кусок текста в качестве скаляра, в котором будут искаться нужные куски, с оглядкой на то, что это все-таки должно быть похоже на xml. Посему, нарекаю этот класс LlXMLParser (Look like XML Parser).

Будущий класс должен уметь:

• собирать все теги, с заданным именем
• собирать содержимое всех тегов, с заданным именем
• собирать значения атрибута, с заданным именем
• собирать все атрибуты тега, с заданным именем

Синопсис

my $llxml = new SHA::XMLParser;
my @p = $llxml->tag_collect($page, 'p');
my $img_srcs = $llxml->get_atrib('src');
$llxml->debug(1);
print $llxml->tag_contents($page, 'body');

Классы в "Perl

В Perl, классы — это всего лишь пакеты. А объекты — это ссылки. Поля объекта хранятся в обычном хэше. Подробнее об ООП в Perl можно почитать в мануалах.

Реализация

Конструктор

sub new {
    my $class = shift;
    my %parser;
    bless \%parser, $class;
    return \%parser;
}

Простой конструктор. Возвращает ссылку, "благословленную" в пакет.

Режим дебага

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

#on-off debug mode
sub debug    {
    my $self = shift;
    my $val = shift;
    $self->{debug} = ($val) ? 1:0;
}

Режим дебага будет заключаться в том, чтобы возвращать не просто значения, а оптимизированные для вывода на экран и отладки. Для этого нам потребуется метод, преобразующий обычный кусок xml в xml, приготовленный для вывода на экран.

sub _htmlchars    {
    my $val = shift;
    $$val =~ s/&/&/g;
    $$val =~ s/</&lt;/g;
    $$val =~ s/>/&gt;/g;
    $$val =~ s/\t/&nbsp;&nbsp;&nbsp;&nbsp;/g;    #делаем отступы
    $$val =~ s/[\n\r]/<br\/>/g;
    $$val =~ s/ /&nbsp;/g;
    return $$val;
}

Функция принимает ссылку на скаляр и модифицирует его.

Сбор тегов

sub tag_collect {
  my ($self, $text, $tag, $trash) = @_;
  $tag =~ s/[< >]//g; #если имя тега пришло в виде <tag>, чистим <>
  my @result;
  #здесь немного магии
  while($text =~ /(<\s*$tag.*?<\/\s*$tag\s*>)/sig)  {
  my $val = $1;
  if($self->{debug}) {_htmlchars(\$val)}  #дебаг
  push @result, $val;
  }
  return @result; #здесь удобнее возвращать массив элементов
}

Этот метод принимает текст для парсинга и имя тега. Затем, он ищет в тексте заданный тег. Предполагается, что это — тег-контейнер. Если это одиночный тег, то его атрибуты будем получать по-другому.

Получение всех атрибутов тега

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

sub tag_atribs {
  my ($self, $text, $tag, $t) = @_;
  $tag =~ s/[< >]//g;
  my @result;
  while($text =~ /<$tag(.*?)>/igs)  {
  push @result, $1;
  }
  return \@result;  #возвращаем ссылку
}

Получим ссылку на все атрибуты тегов, с заданным именем.

Сбор содержимого тега

Допустим, хотим получить содержимое всех абзацев. Причем, без самих кодов абзацев. Можно воспользоваться методом tag_contents.

sub tag_contents {
  my ($self, $text, $tag, $t) = @_;
  $tag =~ s/[< >]//g;
  my @result;
  while($text =~ /<$tag.*?>(.*?)<\/\s*$tag>/gis)  {
  my $val = $1;
  if($self->{debug})  {_htmlchars(\$val)}
  push @result, $val;
  }
  return \@result;  #возвращаем ссылку
}

Сбор значений конкретного атрибута

Допустим, хотим собрать все ссылки на картинки со страницы. Нам понадобятся значения атрибута src. Вот метод, который позволит быстро сделать то, что мы задумали.

sub get_atrib  {
  my($self, $text, $atr, $t) = @_;
  my @result;
  push @result, $2 while($text =~ /$atr\s*="\s*('|")?(.*?)(?:\"1|>|=)/ig); #'
  return \@result;
}

Собственно, получим ссылку на массив значений нашего атрибута.

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

sub has_text  {
  my($self, $text, $check, $result) = @_;
  $result = 0;
  $result++ while($text =~ /$check/g);
  return $result;
}

Заключение

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

По сути, это даже не класс, а библиотека. Ведь нам вряд ли потребуется более одного объекта данного класса из-за того, что мы не зашиваем текст в объект, а каждый раз передаем кусочек, при вызове методов. ООП здесь нужно лишь для того, чтобы избежать конфликтов имен. Кроме того, это улучшает переносимость библиотеки.

TODO

Возможно в последствии, добавлю методы для обрезки и вырезки чего-либо. Так же было бы неплохо видеть тут методы для поиска и замены.

Бывают еще, задачи очистки кода. Например, типовая задача — удаление всех атрибутов (кроме важных типа src) во всех тегах.

Думал так же, о рекурсивном поиске вложенных тегов, но решил, что это не имеет смысла, ибо исходный текст всего лишь похож на xml.

Вот такие пироги. Пользуйтесь на здоровье.

А если вы хотите парсить XML или сайты профессионально - можете обратиться ко мне и я вам в этом помогу. Возможно даже бесплатно;)