File Coverage

web/cgi-bin/yatt.lib/YATT/LRXML.pm
Criterion Covered Total %
statement 100 116 86.2
branch 15 28 53.5
condition 2 2 100.0
subroutine 27 31 87.1
pod 0 3 0.0
total 144 180 80.0


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2             package YATT::LRXML;
3 7     7   34 use strict;
  7         15  
  7         217  
4 7     7   34 use warnings qw(FATAL all NONFATAL misc);
  7         11  
  7         280  
5              
6 7     7   32 use YATT::Util qw(call_type);
  7         12  
  7         503  
7              
8             require YATT::LRXML::Node;
9              
10             sub Parser () { 'YATT::LRXML::Parser' }
11              
12 7     7   33 use Carp;
  7         10  
  7         1997  
13              
14             # Returns YATT::LRXML::Cursor
15             sub read_string {
16 2     2 0 1014 my $pack = shift;
17 2         9 my $parser = $pack->call_type(Parser => 'new');
18 2         11 $parser->parse_string(@_);
19             }
20              
21             sub read_handle {
22 0     0 0 0 my $pack = shift;
23 0         0 my $parser = $pack->call_type(Parser => 'new');
24 0         0 $parser->parse_handle(@_);
25             }
26              
27             sub read {
28 0     0 0 0 my ($pack, $filename) = splice @_, 0, 2;
29 0         0 my $fh;
30 0 0       0 if (ref $filename) {
31 0         0 $fh = $filename;
32             } else {
33 0 0       0 open $fh, '<', $filename or croak "Can't open '$filename': $!";
34 0         0 unshift @_, filename => $filename;
35             }
36 0         0 $pack->read_handle($fh, @_);
37             }
38              
39             #========================================
40              
41             package YATT::LRXML::Scanner; # To scan tokens.
42 7     7   37 use strict;
  7         11  
  7         182  
43 7     7   32 use warnings qw(FATAL all NONFATAL misc);
  7         13  
  7         252  
44 7     7   40 use base qw(YATT::Class::ArrayScanner);
  7         10  
  7         4428  
45             use YATT::Fields
46 7         41 (['^cf_linenum' => 1]
47             , ['^cf_last_nol' => 0] # last number of lines
48             , qw(cf_last_linenum
49 7     7   38 cf_path cf_metainfo));
  7         11  
50              
51             sub expect {
52 635     635   1048 (my MY $path, my ($patterns)) = @_;
53 635 50       2048 return unless $path->readable;
54 635         1527 my $value = $path->{cf_array}[$path->{cf_index}];
55 635         775 my @match;
56 635         1234 foreach my $desc (@$patterns) {
57 2453         4544 my ($toktype, $pat) = @$desc;
58 2453 100       16160 next unless @match = $value =~ $pat;
59 635         2003 $path->after_read($path->{cf_index}++);
60 635         3403 return ($toktype, @match);
61             }
62 0         0 return;
63             }
64              
65             sub number_of_lines {
66 156     156   378 (my MY $path, my ($pos)) = @_;
67 156 50       602 $pos = $path->{cf_index} unless defined $pos;
68 156 50       347 return 0 unless @{$path->{cf_array}};
  156         596  
69 156 50       541 defined (my $tok = $path->{cf_array}[$pos])
70             or return undef;
71 156         1074 $tok =~ tr:\n::;
72             }
73              
74             sub after_read {
75 1450     1450   2222 (my MY $path, my ($pos)) = @_;
76 1450 50       2993 if (defined $pos) {
77 1450         3292 $$path{cf_last_nol} = $path->{cf_array}[$pos] =~ tr:\n::;
78             }
79 1450         2683 $path->{cf_last_linenum} = $path->{cf_linenum};
80 1450 50       3333 unless (defined $$path{cf_linenum}) {
81 0         0 $$path{cf_linenum} = 1;
82             } else {
83 1450   100     6053 $$path{cf_linenum} += $$path{cf_last_nol} || 0;
84             }
85             }
86              
87 7     7   1877 use YATT::Exception qw(Exception);
  7         16  
  7         853  
88              
89             sub token_error {
90 0     0   0 (my MY $self, my ($mesg)) = @_;
91             $self->Exception->new(error_fmt => $mesg
92             , file => $self->{cf_metainfo}->in_file
93 0         0 , line => $self->{cf_linenum});
94             }
95              
96             #========================================
97             package YATT::LRXML::Builder; # To build tree.
98 7     7   38 use strict;
  7         10  
  7         197  
99 7     7   32 use warnings qw(FATAL all NONFATAL misc);
  7         14  
  7         252  
100 7     7   33 use base qw(YATT::Class::Configurable);
  7         10  
  7         495  
101 7         29 use YATT::Fields qw(^product ^parent ^is_switched
102 7     7   34 cf_endtag cf_startpos cf_startline cf_linenum);
  7         21  
103              
104 7     7   37 use YATT::LRXML::Node qw(node_set_nlines);
  7         12  
  7         1695  
105             sub Scanner () {'YATT::LRXML::Scanner'}
106              
107 0     0   0 sub initargs {qw(product parent)}
108              
109             sub new {
110 323     323   618 my $pack = shift;
111 323         1466 my MY $path = $pack->SUPER::new;
112 323 50       1553 $path->init(@_) if @_;
113 323         2790 $path;
114             }
115              
116             sub init {
117 323     323   509 my MY $path = shift;
118 323         765 @{$path}{qw(product parent)} = splice @_, 0, 2;
  323         1091  
119 323 50       1609 $path->configure(@_) if @_;
120 323         526 $path;
121             }
122              
123             sub open {
124 67     67   153 (my MY $parent, my ($product)) = splice @_, 0, 2;
125             ref($parent)->new($product, $parent, $parent->configure
126             , startline => $parent->{cf_linenum}
127 67         340 , @_);
128             }
129              
130 7     7   37 use YATT::Exception qw(Exception);
  7         13  
  7         2836  
131              
132             sub error {
133 1     1   5 (my MY $self, my ($mesg, $param, @other)) = @_;
134 1         13 $self->Exception->new(error_fmt => $mesg
135             , error_param => $param
136             , @other);
137             }
138              
139             sub verify_close {
140 64     64   181 (my MY $self, my ($tagname, $scan)) = @_;
141 64 50       226 unless (defined $self->{cf_endtag}) {
142 0         0 die $self->error("TAG '/%s' without open", [$tagname]
143             , file => $scan->cget('metainfo')->filename
144             , line => $scan->linenum);
145             }
146 64 100       284 unless ($tagname eq $self->{cf_endtag}) {
147             die $self->error("TAG '%s' line %d closed by /%s"
148 1         17 , [$self->{cf_endtag}, $self->{cf_startline}, $tagname]
149             , file => $scan->cget('metainfo')->filename
150             , line => $scan->linenum);
151             }
152             }
153              
154             sub add {
155 996     996   1916 (my MY $self, my Scanner $scan) = splice @_, 0, 2;
156 996         1130 push @{$self->{product}}, @_;
  996         2678  
157 996         2054 $self->{cf_linenum} = $scan->{cf_linenum};
158 996         2667 $self;
159             }
160              
161             sub switch {
162 16     16   36 (my MY $self, my ($elem)) = @_;
163 16 100       58 unless ($self->{is_switched}) {
164 11         32 $self->{is_switched} = $self->{product};
165             }
166 16         22 push @{$self->{is_switched}}, $elem;
  16         45  
167 16         31 $self->{product} = $elem;
168 16         101 $self;
169             }
170              
171             sub DESTROY {
172 323     323   615 my MY $self = shift;
173             # switch した場合は?
174             node_set_nlines($self->{product}
175 323         1392 , $self->{cf_linenum} - $self->{cf_startline});
176             }
177              
178             1;