File Coverage

blib/lib/swat/story.pm
Criterion Covered Total %
statement 12 102 11.7
branch 0 28 0.0
condition 0 2 0.0
subroutine 4 35 11.4
pod 0 30 0.0
total 16 197 8.1


line stmt bran cond sub pod time code
1             package swat::story;
2              
3 1     1   3 use strict;
  1         1  
  1         24  
4 1     1   2 use base 'Exporter';
  1         1  
  1         63  
5 1     1   1090 use Outthentic::DSL;
  1         9921  
  1         28  
6 1     1   5 use File::Temp qw/ tempfile /;
  1         1  
  1         901  
7              
8             our @EXPORT = qw{
9              
10             new_story end_of_story
11              
12             get_prop set_prop
13              
14             debug_mod1 debug_mod2 debug_mod12
15              
16             set_response
17              
18             dsl captures capture stream match_lines
19              
20             run_swat_module apply_module_variables module_variable
21              
22             do_perl_file
23              
24             modify_resource
25              
26             set_response_processor
27             run_response_processor
28              
29             hostname ignore_http_err
30              
31             project_root_dir
32              
33             test_root_dir
34              
35             resource resource_dir
36              
37             http_method
38              
39             body
40              
41             headers
42              
43             };
44              
45             our @stories = ();
46              
47             sub new_story {
48            
49 0     0 0   push @stories, {
50             template_variables => {},
51             props => { dsl => Outthentic::DSL->new() , response => [] },
52             };
53              
54             }
55              
56             sub end_of_story {
57              
58 0 0   0 0   if (debug_mod2()){
59 0           Test::More::ok(1,'end of story: '.(get_prop('check_list')));
60             }
61 0           delete $stories[-1];
62              
63             }
64              
65             sub _story {
66 0     0     @stories[-1];
67             }
68              
69             sub get_prop {
70              
71 0     0 0   my $name = shift;
72              
73 0           _story()->{props}->{$name};
74            
75             }
76              
77             sub set_prop {
78              
79 0     0 0   my $name = shift;
80 0           my $value = shift;
81              
82 0           _story()->{props}->{$name} = $value;
83            
84             }
85              
86             sub project_root_dir {
87 0     0 0   get_prop('project');
88             }
89              
90             sub test_root_dir {
91 0     0 0   get_prop('test_root_dir');
92             }
93              
94             sub hostname {
95 0     0 0   get_prop('hostname');
96             }
97              
98             sub ignore_http_err {
99 0     0 0   get_prop('ignore_http_err');
100             }
101              
102             sub resource {
103 0     0 0   get_prop('resource');
104             }
105              
106             sub resource_dir {
107 0     0 0   get_prop('resource_dir');
108             }
109              
110             sub http_method {
111 0     0 0   get_prop('http_method');
112             }
113              
114             sub body {
115 0     0 0   get_prop('body');
116             }
117              
118             sub headers {
119 0     0 0   get_prop('headers');
120             }
121              
122              
123              
124             sub context_populated {
125 0     0 0   get_prop('context_populated')
126             }
127              
128             sub debug_mod1 {
129              
130 0     0 0   get_prop('debug') == 1
131             }
132              
133             sub debug_mod2 {
134              
135 0     0 0   get_prop('debug') == 2
136             }
137              
138             sub debug_mod12 {
139              
140 0 0   0 0   debug_mod1() or debug_mod2()
141             }
142              
143             sub set_response {
144 0     0 0   my $cv = get_prop('response');
145 0           push @$cv, shift();
146 0           set_prop('response', $cv);
147             }
148              
149             sub dsl {
150 0     0 0   get_prop('dsl')
151             }
152              
153             sub captures {
154              
155             dsl()->{captures}
156 0     0 0   }
157              
158             sub stream {
159              
160             dsl()->{stream}
161 0     0 0   }
162              
163             sub match_lines {
164              
165             dsl()->{match_lines}
166 0     0 0   }
167              
168             sub capture {
169 0     0 0   dsl()->{captures}->[0]
170             }
171              
172             sub run_swat_module {
173              
174 0     0 0   my $http_method = uc(shift());
175 0           my $resource = shift;
176 0   0       my $module_variables = shift || {};
177              
178 0           $main::module_variables = $module_variables;
179              
180 0           my $test_root_dir = get_prop('test_root_dir');
181              
182 0           my $http_method_path = uc($http_method);
183 0           my $module_file = "$test_root_dir/$resource/$http_method_path/request.mod";
184              
185 0 0         if (debug_mod2()){
186 0           Test::More::ok(1,"run swat module: $http_method => $resource");
187 0           Test::More::ok(1,"load module file: $module_file");
188             }
189              
190 0           my $test_root_dir = get_prop('test_root_dir');
191              
192 0           do_perl_file($module_file);
193            
194             }
195              
196             sub do_perl_file {
197              
198 0     0 0   my $file = shift;
199              
200             {
201 0           package main;
202 0           do $file;
203 0 0         die "couldn't parse $file: $@" if $@;
204             }
205              
206 0           return 1;
207             }
208              
209              
210             sub apply_module_variables {
211              
212 0     0 0   set_prop( module_variables => $main::module_variables );
213              
214 0           for my $name ( keys %{ get_prop( 'module_variables' ) } ){
  0            
215              
216 0           my $v = module_variable($name);
217              
218 0           my $re = "%".$name."%";
219              
220 0           my $curl_cmd = get_prop('curl_cmd');
221 0           my $resource = get_prop('resource');
222              
223 0           s{$re}[$v]g for $curl_cmd;
224 0           s{$re}[$v]g for $resource;
225              
226 0 0         if (debug_mod2()){
227 0           Test::More::ok(1,"apply module variable: $name => $v");
228             }
229              
230 0           set_prop( curl_cmd => $curl_cmd );
231 0           set_prop( resource => $resource );
232             }
233            
234             }
235              
236             sub module_variable {
237              
238 0     0 0   my $name = shift;
239              
240 0           get_prop( 'module_variables' )->{$name};
241              
242             }
243              
244             sub modify_resource {
245              
246 0     0 0   my $sub = shift;
247              
248 0           my $resource = get_prop('resource');
249              
250 0 0         Test::More::ok(1,"try to modify_resource: $resource ") if debug_mod12();
251              
252 0           my $new_resource = $sub->($resource);
253              
254 0 0         Test::More::ok(1,"modify_resource ok: $resource => $new_resource") if debug_mod12();
255              
256 0           set_prop( resource => $new_resource );
257              
258             }
259              
260             sub set_response_processor {
261              
262 0     0 0   my $sub = shift;
263              
264 0 0         Test::More::ok(1,"setting response processor") if debug_mod12();
265              
266 0           set_prop( response_processor => $sub );
267              
268             }
269              
270             sub run_response_processor {
271              
272 0 0   0 0   return unless get_prop( 'response_processor' );
273              
274 0           my $body = body();
275              
276 0           my $headers = headers();
277              
278 0 0         Test::More::ok(1,"running response processor") if debug_mod12();
279              
280 0           my $sub = get_prop( 'response_processor' );
281              
282 0           my $retval = $sub->($headers,$body);
283              
284 0           my ($fh, $content_file) = tempfile( DIR => get_prop('test_root_dir') );
285              
286 0 0         open F, ">", $content_file or die $!;
287 0           print F $retval;
288 0           close F;
289              
290 0 0         Test::More::diag("modified response saved to $content_file") if debug_mod12();
291              
292 0 0         if (debug_mod12()){
293 0           my $debug_bytes = get_prop('debug_bytes');
294 0           my $rshort = substr( $retval, 0, $debug_bytes );
295 0 0         if (length($rshort) < length($retval)) {
296 0           Test::More::diag("modified response:\n$rshort ... ( output truncated to $debug_bytes bytes )");
297             } else{
298 0           Test::More::diag("modified response:\n$retval");
299             }
300             }
301              
302 0           dsl()->{output} = $retval;
303             }
304              
305              
306             1;
307              
308             __END__