Line # Revision Author
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