File Coverage

blib/lib/Test/Smoke/Policy.pm
Criterion Covered Total %
statement 53 79 67.0
branch 14 24 58.3
condition 7 14 50.0
subroutine 11 12 91.6
pod 6 6 100.0
total 91 135 67.4


line stmt bran cond sub pod time code
1             package Test::Smoke::Policy;
2 12     12   697 use strict;
  12         50  
  12         342  
3              
4 12     12   51 use vars qw( $VERSION );
  12         20  
  12         457  
5             $VERSION = '0.004';
6              
7 12     12   55 use File::Spec;
  12         21  
  12         231  
8 12     12   364 use Test::Smoke::LogMixin;
  12         30  
  12         8718  
9              
10             =head1 NAME
11              
12             Test::Smoke::Policy - OO interface to handle the Policy.sh stuff.
13              
14             =head1 SYNOPSIS
15              
16             use Test::Smoke::Policy;
17              
18             my $srcpath = File::Spec->updir;
19             my $policy = Test::Smoke::Policy->new( $srcpath );
20              
21             $policy->substitute( [] );
22             $policy->write;
23              
24             =head1 DESCRIPTION
25              
26             I wish I understood what Merijn is doeing in the original code.
27              
28             =head1 METHODS
29              
30             =head2 Test::Smoke::Policy->new( $srcpath )
31              
32             Create a new instance of the Policy object.
33             Read the file or take data from the DATA section.
34              
35             =cut
36              
37             sub new {
38 4     4 1 1391 my $proto = shift;
39 4   33     24 my $class = ref $proto || $proto;
40              
41 4         9 my $self = bless { }, $class;
42 4         14 $self->reset_rules;
43 4         16 $self->_read_Policy( @_ );
44 4         17 $self;
45             }
46              
47             =head2 $policy->verbose
48              
49             Get verbosity.
50              
51             =cut
52              
53 8     8 1 38 sub verbose { $_[0]->{v} }
54              
55             =head2 $policy->set_rules( $rules )
56              
57             Set the rules for substitutions.
58              
59             =cut
60              
61             sub set_rules {
62 46     46 1 250 my( $self, $rules ) = @_;
63              
64 46         67 push @{ $self->{_rules} }, $rules;
  46         82  
65             }
66              
67             =head2 $policy->reset_rules( )
68              
69             Reset the C<_rules> property.
70              
71             =cut
72              
73             sub reset_rules {
74 56     56 1 16551 $_[0]->{_rules} = [ ];
75 56         91 $_[0]->{_new_policy} = undef;
76             }
77              
78             =head2 $policy->_do_subst( )
79              
80             C<_do_subst()> does the substitutions and stores the substituted version
81             as the B<_new_policy> attribute.
82              
83             =cut
84              
85             sub _do_subst {
86 32     32   768 my $self = shift;
87              
88 32         34 my %substs;
89 32         38 foreach my $rule ( @{ $self->{_rules} } ) {
  32         50  
90 40         41 push @{ $substs{ $rule->[0] } }, $rule->[1];
  40         84  
91             }
92 32         46 my $policy = $self->{_policy};
93 32         75 while ( my( $target, $values ) = each %substs ) {
94 40 50 66     418 unless ( $policy =~ s{^(\s*ccflags=.*?)$target}
  40         298  
95             {$1 . join " ",
96 0         0 grep $_ && length $_ => @$values}meg ) {
97 0         0 require Carp;
98             Carp::carp( "Policy target '$target' failed to match" );
99             }
100 32         89 }
101             $self->{_new_policy} = $policy;
102             }
103              
104             =head2 $policy->write( )
105              
106             =cut
107              
108 0     0 1 0 sub write {
109             my $self = shift;
110 0 0       0  
111             defined $self->{_new_policy} or $self->_do_subst;
112 0         0  
113 0   0     0 local *POL;
114 0         0 my $p_name = shift || 'Policy.sh';
115 0 0       0 unlink $p_name; # or carp "Can't unlink '$p_name': $!";
116 0         0 if ( open POL, "> $p_name" ) {
117 0 0       0 print POL $self->{_new_policy};
118 0         0 close POL or do {
119 0         0 require Carp;
120             Carp::carp( "Error rewriting '$p_name': $!" );
121             };
122 0         0 } else {
123 0         0 require Carp;
124             Carp::carp( "Unable to rewrite '$p_name': $!" );
125             }
126             }
127              
128             =head2 $policy->_read_Policy( $srcpath[, $verbose[, @ccflags]] )
129              
130             C<_read_Policy()> checks the C<< $srcpath >> for these conditions:
131              
132             =over 4
133              
134             =item B Policy is in C<$$srcpath>
135              
136             =item B Policy is in C<@$srcpath>
137              
138             =item B Policy is read from the filehandle
139              
140             =item B are taken as the base path for F
141              
142             =back
143              
144             The C<@ccflags> are passed to C<< $self->default_Policy() >>
145              
146             =cut
147              
148 4     4   16 sub _read_Policy {
149 4 100       17 my( $self, $srcpath, $verbose, @ccflags ) = @_;
150             $srcpath = '' unless defined $srcpath;
151 4 100 66     32  
152 4         10 $self->{v} ||= defined $verbose ? $verbose : 0;
153 4         11 my $vmsg = "";
154 4 100       18 local *POLICY;
    50          
    50          
155             if ( ref $srcpath eq 'SCALAR' ) {
156 1         2  
157 1         1 $self->{_policy} = $$srcpath;
158             $vmsg = "internal content";
159              
160             } elsif ( ref $srcpath eq 'ARRAY' ) {
161 0         0  
162 0         0 $self->{_poliy} = join "", @$srcpath;
163             $vmsg = "internal content";
164              
165             } elsif ( ref $srcpath eq 'GLOB' ) {
166 0         0  
167 0         0 *POLICY = *$srcpath;
  0         0  
  0         0  
168 0         0 $self->{_policy} = do { local $/; };
169             $vmsg = "anonymous filehandle";
170              
171 3 100 66     30 } else {
172             $srcpath = File::Spec->curdir
173 3         42 unless defined $srcpath && length $srcpath;
174             my $p_name = File::Spec->catfile( $srcpath, 'Policy.sh' );
175 3 50       86  
176 3         13 unless ( open POLICY, $p_name ) {
177 3         9 $self->{_policy} = $self->default_Policy( @ccflags );
178             $vmsg = "default content";
179 0         0 } else {
  0         0  
  0         0  
180 0         0 $self->{_policy} = do { local $/; };
181 0         0 close POLICY;
182             $vmsg = $p_name;
183             }
184              
185 4         11 }
186             $self->log_info("Reading 'Policy.sh' from %s (v=%d)", $vmsg, $self->verbose);
187             }
188              
189             =head2 $policy->default_Policy( [@ccflags] )
190              
191             Generate the default F from a set of ccflags, but be
192             backward compatible.
193              
194             =cut
195              
196 3     3 1 11 sub default_Policy {
197 3 100       11 my $self = shift;
198             my @ccflags = @_ ? @_ : qw( -DDEBUGGING );
199 3         11  
200 3         19 local $" = " ";
201             return <<__EOPOLICY__;
202             #!/bin/sh
203              
204             # Default Policy.sh from Test::Smoke
205              
206             # Be sure to define -DDEBUGGING by default, it's easier to remove
207             # it from Policy.sh than it is to add it in on the correct places
208              
209             ccflags='@ccflags'
210             __EOPOLICY__
211             }
212              
213             1;
214              
215             =head1 COPYRIGHT
216              
217             (c) 2001-2015, All rights reserved.
218              
219             * H.Merijn Brand
220             * Nicholas Clark
221             * Abe Timmerman
222              
223             This library is free software; you can redistribute it and/or modify
224             it under the same terms as Perl itself.
225              
226             See:
227              
228             * ,
229             *
230              
231             This program is distributed in the hope that it will be useful,
232             but WITHOUT ANY WARRANTY; without even the implied warranty of
233             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
234              
235             =cut