File Coverage

blib/lib/FB3/Validator.pm
Criterion Covered Total %
statement 18 140 12.8
branch 0 56 0.0
condition 0 11 0.0
subroutine 6 10 60.0
pod 0 3 0.0
total 24 220 10.9


line stmt bran cond sub pod time code
1             package FB3::Validator;
2              
3             =head1 NAME
4              
5             FB3::Validator - check file to be a valid FB3 book
6              
7             =head1 SYNOPSIS
8              
9             my $Validator = FB3::Validator->new;
10             if( my $ValidationError = $Validator->Validate( "path/to/book.fb3" )) {
11             die "path/to/book.fb3 is not a valid FB3: $ValidationError";
12             }
13              
14             =cut
15              
16 1     1   1434 use strict;
  1         3  
  1         31  
17 1     1   12 use OPC;
  1         4  
  1         21  
18 1     1   5 use XML::LibXML;
  1         2  
  1         9  
19 1     1   215 use FB3;
  1         1  
  1         53  
20              
21             our $XSD_DIR;
22              
23             use constant {
24 1         126 RELATION_TYPE_CORE_PROPERTIES =>
25             'http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties',
26             RELATION_TYPE_FB3_BOOK =>
27             'http://www.fictionbook.org/FictionBook3/relationships/Book',
28             RELATION_TYPE_FB3_BODY =>
29             'http://www.fictionbook.org/FictionBook3/relationships/body',
30 1     1   7 };
  1         1  
31              
32             use constant {
33 1         1663 CORE_PROPERTIES_CT => 'application/vnd.openxmlformats-package.core-properties+xml',
34             RELATIONSHIPS_CT => 'application/vnd.openxmlformats-package.relationships+xml',
35 1     1   7 };
  1         2  
36              
37             sub new {
38 0     0 0   my( $class, $XSD_DIR ) = @_;
39 0   0       $XSD_DIR //= FB3::SchemasDirPath(); # in development purposes it maybe
40             # convenient to use some other schemas path
41              
42 0           my $Validator = {
43             xsd_dir => $XSD_DIR,
44             };
45            
46 0           bless $Validator, $class;
47              
48 0           return $Validator;
49             }
50              
51             # Возвращает пустую строку в случае успеха, иначе - текст ошибки
52             sub Validate {
53 0     0 0   my( $self, $FileName ) = @_;
54              
55 0           my $XSD_DIR = $self->{xsd_dir};
56              
57             # Проверка, что файл - валидный ZIP архив
58              
59 0           my $Package = eval{ OPC->new( $FileName ) };
  0            
60 0 0         return $@ if( $@ );
61              
62 0           my %Namespaces = (
63             opcr => 'http://schemas.openxmlformats.org/package/2006/relationships',
64             );
65 0           my $XPC = XML::LibXML::XPathContext->new();
66 0           $XPC->registerNs( $_ => $Namespaces{$_} ) for keys %Namespaces;
67              
68             # Находим Content Types Stream, проверяем валидность
69              
70 0           my $CtXML = $Package->GetContentTypesXML;
71 0 0         unless( $CtXML ) {
72 0           return "Content Types part not found";
73             }
74 0           my $CtSchema = XML::LibXML::Schema->new( location =>
75             "$XSD_DIR/opc-contentTypes.xsd" );
76 0           my $CtDoc;
77 0           eval {
78 0           $CtDoc = XML::LibXML->new()->parse_string( $CtXML );
79 0           $CtSchema->validate( $CtDoc );
80             };
81 0 0         if( $@ ) {
82 0           return "Content Types part contains invalid XML or is invalid against ".
83             "XSD schema:\n$@";
84             }
85              
86             # Находим все части, описывающие связи (Relationships).
87              
88 0           my @ValidPartNames = grep IsValidPartName($_), $Package->PartNames;
89              
90 0           my @RelsPartNames;
91 0           for my $PartName ( @ValidPartNames ) {
92 0           my( $SourceDir, $SourceFileName ) = _SourceByRelsPartName( $PartName );
93 0 0 0       if( defined $SourceDir && defined $SourceFileName ) {
94 0           my $SourcePartName = $SourceDir.$SourceFileName;
95              
96 0 0 0       if( $SourcePartName eq "/" # источник - сам архив
97             || grep $SourcePartName eq $_, @ValidPartNames # источник есть в архиве
98             ) {
99              
100 0 0         push @RelsPartNames, $PartName unless grep $PartName eq $_, @RelsPartNames;
101             }
102             }
103             }
104              
105             # Проверки частей, описывающих связи
106              
107 0           my $PackageRelsDoc; # заодно находим часть с Package Relationships
108             my @PartNames; # заодно собираем названия всех частей, связи с которыми прописаны
109              
110 0           my $RelsSchema = XML::LibXML::Schema->new( location => "$XSD_DIR/opc-relationships.xsd" );
111              
112 0           for my $RelsPartName ( @RelsPartNames ) {
113              
114             # Проверка части на соответствие opc-relationships.xsd
115              
116 0           my $RelsDoc;
117 0           my $RelsPartXML = $Package->PartContents( $RelsPartName );
118 0           eval {
119 0           $RelsDoc = XML::LibXML->new()->parse_string( $RelsPartXML );
120 0           $RelsSchema->validate( $RelsDoc );
121             };
122 0 0         if( $@ ) {
123 0           return $RelsPartName." is not a valid XML or is not valid against ".
124             "opc-relationships.xsd:\n$@";
125             }
126              
127             # У Relationships частей должен быть соответствующий Content Type
128              
129 0 0         unless( $Package->PartContentType( $RelsPartName ) eq RELATIONSHIPS_CT ) {
130 0           return "Wrong content type for $RelsPartName (OPC M1.30 violation)"
131             }
132              
133             # Проверки отдельных связей
134              
135 0           my( $SourceDir ) = _SourceByRelsPartName( $RelsPartName );
136 0           my @RelIDs;
137 0           for my $RelNode ( $XPC->findnodes( '/opcr:Relationships/opcr:Relationship',
138             $RelsDoc )) {
139              
140             # У связей должен быть уникальный ID
141              
142 0           my $RelID = $RelNode->getAttribute('Id');
143 0 0         if( grep $RelID eq $_, @RelIDs ) {
144 0           return "Duplicate Ids in Relationships part $RelsPartName ".
145             "(OPC M1.26 violation)";
146             }
147              
148 0   0       my $TargetMode = $RelNode->getAttribute('TargetMode') || 'Internal';
149 0 0         if( $TargetMode eq 'Internal' ) {
150              
151             # Части, связи с которыми описаны, должны существовать
152              
153 0           my $RelatedPartName = OPC::FullPartNameFromRelative(
154             $RelNode->getAttribute('Target'), $SourceDir );
155              
156 0 0         unless( grep $RelatedPartName eq $_, @ValidPartNames ) {
157 0           return "$RelsPartName contains reference on unexisting part $RelatedPartName";
158             }
159              
160             # Не должно быть связей с другими Relationships частями [M1.25]
161              
162 0 0         if( grep $RelatedPartName eq $_, @RelsPartNames ) {
163 0           return "Relationship part $RelsPartName contains reference on another ".
164             "Relationships part $RelatedPartName (OPC M1.25 violation)";
165             }
166              
167 0 0         push @PartNames, $RelatedPartName
168             unless grep $RelatedPartName eq $_, @PartNames;
169             }
170             }
171              
172 0 0         if( $RelsPartName eq "/_rels/.rels" ) {
173 0           $PackageRelsDoc = $RelsDoc;
174             }
175             }
176              
177             # Общие для всех частей проверки
178              
179 0           for my $PartName ( @PartNames ) {
180              
181             # У всех частей должен быть задан Content type [M1.2], хотя он может быть
182             # пустым [M1.14]
183              
184 0 0         unless( defined $Package->PartContentType( $PartName )) {
185 0           return "Content type is not provided for $PartName (OPC M1.2 violation)";
186             }
187             }
188            
189             # Обязательно должна быть часть, описывающая связи пакета (/_rels/.rels)
190              
191 0 0         unless( $PackageRelsDoc ) {
192 0           return "Can't find package relationships item (/_rels/.rels)";
193             }
194              
195             # В пакете может присутствовать максимум одна часть, описывающей мета данные
196             # (Core Properties) [M4.1]
197              
198 0           my @CorePropRelations = $XPC->findnodes(
199             '/opcr:Relationships/opcr:Relationship[@Type="'.RELATION_TYPE_CORE_PROPERTIES.'"]',
200             $PackageRelsDoc );
201              
202 0 0         if( @CorePropRelations > 1 ) {
203 0           return "Found more than one part with type 'Core Properties' (OPC M4.1 violation)";
204             }
205              
206             # Если такая часть есть - проверка XML валидности, соответствия схеме и content type
207            
208 0 0         if( @CorePropRelations ) {
209 0           my $CorePropPartName = OPC::FullPartNameFromRelative(
210             $CorePropRelations[0]->getAttribute('Target'), '/' );
211 0           my $CorePropXML = $Package->PartContents( $CorePropPartName );
212 0           my $CorePropSchema = XML::LibXML::Schema->new( location =>
213             "$XSD_DIR/opc-coreProperties.xsd" );
214 0           eval {
215 0           my $CorePropDoc = XML::LibXML->new()->parse_string( $CorePropXML );
216 0           $CorePropSchema->validate( $CorePropDoc );
217             };
218 0 0         if( $@ ) {
219 0           return $CorePropPartName." is not a valid XML or is not valid against ".
220             "opc-coreProperties.xsd:\n$@";
221             }
222              
223 0 0         unless( $Package->PartContentType( $CorePropPartName ) eq CORE_PROPERTIES_CT ) {
224 0           return "Wrong content type for $CorePropPartName"
225             }
226             }
227              
228             # В пакете должна быть как минимум одна часть, описывающая заголовок книги
229              
230 0           my @DescrRelationNodes = $XPC->findnodes(
231             '/opcr:Relationships/opcr:Relationship[@Type="'.RELATION_TYPE_FB3_BOOK.'"]',
232             $PackageRelsDoc );
233              
234 0 0         unless( @DescrRelationNodes ) {
235 0           return "FB3 description not found";
236             }
237              
238 0           for my $DescrRelationNode ( @DescrRelationNodes ) {
239            
240             # Каждую часть с описанием проверяем на валидность и соответствие схеме
241              
242 0           my $DescrPartName = OPC::FullPartNameFromRelative(
243             $DescrRelationNode->getAttribute('Target'), '/' );
244 0           my $DescrXML = $Package->PartContents( $DescrPartName );
245 0           my $DescrSchema = XML::LibXML::Schema->new( location =>
246             "$XSD_DIR/fb3_descr.xsd" );
247 0           my $DescrDoc;
248 0           eval {
249 0           $DescrDoc = XML::LibXML->new()->parse_string( $DescrXML );
250 0           $DescrSchema->validate( $DescrDoc );
251             };
252 0 0         if( $@ ) {
253 0           return $DescrPartName." is not a valid XML or is not valid against ".
254             "fb3_descr.xsd:\n$@";
255             }
256              
257             # Часть с описанием обязательно должна содержать в себе ссылку на тело книги
258              
259 0           $DescrPartName =~ /^(.*)\/([^\/]*)$/;
260 0           my( $DescrDir, $DescrFileName ) = ( $1, $2 );
261 0           my $DescrRelsPartName = "$DescrDir/_rels/$DescrFileName.rels";
262 0           my $DescrRelsXML = $Package->PartContents( $DescrRelsPartName );
263 0 0         unless( $DescrRelsXML ) {
264 0           return "Can't find relationships for book description $DescrPartName ".
265             "(no $DescrRelsPartName)";
266             }
267 0           my $DescrRelsDoc = XML::LibXML->new()->parse_string( $DescrRelsXML );
268 0           my $BodyRelation = $XPC->findvalue(
269             '/opcr:Relationships/opcr:Relationship[@Type="'.RELATION_TYPE_FB3_BODY.'"]/@Target',
270             $DescrRelsDoc,
271             );
272 0 0         unless( $BodyRelation ) {
273 0           return "Can't find body relationship for $DescrPartName";
274             }
275 0           my $BodyPartName = OPC::FullPartNameFromRelative( $BodyRelation,
276             $DescrDir );
277              
278             # Найденную часть с телом книги также проверяем на валидность и соответствие схеме
279              
280 0           my $BodyXML = $Package->PartContents( $BodyPartName );
281 0           my $BodySchema = XML::LibXML::Schema->new( location =>
282             "$XSD_DIR/fb3_body.xsd" );
283 0           my $BodyDoc;
284 0           eval {
285 0           $BodyDoc = XML::LibXML->load_xml(string=>$BodyXML, huge => 1);
286 0           $BodySchema->validate( $BodyDoc );
287             };
288 0 0         if( $@ ) {
289 0           return $BodyPartName." is not a valid XML or is not valid against ".
290             "fb3_body.xsd:\n$@";
291             }
292             }
293              
294 0           return ''; # успешный выход
295             }
296              
297             sub IsValidPartName {
298 0     0 0   my $PartName = shift;
299              
300             # "A part URI shall not have a forward slash as the last character. [M1.5]"
301 0 0         return 0 if $PartName =~ /\/$/;
302              
303             # Проверяем отдельные сегменты имени
304 0           for my $NameSegment ( split '/', $PartName ) {
305              
306             # "A segment shall not contain percent-encoded forward slash (“/”), or backward
307             # slash (“\”) characters. [M1.7]"
308             # "A segment shall not contain percent-encoded unreserved characters. [M1.8]"
309 0           for my $Char (( '/', '\\', 'a'..'z', 0..9, '-', '.', '_', '~' )) {
310 0           my $PercentEncodedChar = sprintf( '%%%x', ord( $Char ));
311 0 0         return 0 if $NameSegment =~ /$PercentEncodedChar/i;
312             }
313              
314             # "A segment shall not end with a dot (“.”) character. [M1.9]"
315 0 0         return 0 if $NameSegment =~ /\.$/;
316              
317             # "A segment shall include at least one non-dot character. [M1.10]"
318             # (избыточное условие, удовлетворяющееся с помощью M1.9)
319             }
320              
321 0           return 1;
322             }
323              
324             sub _SourceByRelsPartName {
325 0     0     my $RelsPartName = shift;
326              
327 0           my( $SourceDir, $SourceFileName ) = ( $RelsPartName =~ /
328             ^ ( .* ) # папка файла источника
329             _rels\/
330             ([^\/]*) # название файла источника без папки
331             .rels /x );
332            
333 0           return ( $SourceDir, $SourceFileName );
334             }
335              
336             1;