Парсер XML на языке Perl с записью выходного XML файла

Из данной статьи Вы узнаете, как распарсить XML файл, а также создать свой XML файл с необходимой структурой.

Анализатор XML файлов

Отбор необходимых узлов в дереве XML идет при помощи модулей XML::DOM, XML::DOM::Parser и XML::DOM::XPath.
Главное, чем оперируют данные модули это Node – узел. Он может содержать в себе еще узлы, может содержать строку данных, может содержать не строковые (бинарные данные), может быть пустым ( к примеру, <defect></defect>) и т.д.

Основные методы данных модулей это :
getElementsByTagName() – возвращает список нодов с заданным именем, например можно передавать "record-id" и вернеться указатель на массив из найденных узлов с таим именем.
findnodes() - по переданной строке возвращает массив из Nodes, например можно передать более длинную строку "defect/record-id". Если указать в передаваемой строке в начале 2 слеша, например, "//record-id", то поиск узлов с заданным именем будет происходить не вглубь дерева (вниз от текущего), а с самого начала с корневого элемента.
getFirstChild()->getData() – для заданного узла вернет значение, например для <record-id>22</record-id> это значение 22.
getAttributeNode() – возвращает узел-атрибут текущего узла, с именем, которое ему было передано в качестве аргумента.

Пример 1: Узел attachment имеет несколько атрибутов:
<attachment name="sps5.PNG" size="17582" create-date="20100202"/> Если в переменной $node хранится ссылка на узел attachement, то с помощью следующего кода :
my $href = $node->getAttributeNode ("create-date");
my $date =$href->getValue;

В переменную $date запишется значение 20100202.

Пример 2: На основании xml файла перебрать все узлы с именем defect:

<TestTrackData>
<defect>
	<record-id>22</record-id>
</defect>
<defect>
	<record-id>23</record-id>
<defect>
	<record-id>24</record-id>
</defect>
</TestTrackData>

Пример кода, который найдет и переберет все узлы defect:

my $dom_parser = new XML::DOM::Parser;
#Указываем файл для распарсивания
my $doc = $dom_parser->parsefile ("file.xml");
#Получить рутовый(корневой) узел
my $root = $doc->getDocumentElement();
#Вниз от корневого узла найти все узлы с именем defect
my $defects = $doc->getElementsByTagName("defect");
#Работаем с узлами defect
for(my $i=0;  $i < $defects->getLength;$i++){
    my $defect = $defects->item($i);
    …
  }

Создание XML файла заданной структуры

Для создания своих XML документов необходимо подключить модуль XML::Writer.

Основные методы данного модуля:
startTag() – создает узел с именем, переданным в качестве переменной. Функция startTag() обязательно должна заканчиваться endTag(), представляйте это себе как открывающуюся и закрывающуюся скобки.
endTag() – создает закрывающий узел, для текущего узла, к примеру </defect>, можно вызывать без переменной просто $node->endTag() можно для себя, чтобы знать какой блок (узел ) закрываешь указывать имя этого узла $node->endTag("defect").
dataElement() – сразу создает и открывающий и закрывающий блоки, и в качестве переменной можно передать значение элемента.

Пример 1: Создание узла XML документа первым способом
$node->startTag("record-id");
$node->characters("15");
$node->endTag();
Создаст узел:
<record-id>15</record-id>

Пример 2: Создание узла XML документа вторым способом
$node->dataElement("record-id","15");
Создаст точно такой же узел в xml документе:
<record-id>15</record-id>

Пример 3: Создание узла с аттрибутом
$node->dataElement("record-id","15", 'name' => "Record1");
Такой код создаст узел с атрибутом name и значением Record1:
<record-id name="Record1">15</record-id>

Если Вам нужно, какие-то не строковые данные (например jpeg файл) вставить в xml файл, то для этого нужно использовать специальную функцию:
raw() – в которую нужно передать поток перекодированных в бинарный формат данных. Т.е. сам файл сначала подготовить с помощью функции encode_base64 (модуль MIME::Base64). Как делается вставка не строковых данных в xml файл описывается в функциях парсера create_node_attachment и encode_file .

Пример 4: Создание XML-объявления и вставка типа для XML документа
my $writer = new XML::Writer(OUTPUT => "new.xml", UNSAFE =>1);
$writer->xmlDecl('UTF-8','yes');
$writer->doctype('bugzilla',undef,'bugzilla.dtd');

Создает в xml файле следующие строки
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<!DOCTYPE bugzilla SYSTEM "bugzilla.dtd">
<bugzilla version="3.4.2" urlbase="http://localhost/TestTrack/" maintainer="bugzilla@xxxxx.ru" exporter="sokunova@xxxxx.ru">

Примечание: метод doctype($name, [ $publicID, $systemID]) может вызываться либо от одного либо от трех переменных сразу. Если Вам как в примере выше параметр PUBLIC не нужен, то заменяете его значением undef.

Описание работы XML парсера

Ниже представлен код программы, которая читает и анализирует XML формат базы TestTrack и переводит его в необходимый для Bugzilla 3.4.2 формат XML файл. Если происходит перевод из одного формата в другой, как в данном примере, то необходимо сначала составить таблицу, какой узел какому будет соответствовать. В данном примере все узлы <defect> заменяются на <bug>, <defect-number> на <bug_id> и т.д. Если каких-то полей не хватает, то создаются со значениями по-умолчанию (например нулевые), а также некоторые значения приводятся к нужному формату.

Текст программы с комментариями

#!/usr/bin/perl -w
#######################################
## Shpatserman Maria 
#07.02.2010
#
# XML Parser and Creator Bugzilla's xml
#
#######################################
use strict;
use XML::Writer;
use IO::File;
use MIME::Base64 qw(encode_base64);
use XML::DOM;
use XML::DOM::XPath;
use Data::Dumper;
use File::MMagic::XS;
use Getopt::Compact;

### Функция создающая XML узел to_node с данными взятыми из узла from_node
sub create_node{ my( $defect, $writer,$from_node,$to_node) =@_; my @testnodes = $defect->findnodes( $from_node); my $node = $testnodes[0]; my $str =$node->getFirstChild()->getData(); $writer->dataElement($to_node,$str); } ### Функция создания XML узлов с преобразованием времени (creation_ts , delta_ts ...) sub create_node_time{ my( $defect, $writer,$from_node,$to_node) =@_; my @testnodes = $defect->findnodes( $from_node); my $node = $testnodes[0]; ### Прочитали дату в формате "12.02.2010 10:29" my $str =$node->getFirstChild()->getData(); my $Y = substr($str, 6, 4); my $m = substr($str, 3, 2); my $d = substr($str, 0, 2); ### Записали дату в формате "2010-02-12 10:29:28" my $formatdate= "$Y-$m-$d 10:29:28"; $writer->dataElement($to_node,$formatdate); }
### Функция, которая создает XML узел со значением ей переданным в качестве переменной value
sub create_node_value{
  my($writer,$name_node,$value) = @_;
  $writer->dataElement($name_node, $value);
}
### Функция для создания XML узла product с данными из узла from_node
sub create_node_product{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений TesTrack component (исходный XML) => Bugzilla product (XML на выходе)
  my %products = ("\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 1" => "СПб - Продукт 1",
                  "\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 2" => "СПб - Продукт 2",
                  "\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 3" => "СПб - Продукт 3");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  ### Можно воспользоваться функцией Dumper и модулем Data::Dumper, если вдруг на вид две строки равны,
  ### а равенство не срабатывает
  #print Dumper($str);
  my $node_text = $products{$str};
  $writer->dataElement($to_node,$node_text);
}
###Функция создания XML узла version с данными из узла from_node
sub create_node_version{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений TestTrack product => Bugzilla version 
  my %versions = ("\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 1" => "V1",
                  "\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 2" => "V2",
                  "\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 3" => "V3");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  #print Dumper($str);
  my $node_text = $versions{$str};
  $writer->dataElement($to_node,$node_text);
}
### Функция создания XML узла bug_status из узла from_node 
sub create_node_status{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений TestTrack defect-status => Bugzilla bug_status
  my %bug_status = ("Open" => "NEW",
                    "Open (Verify Failed)" => "NEW",
                    "Open (Re-Opened)" => "NEW",
                    "Fixed" => "RESOLVED",
                    "Closed" => "CLOSED",
                    "Closed (Fixed)" => "CLOSED",
                    "Closed (Verified)" => "CLOSED");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  ### Получение статуса ошибки
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  ### Преобразование в нужный для Bugzilla статус ошибки
  my $node_text = $bug_status{$str};
  $writer->dataElement($to_node,$node_text);
  ### Если ошибка исправлена, то еще одно поле добавляем
  if (($node_text eq "RESOLVED")||($node_text eq "CLOSED")) { $writer->dataElement("resolution","FIXED");}

}
### Функция создания XML узла priority из узла from_node
sub create_node_priority{
  my($defect, $writer,$from_node,$to_node) = @_;
  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =''.$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  my $node_text ="";
  ### Заменяем считанное значение эквивалентным для Bugzilla
  if( ($str eq '1') || ($str eq '2')) { $node_text = "В дистрибутив";}
  elsif ($str eq '3') { $node_text = "Срочно";}
  else  { $node_text = "Несрочно";}

  $writer->dataElement($to_node,$node_text);
}

### Вспомогательная функция получения  полного имени и email по фамилии 
sub getname_email_users {
  ### Аргумент - фамилия
  my $user =$_[0];

  my %users=("Sokunova" => ["Сокунова М.А.", 'sokunova@xxxxx.ru'],
             "Ivanov" =>["Иванов Ю.Л.", 'ivanov@xxxxx.ru'],
             "Petrov" => ["Петров И.И.", 'petrov@xxxxx.ru']);

  my $name = $users{$user}[0];
  my $email = $users{$user}[1];
  ### Возвращаем полноем имя и email
  return($name, $email);
}
### Функция создания  XML узла reporter из узла from_node
sub create_node_reporter{
  my($defect, $writer,$from_node,$to_node) = @_;
  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  ### Считали фамилию
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*?)(\s*)/$2/;
  ### Получаем массив из полного имени и email
  my @name_email = &getname_email_users($str);
  ### Создаем узел, в котором значение - полное имя, а аттрибут - email
  $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
}
### Функция создания XML узла qa_contact по фамилии from_str
sub create_node_qacontact{
  my($defect, $writer,$from_str,$to_node) = @_;
  my @name_email = &getname_email_users($from_str);
  $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
}
### Функция создания  XML узла assigned_to из узла from_node
sub create_node_assignedto{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Получить список фамилий на кого назначен баг
  my @testnodes = $defect->findnodes( $from_node);
  ### Если баг ни на кого не назначен - назначить на дефолтного тестера
  if ($#testnodes < 0) {
    my $str ="Sokunova";
    my @name_email = &getname_email_users($str);

    $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
  }
  ### Если баг хоть на кого-то назначен
  else
  { 
    my $node = $testnodes[0];
    my $str =$node->getFirstChild()->getData();
    $str =~ s/(\s*)(.*?)(\s*)/$2/;
    my @name_email = &getname_email_users($str);
    #### Создаем узел assigned_to  с данным  полученными по первой фамилии назначенного 
    $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
    #### Удаляем первый элемент из массива
    shift(@testnodes);
    ### Остальных делаем подписанными на этот баг - создаем узлы сс
    foreach my $node_cc (@testnodes) {
	  $str = $node_cc->getFirstChild()->getData();
	  $str =~ s/(\s*)(.*?)(\s*)/$2/;
	  @name_email = &getname_email_users($str);
	  	
	  $writer->dataElement('cc',$name_email[1]);

    }
  }
}

### Функция создания  XML узла long_desc из узла from_node
sub create_node_longdesc_first{
  my($defect, $writer,$from_node,$to_node) = @_;
  $writer->startTag($to_node, 'isprivate'=>'0');
  ### Определяем значение вложенного узла /found-by/last-name
  my @testnodes =$defect->findnodes( $from_node.'/found-by/last-name');
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*?)(\s*)/$2/;
  my @name_email = &getname_email_users($str);
  ### Создаем узел who с полученным значением 
  $writer->dataElement('who',$name_email[1], 'name' => $name_email[0]);
  ### Определяем значение вложенного узла /date-found
  @testnodes =$defect->findnodes( $from_node.'/date-found');
  $node = $testnodes[0];
  $str =$node->getFirstChild()->getData();
  ### Создаем узел bug_when с полученным значением 
  $writer->dataElement('bug_when',$str);
  ### Определяем значение вложенного узла /description
  @testnodes =$defect->findnodes( $from_node.'/description');
  $node = $testnodes[0];
  $str =$node->getFirstChild()->getData();
  ### Создаем узел thetext с полученным значением 
  $writer->dataElement('thetext',$str);
  $writer->endTag();
}

### Функция создания XML узла long_desc из узла from_node  (обработка узлов комментариев)
sub create_node_longdesc_comments{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Найти все узлы - комментарии
  my $defect_events = $defect->getElementsByTagName( $from_node);
  ### Перебираем все узлы - комментарии
  for(my $i=0;  $i < $defect_events->getLength;$i++){
    my $node = $defect_events->item($i);	
    $writer->startTag($to_node, 'isprivate'=>'0');
    my @sub_nodes = $node->findnodes('event-author/last-name');
    my $sub_node = $sub_nodes[0];
    my $str;
    ### Если Автора нет - присвоить имя дефолтного тестера
    unless((defined($sub_node->getFirstChild())))
    {
      $str= "Sokunova";
    }
    ### Если значение с фамилией автора есть - то счтитать значение
    else
    {
      $str =$sub_node->getFirstChild()->getData();
    }
    $str =~ s/(\s*)(.*?)(\s*)/$2/;
    my @name_email = &getname_email_users($str);
    ### Создать узел who c нужным значением
    $writer->dataElement('who',$name_email[1], 'name' => $name_email[0]);
    
    @sub_nodes = $node->findnodes('event-date');
    $sub_node = $sub_nodes[0];
    $str =$sub_node->getFirstChild()->getData();
    my $Y = substr($str, 6);
    my $m = substr($str, 3, 2);
    my $d = substr($str, 0, 2);
    my $formatdate= "$Y-$m-$d 10:29:28";
    $writer->dataElement('bug_when',$formatdate);
    
    ### Ищем узел комментариев
    @sub_nodes =$node->findnodes('notes');
 
    ### Если комментариев не внесли(например, просто переназначили баг),
    ### то создаем пустой узел thetext
    if($#sub_nodes <0 ) {
	   $writer->startTag('thetext');
	   $writer->endTag('thetext');
    }
    ### Иначе считываем значение и записываем в узел thetext
    else
    {
	   $sub_node =$sub_nodes[0];
	
	   $str=$sub_node->getFirstChild()->getData();
	   $writer->dataElement('thetext',$str);
    }
    ### Заканчиваем крупный узел long_desc
    $writer->endTag();
  }

}
### Функция создания XML узла attachment из узла from_node
sub create_node_attachment {
  my($defect, $writer,$from_node,$to_node) = @_;
  my $defect_attachs = $defect->getElementsByTagName($from_node);
  my $n=$defect_attachs->getLength;
  ### Перебираем все узлы так как к одной ошибке 
  ### может быть прикреплено несколько файлов
  for (my $i =0; $i < $defect_attachs->getLength; $i++) {
    my $node = $defect_attachs->item($i);
    ### Создаем корневой узел с нужными аттрибутами
    $writer->startTag('attachment', 'isobsolete' => '0', 'ispatch' => '0', 'isprivate' =>'0');
    ### Создаем первый внутренний узел
    $writer->dataElement('attachid','2');
    ### Получаем данные из узла-аттрибута create-date
    my $href = $node->getAttributeNode ("create-date");
    my $date =$href->getValue;

    my $Y = substr($date, 0, 4);
    my $m = substr($date, 4, 2);
    my $d = substr($date, 6);
    my $formatdate= "$Y-$m-$d 10:29"; 
    ### Создаем узел date с нужным значением
    $writer->dataElement('date',$formatdate);
    $href = $node->getAttributeNode ("name");
    $writer->dataElement('desc',$href->getValue);
    $writer->dataElement('filename',$href->getValue);
    $href = $node->getAttributeNode("filespec");
    my $filename = $href->getValue;

    my $magic = File::MMagic::XS->new();
    ### Получаем тип файла (text/plain text/html ...)
    my $mime = $magic->get_mime($filename);
    ### Записываем это у узел	
    $writer->dataElement('type',$mime);
    $href = $node->getAttributeNode ("sizebytes");
    $writer->dataElement('size',$href->getValue);
    $writer->dataElement('attacher','sokunova@xxxxx.ru');
    $writer->startTag('data','encoding' => 'base64');
    ### Делаем перекодировку данных файла в строку base64 
    my $encode_str = &encode_file($filename);
    ### Кладем полученную строку в значение узла data
    $writer->raw($encode_str);
    $writer->endTag('data');
    ### Закрываем корневой узел attachment
    $writer->endTag('attachment');
	
  }

}

### Функция создания из файла  base64 строки
sub encode_file {
  my $filename = $_[0];
  open(DAT, $filename) or die "$!";
  ### Открытие файла в бинарном формате
  binmode(DAT);
  my $buff;
  my $str='';
  while(read(DAT  , $buff, 60*57)){
    $str =$str. encode_base64($buff);
  }

  close(DAT);
  return $str;
}

### Функция для создания корректной структуры XML файла Bugzilla из другого багтрэкера 
sub bugzilla_structure {
  my( $defect, $writer) =@_;
  ### Создание узла <bug_id>
  &create_node($defect,$writer,'defect-number','bug_id'); 
  ### Создание узла <creation_ts>
  &create_node_time($defect, $writer, 'date-created', 'creation_ts');
  ### Создание узла <short_desc>
  &create_node($defect, $writer, 'summary', 'short_desc');
  ### Создание узла <delta_ts>
  &create_node_time($defect,$writer, 'date-last-modified','delta_ts');
  ### Создание узла <reporter_accessible>
  &create_node_value($writer, 'reporter_accessible', '1');
  ### Создание узла <cclist_accessible>
  &create_node_value($writer, 'cclist_accessible', '1');
  ### Создание узла <classification_id>
  &create_node_value($writer, 'classification_id', '5');
  ### Создание узла <classification>
  &create_node_value($writer, 'classification', 'СПб');
  ### Создание узла <product>
  &create_node_product($defect,$writer,'component','product');
  ### Создание узла <component>
  &create_node_value($writer, 'component','Интерфейс пользователя');
  ### Создание узла <version>
  &create_node_version($defect,$writer,'product', 'version');
  ### Создание узла <rep_platform>
  &create_node_value($writer, 'rep_platform', 'Intel 32');
  ### Создание узла <op_sys>
  &create_node_value($writer, 'op_sys', 'Windows XP');
  ### Создание узла <bug_status>
  &create_node_status($defect,$writer,'defect-status','bug_status');
  ### Создание узла <priority>
  &create_node_priority($defect,$writer,'priority','priority');
  ### Создание узла <bug_severity>
  &create_node_value($writer, 'bug_severity','Ошибка');
  ### Создание узла <target_milestone>
  &create_node_value($writer, 'target_milestone','---');
  ### Создание узла <everconfirmed>
  &create_node_value($writer, 'everconfirmed','1');
  ### Создание узла <reporter>
  &create_node_reporter($defect,$writer, 'entered-by/last-name','reporter');
  ### Создание узла <assigned_to> and <cc>
  &create_node_assignedto($defect, $writer, 'currently-assigned-to/last-name','assigned_to');
  ### Создание узла <estimated_time>
  &create_node_value($writer, 'estimated_time', '0.00');
  ### Создание узла <remaining_time>
  &create_node_value($writer, 'remaining_time', '0.00');
  ### Создание узла <actual_time>
  &create_node_value($writer, 'actual_time', '0.00');
  ### Создание узла <qa_contact>
  &create_node_qacontact($defect, $writer, 'Sokunova', 'qa_contact');
  ### Создание узла <group>
  &create_node_value($writer, 'group', 'Доступ - Продукты СПб');
  ### Создание узла <long_desc>
  &create_node_longdesc_first($defect,$writer,'reported-by-record','long_desc');
  ### Создание узлов <long_desc> из излов комментариев
  &create_node_longdesc_comments($defect,$writer,'defect-event','long_desc');
  ### Создание узла <attachment>
  &create_node_attachment($defect,$writer, 'attachment', 'attachment');

}

### Функция перебирает все узлы defect и замена их на узлы  bug 
sub parse_xml{
  my $doc = $_[0];
  my $writer = $_[1];
  ### Парсинг всех узлов defect
  my $defects = $doc->getElementsByTagName("defect");
  for(my $i=0;  $i < $defects->getLength;$i++){
    my $defect = $defects->item($i);
    ### Создание узлов  <bug> для всех узлов <defect> 
    $writer->startTag('bug');
    ### Создание всех необходимых узлов 
    &bugzilla_structure($defect,$writer);
    $writer->endTag('bug');	
  }
}

###Стартовая функция анализатора XML, создаем объявление в
###новом XML документе
sub print_xml{
  my ($output, $testrakxml) =@_;
  my $dom_parser = new XML::DOM::Parser;
  my $doc = $dom_parser->parsefile ($testrakxml);
  my $root = $doc->getDocumentElement();

  my $writer = new XML::Writer(OUTPUT => $output, UNSAFE =>1);
  ###Включаем XML-объявление
  $writer->xmlDecl('UTF-8','yes');

  ###Добавление типа документа 
  $writer->doctype('bugzilla',undef,'bugzilla.dtd');
  $writer->startTag('bugzilla', 'version' => '3.4.2',  'urlbase' => 'http://localhost/TestTrack/',
                    'maintainer' => 'bugzilla@xxxxx.ru', 'exporter' => 'sokunova@xxxxx.ru');
  ###Парсинг исходного документа с записью с данных в выходной 
  ###документ
  &parse_xml($doc, $writer);
 
  $writer->endTag();
  ###Закрытие XML-документа
  $writer->end;
}

###Задаем параметры программы и переменные командной строки
my $keys = new Getopt::Compact
        (name => 'parser XML program',
         version => '1.1',
         struct=>
                [
                        [[qw(i input_xml)],qq(XML file for parsing - TestTrack format),'=s'],
                        [[qw(o output_xml)],qq(XML file will be saved in bugzilla format),'=s'],
                ]
        );
my $opts = $keys->opts;
###Если не задан входной XML файл для распарсивания или выходной
###для сохранения, то выходим
if (!defined($$opts{input_xml}) || !defined($$opts{output_xml})) {
  print "Enter xml for parsing and xml for save \n";
  exit 0;

}
print " INPUT = $$opts{input_xml} OUTPUT = $$opts{output_xml} \n";
my $output = new IO::File(">$$opts{output_xml}");
my $testrakxml= $$opts{input_xml};
###Вызываем функцию анализатора
&print_xml($output, $testrakxml);

Исходный текст программы: parser.pl
Пример тестового входного XML файла: test_xml.xml
Дополнительно рекомендую прочесть книгу «Perl & XML. Библиотека программиста» Э. Рэй, Дж. Макинтош.