File Coverage

lib/XML/Schema/Particle/Sequence.pm
Criterion Covered Total %
statement 26 79 32.9
branch 5 58 8.6
condition 3 13 23.0
subroutine 5 9 55.5
pod 1 5 20.0
total 40 164 24.3


line stmt bran cond sub pod time code
1             #============================================================= -*-perl-*-
2             #
3             # XML::Schema::Particle::Sequence.pm
4             #
5             # DESCRIPTION
6             # Subclassed particle to contain a sequence of other particles
7             # which should be matched in order.
8             #
9             # AUTHOR
10             # Andy Wardley
11             #
12             # COPYRIGHT
13             # Copyright (C) 2001 Canon Research Centre Europe Ltd.
14             # All Rights Reserved.
15             #
16             # This module is free software; you can redistribute it and/or
17             # modify it under the same terms as Perl itself.
18             #
19             # REVISION
20             # $Id: Sequence.pm,v 1.1.1.1 2001/08/29 14:30:17 abw Exp $
21             #
22             #========================================================================
23              
24             package XML::Schema::Particle::Sequence;
25              
26 2     2   852 use strict;
  2         4  
  2         64  
27 2     2   10 use base qw( XML::Schema::Particle );
  2         4  
  2         491  
28 2     2   13 use vars qw( $VERSION $DEBUG $ERROR $ETYPE );
  2         4  
  2         2188  
29              
30             $VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
31             $DEBUG = 0 unless defined $DEBUG;
32             $ERROR = '';
33             $ETYPE = 'SequenceParticle';
34              
35             #*DEBUG = \$XML::Schema::Particle::DEBUG;
36             #*ERROR = \$XML::Schema::Particle::ERROR;
37             #*DECLINED = \&XML::Schema::Particle::DECLINED;
38              
39              
40             #------------------------------------------------------------------------
41             # init()
42             #
43             # Called automatically by base class new() method.
44             #------------------------------------------------------------------------
45              
46             sub init {
47 3     3 1 5 my ($self, $config) = @_;
48              
49 3 50       15 $self->TRACE("config => ", $config) if $DEBUG;
50              
51             my $sequence = $config->{ sequence }
52 3   50     11 || return $self->error("no sequence defined");
53              
54 3 50       9 return $self->error("sequence expects an array ref")
55             unless ref $sequence eq 'ARRAY';
56              
57 3         4 my ($p, @particles);
58             my $factory = $self->{ _FACTORY } = $config->{ FACTORY }
59 3   33     17 || $XML::Schema::FACTORY;
60              
61 3         6 foreach $p (@$sequence) {
62 6         20 my $particle = $factory->create( particle => $p );
63 6 100       16 unless (defined $particle) {
64 1         6 return $self->error("error in sequence item ", scalar @particles,
65             ': ', $factory->error());
66             }
67            
68 5         12 push(@particles, $particle);
69             }
70 2         6 $self->{ particles } = \@particles;
71 2         4 $self->{ type } = 'sequence';
72              
73 2 50       11 $self->constrain($config)
74             || return;
75              
76 2         21 return $self;
77             }
78              
79              
80             sub particles {
81 1     1 0 3 my $self = shift;
82             return $self->{ particles }
83 1   33     9 || $self->error("empty particle sequence");
84             }
85              
86              
87             sub start {
88 0     0 0   my $self = shift;
89              
90 0 0         $self->TRACE() if $DEBUG;
91              
92 0           $self->{ occurs } = 0;
93 0           $self->_start_sequence();
94             }
95              
96              
97             sub _start_sequence {
98 0     0     my $self = shift;
99              
100 0 0         $self->TRACE() if $DEBUG;
101              
102             my $particles = $self->{ particles }
103 0   0       || return $self->decline("empty particle sequence");
104              
105 0           $self->{ _PSET } = [ @$particles ];
106              
107 0           my $first = $particles->[0];
108              
109 0   0       return $first->start()
110             || $self->error($first->error());
111             }
112              
113              
114             sub end {
115 0     0 0   my $self = shift;
116 0           my ($min, $max, $occurs, $name) = @$self{ qw( min max occurs name ) };
117              
118 0 0         $self->TRACE() if $DEBUG;
119              
120 0           my $pset = $self->{ _PSET };
121              
122 0 0         if (@$pset) {
123 0           my $pnow = shift @$pset;
124 0           while ($pnow) {
125 0           $self->TRACE("clearing ", $pnow->ID);
126 0 0         $pnow->end()
127             || return $self->error($pnow->error());
128 0 0         if ($pnow = shift(@$pset)) {
129 0 0         $pnow->start()
130             || return $self->error($pnow->error());
131             }
132             }
133 0           $occurs++;
134             }
135              
136 0 0         return $self->error("minimum of $min $name element",
    0          
137             $min > 1 ? 's' : '', " expected")
138             if $occurs < $min;
139              
140 0 0         return $self->error("maximum of $max $name element",
    0          
141             $max > 1 ? 's' : '', " exceeded")
142             if $occurs > $max;
143              
144 0           return 1;
145             }
146              
147              
148             sub element {
149 0     0 0   my ($self, $name) = @_;
150 0           my $pset = $self->{ _PSET };
151 0 0         my $pnow = @$pset ? $pset->[0] : undef;
152 0           my ($min, $max) = @$self{ qw( min max ) };
153 0           my $element;
154 0           my $restarted = 0;
155 0           my $satisfied = 0;
156              
157 0 0         $self->TRACE("name => ", $name) if $DEBUG;
158              
159 0           while ($pnow) {
160             # true value returned indicates success
161 0 0         return $element
162             if ($element = $pnow->element($name));
163              
164             # undefined value returned indicates error
165 0 0         unless (defined $element) {
166 0           $self->TRACE('DECLINED');
167 0 0         return $satisfied ? $self->decline("unexpected <$name> element")
168             : $self->error($pnow->error())
169             }
170              
171             # defined but false value (0) indicates particle
172             # declined to accept element but was otherwise
173             # satisfied according to min/max constraints so
174             # we move on to try the next particle
175 0           $self->TRACE("ending $pnow because it declined");
176 0 0         $pnow->end()
177             || return $self->error($pnow->error());
178              
179 0           shift(@$pset);
180              
181 0 0         if (@$pset) {
182 0           $pnow = $pset->[0];
183 0 0         $pnow->start() || return $self->error($pnow->error());
184             }
185             else {
186             # looks like we reached the end of the sequence...
187 0           my $occurs = ++$self->{ occurs };
188              
189             # if we've reached our max occurences then we must decline
190 0 0         return $self->decline("unexpected <$name> element (max. $max sequences reached)")
191             if $occurs >= $max;
192              
193             # and if we've already restarted once then we shouldn't again
194 0 0         last if $restarted;
195              
196             # otherwise restart the sequence
197 0 0         return unless $self->_start_sequence();
198 0           $pset = $self->{ _PSET };
199 0 0         $pnow = @$pset ? $pset->[0] : undef;
200              
201 0           $restarted++;
202 0 0         $satisfied++ if $occurs >= $min;
203             }
204             }
205              
206 0 0         return $satisfied ? $self->decline("unexpected <$name> element")
207             : $self->error("unexpected <$name> element");
208              
209             }
210              
211              
212            
213             1;
214              
215              
216              
217              
218              
219