| 1 |
296 |
ahitrov |
package IIR_Parser; |
| 2 |
|
|
use strict; |
| 3 |
|
|
use locale; |
| 4 |
|
|
|
| 5 |
|
|
use vars qw ($VERSION); $VERSION=0.1; |
| 6 |
|
|
|
| 7 |
|
|
#use LogPool; |
| 8 |
|
|
|
| 9 |
|
|
my %default_params = ( |
| 10 |
|
|
'field_name_length' => 132 , |
| 11 |
|
|
'debug' => 0, |
| 12 |
|
|
'save_path' => undef, |
| 13 |
|
|
'err' => undef, |
| 14 |
|
|
|
| 15 |
|
|
); |
| 16 |
|
|
|
| 17 |
|
|
|
| 18 |
|
|
##################### СЧИТЫВАНИЕ СЛЕДУЮЩЕГО СИМВОЛА |
| 19 |
|
|
sub getchar { |
| 20 |
|
|
my $self = shift; |
| 21 |
|
|
$self -> {_CHAR} = getc ($self->{'_FH'}) ; |
| 22 |
|
|
## $self -> {err}->handle('debug', "Got char =$self->{_CHAR}=\n"); |
| 23 |
|
|
return $self -> {_CHAR} ; |
| 24 |
|
|
} |
| 25 |
|
|
###################### КОНСТРУКТОР |
| 26 |
|
|
|
| 27 |
|
|
sub new { |
| 28 |
|
|
my ($class, %params ) = @_; |
| 29 |
|
|
my $self = { }; |
| 30 |
|
|
|
| 31 |
|
|
foreach ( keys %default_params ) { |
| 32 |
|
|
$self->{ $_} = exists $params {$_} ? $params {$_} : $default_params {$_} ; |
| 33 |
|
|
} |
| 34 |
|
|
|
| 35 |
|
|
bless ($self,$class); |
| 36 |
|
|
|
| 37 |
|
|
my $input_path = $params{'input_path' }; |
| 38 |
|
|
|
| 39 |
|
|
if( defined $input_path ) { # Откроем файл |
| 40 |
|
|
( -d $input_path ) || $self -> {err}->handle('fatal', "IIR ($input_path) : is not a directory\n"); |
| 41 |
|
|
my $input_file_name = $input_path."/.IIR"; |
| 42 |
|
|
$self->{_FH} = IO::File -> new ("< $input_file_name") || $self -> {err}->handle('fatal', "Unable to open $input_file_name : $! \n" ); |
| 43 |
|
|
|
| 44 |
|
|
} else { # Приготовимся читать из STDIN |
| 45 |
|
|
$self->{_FH} = \*STDIN; |
| 46 |
|
|
|
| 47 |
|
|
} |
| 48 |
|
|
|
| 49 |
|
|
my $char = $self->getchar ; # Прочитаем и запомним первый символ |
| 50 |
|
|
defined ( $char ) || $self -> {err}->handle('syntax',"Message is empty: cannot read first char\n"); |
| 51 |
|
|
|
| 52 |
|
|
$self -> ClearSpaces; # Пропустим пробелы в начале |
| 53 |
|
|
return $self; |
| 54 |
|
|
} |
| 55 |
|
|
|
| 56 |
|
|
######################## ПРОПУСК ПРОБЕЛОВ |
| 57 |
|
|
sub ClearSpaces { |
| 58 |
|
|
my $self = shift; |
| 59 |
|
|
my $char = $self -> {_CHAR} ; |
| 60 |
|
|
while ( defined($char) && $char =~ /[\s\r\n]/ ) { |
| 61 |
|
|
$char = $self->getchar ; |
| 62 |
|
|
} |
| 63 |
|
|
} |
| 64 |
|
|
|
| 65 |
|
|
########################## ЧТЕНИЕ ИМЕНИ ПОЛЯ |
| 66 |
|
|
|
| 67 |
|
|
sub GetFieldName { # Прочитаем имя поля IIR |
| 68 |
|
|
my $self = shift; |
| 69 |
|
|
$self->{debug} && $self->{err}->handle('debug',"GetFieldName\n"); |
| 70 |
|
|
|
| 71 |
|
|
my $char = $self -> {'_CHAR'} ; |
| 72 |
|
|
my $ret = ""; |
| 73 |
|
|
while ($char =~ /\w/) { # Имя содержит только алфавитно-цифровые символы и подчеркивание |
| 74 |
|
|
(length($ret) > $self -> {'field_name_length'} ) && $self->{err}->handle('syntax', "Field too long : ".length($ret)."\n"); |
| 75 |
|
|
$ret .= $char; |
| 76 |
|
|
$char = $self->getchar; |
| 77 |
|
|
defined($char) || $self->{err}->handle('syntax', "File ended while scanning for field name \n" ); |
| 78 |
|
|
} |
| 79 |
|
|
|
| 80 |
|
|
defined($char) || $self->{err}->handle('syntax', "File ended between field name and expected colon\n"); |
| 81 |
|
|
( $char ne ':' ) && $self->{err}->handle('syntax', "Field name ".$ret.$char." does not end with colon\n"); |
| 82 |
|
|
# После имени должно идти двоеточие |
| 83 |
|
|
$char = $self->getchar; |
| 84 |
|
|
return $self -> {'_FIELD_NAME'} |
| 85 |
|
|
= $ret ; # Запомним название поля |
| 86 |
|
|
} |
| 87 |
|
|
|
| 88 |
|
|
########################## ЧТЕНИЕ ЗНАЧЕНИЯ ПОЛЯ |
| 89 |
|
|
|
| 90 |
|
|
sub GetFieldValue { |
| 91 |
|
|
my ($self, %args) = @_; |
| 92 |
|
|
$self->{debug} && $self->{err}->handle('debug',"GetFieldValue $self->{_FIELD_NAME}\n"); |
| 93 |
|
|
|
| 94 |
|
|
my $char = $self -> {'_CHAR'} ; |
| 95 |
|
|
my $mode = $args {'mode'}; |
| 96 |
|
|
my $name = $args {'name'}; |
| 97 |
|
|
|
| 98 |
|
|
my $save = ($mode =~ /save/ ); # Режим записи значений полей в отдельные файлы |
| 99 |
|
|
my $return = ($mode =~ /return/); # Режим возврата значений полей |
| 100 |
|
|
my $check = ($mode =~ /check/); # Режим возврата значений полей |
| 101 |
|
|
my $ret = ""; |
| 102 |
|
|
my $firstline = 1; |
| 103 |
|
|
my $line_begin=""; |
| 104 |
|
|
my $type; |
| 105 |
|
|
my $binary=0; |
| 106 |
|
|
|
| 107 |
|
|
my $save_file = undef; |
| 108 |
|
|
if ($save) { # Откроем файл для сохранения значения поля, если это надо. |
| 109 |
|
|
defined ($self -> {'save_path'} ) || $self->{err}->handle('developer', "GetFieldValue with save option called without a defined save_path\n"); |
| 110 |
|
|
my $save_file_name; |
| 111 |
|
|
my $instance_number; |
| 112 |
|
|
do { # На случай множественных значений полей - если такой файл уже есть, припишем к его названию номер |
| 113 |
|
|
$save_file_name = "$self->{save_path}/.$self->{_FIELD_NAME}$instance_number"; |
| 114 |
|
|
$instance_number++; |
| 115 |
|
|
} while -f $save_file_name ; |
| 116 |
|
|
$save_file = MP::WriteFile -> open ("$save_file_name") || $self->{err}->handle('fatal' , "Cannot open >$save_file_name\n" ); |
| 117 |
|
|
$ret = $save_file; # Возвращаемым значением будет сохраненный файл (объект класса MP::WriteFile) |
| 118 |
|
|
} |
| 119 |
|
|
|
| 120 |
|
|
return "" unless defined ($char) ; # Если тут EOF, делать больше нечего - вернем пустую строку |
| 121 |
|
|
|
| 122 |
|
|
while ( $char =~/[ \t]/ ) { # Пропустим пробелы вначале (но не переводы строки!) |
| 123 |
|
|
$char = $self->getchar; |
| 124 |
|
|
return "" unless defined ($char); |
| 125 |
|
|
} |
| 126 |
|
|
if ($char eq "\n") { # Если в первой же строке пусто, |
| 127 |
|
|
$char = $self->getchar; # Посмотрим, что дальше |
| 128 |
|
|
return $ret if($char ne ' '); # Если там непробел -- это уже начало следующего поля, а данное - пустое. Возвращаемся. |
| 129 |
|
|
$char = $self->getchar; |
| 130 |
|
|
} |
| 131 |
|
|
|
| 132 |
|
|
while (1) { |
| 133 |
|
|
unless (defined ($char)) { # EOF: Заканчиваем читать. |
| 134 |
|
|
$save_file->close if $save; |
| 135 |
|
|
return $ret; |
| 136 |
|
|
} |
| 137 |
|
|
$ret = 1 if $check; |
| 138 |
|
|
$ret .= $char if $return; # Припишем новый символ к значению поля |
| 139 |
|
|
|
| 140 |
|
|
if ( $save && !($binary && $line_begin eq '' && $char eq ' ' ) ) { |
| 141 |
|
|
$save_file->print($char) || $self ->{err}->handle('fatal',"Cannot write to $save_file->{path}\n") |
| 142 |
|
|
} # Запишем новый символ в файл данного поля |
| 143 |
|
|
# в двоичном поле если вдруг в начале строки окажется пробел, не пишем его |
| 144 |
|
|
$line_begin .= $char if $char ne "\n" && ($binary || $firstline) && length($line_begin) < 8; |
| 145 |
|
|
# Начало строки понадобится для определения типа поля и конца двоичного поля |
| 146 |
|
|
|
| 147 |
|
|
$char = $self->getchar; |
| 148 |
|
|
|
| 149 |
|
|
unless (defined ($char)) { # EOF: Заканчиваем читать. |
| 150 |
|
|
$save_file->close if $save; |
| 151 |
|
|
return $ret; |
| 152 |
|
|
} |
| 153 |
|
|
|
| 154 |
|
|
# Нас интересует тип поля. Если первая строчка начинается с begin, то это |
| 155 |
|
|
# двоичный тип (uuencode), в противном случае - текст. В конце разбора первой строки мы |
| 156 |
|
|
# уже должны знать тип, чтобы правильно разобрать следующую. |
| 157 |
|
|
if ($char eq "\n" && $firstline ) { # Поэтому в конце первой строки определяем тип |
| 158 |
|
|
$firstline = 0; |
| 159 |
|
|
$binary = ($line_begin =~ /^begin\s/ ); |
| 160 |
|
|
} |
| 161 |
|
|
# Во всех строках, кроме первой определяем, является ли данная строка продолжением |
| 162 |
|
|
# поля или уже нет |
| 163 |
|
|
if ($char eq "\n" ) { # Строка закончлась |
| 164 |
|
|
if ($binary) { # Двоичное поле кончается словом end |
| 165 |
|
|
if ($line_begin =~ /^end/ ) { |
| 166 |
|
|
do { # После end пропустим все до первой буквы (названия следующего поля) |
| 167 |
|
|
$char = $self->getchar; |
| 168 |
|
|
} until !defined($char) || $char =~/\w/; |
| 169 |
|
|
$save_file->print("\n") if $save; |
| 170 |
|
|
$save_file->close if $save; |
| 171 |
|
|
return $ret; |
| 172 |
|
|
} else { |
| 173 |
|
|
$line_begin =""; |
| 174 |
|
|
next; |
| 175 |
|
|
} |
| 176 |
|
|
} else { # Для текстового поля признаком продолжения является пробел в начале строки |
| 177 |
|
|
my $nextchar = $self->getchar; |
| 178 |
|
|
if ( $nextchar && $nextchar eq ' ' ) { |
| 179 |
|
|
$char = "\n"; |
| 180 |
|
|
next; |
| 181 |
|
|
} else { |
| 182 |
|
|
$save_file->close if $save; |
| 183 |
|
|
while ( defined $nextchar && $nextchar eq "\n" ) { $nextchar =$self->getchar ; } # Пропустим пустые строки, если они там есть |
| 184 |
|
|
return $ret; |
| 185 |
|
|
} |
| 186 |
|
|
} |
| 187 |
|
|
} |
| 188 |
|
|
} |
| 189 |
|
|
} |
| 190 |
|
|
|
| 191 |
|
|
############# Сброс остатка входного потока в файл |
| 192 |
|
|
sub DumpTail { |
| 193 |
|
|
my ($self,$file) = @_; |
| 194 |
|
|
my $char = $self->{'_CHAR'}; |
| 195 |
|
|
while(defined($char)) { |
| 196 |
|
|
(print {$file} $char ) || return undef; |
| 197 |
|
|
$char = $self->getchar; |
| 198 |
|
|
} |
| 199 |
|
|
return 1; |
| 200 |
|
|
} |
| 201 |
|
|
|
| 202 |
|
|
|
| 203 |
|
|
########### Проверка конца входного потока |
| 204 |
|
|
sub eof { |
| 205 |
|
|
my $self = shift; |
| 206 |
|
|
! defined $self->{'_CHAR'} |
| 207 |
|
|
} |
| 208 |
|
|
|
| 209 |
|
|
|
| 210 |
|
|
|
| 211 |
|
|
1; |
| 212 |
|
|
|
