File Coverage

lib/Net/Domain/SMD/File.pm
Criterion Covered Total %
statement 12 12 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 16 16 100.0


line stmt bran cond sub pod time code
1             # Copyrights 2013-2015 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5 1     1   2648 use warnings;
  1         2  
  1         28  
6 1     1   11 use strict;
  1         2  
  1         29  
7              
8             package Net::Domain::SMD::File;
9 1     1   4 use vars '$VERSION';
  1         2  
  1         49  
10             $VERSION = '0.18';
11              
12 1     1   849 use parent 'Net::Domain::SMD';
  1         300  
  1         6  
13              
14             use Log::Report 'net-domain-smd';
15              
16             use MIME::Base64 qw/decode_base64/;
17             use XML::LibXML ();
18             use POSIX qw/mktime tzset/;
19             use XML::Compile::Util qw/type_of_node/;
20             use List::Util qw/first/;
21              
22              
23             sub init($)
24             { my ($self, $args) = @_;
25             $self->SUPER::init($args);
26              
27             # Clean object construction is needed when we are going to write
28             # SMD files... but we won't for now.
29             $self->{NDSF_fn} = $args->{filename} or panic;
30             $self->{NDSF_marks} = $args->{marks};
31             $self->{NDSF_labels} = $args->{labels};
32             $self;
33             }
34              
35              
36             sub fromFile($%)
37             { my ($class, $fn, %args) = @_;
38              
39             my $schemas = $args{schemas} or panic;
40              
41             open my($fh), '<:raw', $fn
42             or fault __x"cannot read from smd file {fn}", fn => $fn;
43              
44             my $xml;
45             my ($marks, $labels);
46             LINE:
47             while(<$fh>)
48             { next LINE if m/^#|^\s*$/; # not yet permitted in those files
49             if( m/^-{3,}BEGIN .* SMD/)
50             { my @smd;
51             while(<$fh>)
52             { last if m/^-{3,}END .* SMD/;
53             push @smd, $_;
54             }
55             $xml = \decode_base64(join '', @smd);
56             next LINE;
57             }
58              
59             # Only few of the fields are of interest: often better inside XML
60             my ($label, $value) = split /\:\s+/;
61             defined $value && length $value or next;
62             $label = lc $label;
63             $value =~ s/\s*$//s;
64             if($label eq 'u-labels')
65             { $labels = [split /\s*\,\s*/, $value];
66             }
67             elsif($label eq 'marks') # trademark names? Comma list?
68             { $marks = [split /\s*\,\s*/, $value];
69             }
70              
71             }
72              
73             $xml or error __x"there is not SMD information in {fn}", fn => $fn;
74              
75             my $root = $schemas->dataToXML($xml);
76             $class->fromNode($root, filename => $fn, marks => $marks
77             , labels => $labels, %args);
78             }
79            
80             #----------------
81              
82             sub filename() {shift->{NDSF_fn}}
83             sub labels() { @{shift->{NDSF_labels} || []} }
84             sub marks() { @{shift->{NDSF_marks} || []} }
85              
86             1;