package SugarTrail::Template::Master; # Master template holder # new() # parse() # _parse_headers() # _parse_body() use strict; use warnings; use Carp; use SugarTrail::Template::Slave; use SugarTrail::Template::Condition; sub new { my $class = shift; my $args = { @_ }; my $self = {}; $self->{args} = $args; $self->{parsed} = 0; return bless $self, $class; } sub parse { my $self = shift; my ($head, $body) = split "\n\n", $self->{text}, 2; $self->{head} = $head; $self->{body} = $body; my @counts = ( $self->_parse_headers(), $self->_parse_body() ); $self->{parsed}++; return @counts; } sub _parse_headers { my $self = shift; foreach (split "\n", $self->{head}) { my ($n, $v) = split ": ", $_, 2; $self->{meta}->{$n} = $v; } return scalar keys %{ $self->{meta} }; } sub _parse_body { my $self = shift; $self->{steps} = []; foreach (split "\n", $self->{body}) { chomp; s/ *$//; my @conds; my ($line, $cond_block) = $_ =~ m/^(.*?)(\{(.*)\})?$/; $line =~ s/ *$//; if ($cond_block) { $cond_block =~ s/\}$//; $cond_block =~ s/^\{//; @conds = split m/\s*;\s*/, $cond_block; } push @{ $self->{steps} }, { line => $line, conds => \@conds }; } return scalar @{ $self->{steps} }; } sub generate_slave { my $self = shift; my $args = shift; my $slave = SugarTrail::Template::Slave->new($args); $self->parse() unless $self->{parsed}; my @slave_steps; STEP: foreach my $master_step (@{ $self->{steps} }) { my $accept = 1; # accept by default my $slave_step = { line => $master_step->{line}, warnings => [] }; # Test against each condition from the pre-parsed condblock. # * refuse step only in case all conditions passed without # warnings # * in all other cases (fail, warning), accept COND: foreach my $condstr (@{ $master_step->{conds} }) { my $c = SugarTrail::Template::Condition->new($condstr); my ($r, $w) = $c->match($args); # if warnings, store them, prepare to accept and ignore result if (scalar @$w) { $accept = 1; push @{$slave_step->{warnings}}, @$w; next COND; } else { # point of no warnings -- refusal should be valid here $accept = 0 unless $r; } } push @slave_steps, $slave_step if ($accept || scalar @{$slave_step->{warnings}}); } $slave->{meta}->{'Stm'} = $self->{stm}; $slave->{meta}->{'Stm Revision'} = $self->get_current_revision(); $slave->{meta}->{'Params'} = mkmymime($args); $slave->{steps} = \@slave_steps; return $slave; } # skel: returns time (might be useful in absence of VCS) sub get_current_revision { return time; } sub mkmymime { my $d = shift; my $d1 = "; "; my $d2 = "="; my @t; foreach (sort keys %$d) { push @t, $_ . $d2 . $d->{$_}; } return join $d1, @t; } sub source { return $_[0]->{text} } 1;