File Coverage

blib/lib/XAO/DO/Web/Action.pm
Criterion Covered Total %
statement 82 97 84.5
branch 26 36 72.2
condition 17 41 41.4
subroutine 14 15 93.3
pod 1 5 20.0
total 140 194 72.1


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             XAO::DO::Web::Action - base for mode-dependant displayable objects
4              
5             =head1 SYNOPSIS
6              
7             package XAO::DO::Web::Fubar;
8             use strict;
9             use XAO::Objects;
10             use XAO::Errors qw(XAO::DO::Web::Fubar);
11             use base XAO::Objects->load(objname => 'Web::Action');
12              
13              
14             # <%Fubar mode='foo'%>
15             #
16             sub display_foo ($@) {
17             ...
18             }
19              
20             # <%Fubar mode='kick' target='ass'%>
21             #
22             sub data_kick ($@) {
23             my $self=shift;
24             my $args=get_args(\@_);
25             my $target=$args->{'target'} || 'self';
26             return {
27             force => $self->siteconfig->get("/targets/$target/force"),
28             target => $target,
29             }
30             }
31              
32             # Gets called with prepared data
33             #
34             sub display_kick ($@) {
35             my $self=shift;
36             my $args=get_args(\@_);
37             dprint "force=",$args->{'force'};
38             ...
39             }
40              
41             # Data only method, will output JSON
42             # (will also set content-type to application/json!)
43             #
44             # <%Fubar mode='api'%>
45             #
46             # Data prepared as above, but displayed with a custom
47             # display method:
48             #
49             # <%Fubar mode='api' displaymode='api-summary'%>
50             #
51             sub data_api ($@) {
52             my $self=shift;
53             my $args=get_args(\@_);
54             return $self->data_kick($args);
55             }
56              
57             sub display_api_summary ($@) {
58             my $self=shift;
59             my $args=get_args(\@_);
60             return $self->textout($args->{'data'}->{'target'}.' will get kicked');
61             }
62              
63             # This is obsolete, but still supported
64             #
65             sub check_mode ($$) {
66             my $self=shift;
67             my $args=get_args(\@_);
68             my $mode=$args->{'mode'};
69             if($mode eq "foo") {
70             $self->foo($args);
71             }
72             elsif($mode eq "kick") {
73             $self->kick($args);
74             }
75             else {
76             $self->SUPER::check_mode($args);
77             }
78             }
79              
80             =head1 DESCRIPTION
81              
82             Very simple object with overridable check_mode method.
83             Simplifies implementation of objects with arguments like:
84              
85             <%Fubar mode="kick" target="ass"%>
86              
87             The code will attempt to find and call a "data_kick" method first
88             (dashes in 'mode' are replaced with underscores). It needs to return
89             some data, a hash or an array reference typically. If there is no
90             matching data_* method found then no data is built.
91              
92             The next step is to try finding a "display_kick" method. If it exists
93             it is called with original arguments plus "data" set to the data
94             received. If there is no data, then there is no extra argument added to
95             the display_* method (and should there be a 'data' argument it is not
96             modified).
97              
98             The name of the data producing method is derived from 'datamode'
99             defaulting to 'mode' arguments. The name of display method is derived
100             from 'displaymode' defaulting to 'mode' arguments. This allows to reuse
101             the same data builder with various "views", aka display methods. You can
102             also force data display in the presense of a custom display method by
103             setting 'displaymode' to 'data'.
104              
105             If there is a data_* method, but there is no display_* method, then the
106             default is to call display_data() -- which outputs the data in a format
107             given by 'format' argument (only JSON and XML is supported currently).
108              
109             If there are both data_* and display_* methods then the output depends
110             on its content.
111              
112             If there is no data_* and no display_* then a check_mode() method is
113             called that needs to work out what needs to be done. This is an obsolete
114             practice.
115              
116             The default check_mode() method does not have any functionality and always
117             simply throws an error with the content of 'mode':
118              
119             throw $self "- unknown mode ($mode)";
120              
121             Remember that using "throw $self" you actually throw an error that
122             depends on the namespace of your object and therefore can be caught
123             separately if required.
124              
125             =head2 JSON Encoding Configuration
126              
127             The JSON encoding can be controlled with two site configuration
128             values:
129              
130             /xao/action/json_pretty - insert line breaks to make JSON easier to read
131             /xao/action/json_canonical - sort hash keys to stabilize the output
132              
133             =cut
134              
135             ###############################################################################
136             package XAO::DO::Web::Action;
137 7     7   6207 use warnings;
  7         13  
  7         256  
138 7     7   36 use strict;
  7         11  
  7         145  
139 7     7   31 use POSIX qw(strftime);
  7         11  
  7         68  
140 7     7   504 use JSON;
  7         11  
  7         51  
141 7     7   868 use Error qw(:try);
  7         12  
  7         123  
142 7     7   873 use XAO::Objects;
  7         12  
  7         172  
143 7     7   30 use XAO::Utils qw(:debug :args :math :html);
  7         11  
  7         1365  
144              
145 7     7   41 use base XAO::Objects->load(objname => 'Web::Page');
  7         10  
  7         41  
146              
147             sub get_mode_sub ($$$$;$);
148              
149             ###############################################################################
150              
151             sub display ($%) {
152 123     123 1 167 my $self=shift;
153 123         249 my $args=get_args(\@_);
154              
155 123         1217 my $data_sub=$self->get_mode_sub('data',$args->{'datamode'},$args->{'mode'});
156              
157 123         396 my $display_sub=$self->get_mode_sub('display',$args->{'displaymode'},$args->{'mode'},$data_sub);
158              
159             # Preparing the data, if data method is known
160             #
161 123         199 my $data;
162 123 100       208 if($data_sub) {
163              
164             # We catch errors in generating data and we provide a storage
165             # for default data.
166             #
167 27         32 my $default_data;
168             try {
169 27     27   707 $data=$data_sub->($self,$args,{
170             default_data_ref => \$default_data,
171             });
172              
173             # Adding a status when possible to unify the results
174             #
175 27 100       592 if(ref $data eq 'HASH') {
176 26   50     104 $data->{'status'}||='success';
177             }
178             }
179             otherwise {
180 0     0   0 my $e=shift;
181 0         0 my $etext="$e";
182              
183             # If the error looks like {{CODE: Text}} or {{Text}}
184             # we trust the thrower and take the code and the text from
185             # within brackets.
186             #
187 0         0 my $ecode;
188 0 0       0 if($etext=~/\{\{(?:([A-Z0-9_-]+):\s*)?(.*?)\s*\}\}/) {
189 0         0 $ecode=$1;
190 0         0 $etext=$2;
191             }
192              
193 0   0     0 $ecode||='UNKNOWN';
194              
195             # If default data was populated by the routine we take it.
196             #
197 0   0     0 $data=$default_data || { };
198              
199             # If we had no data, or the default data does not have error
200             # code and message -- adding them.
201             #
202 0 0       0 if(ref $data eq 'HASH') {
203 0   0     0 $data->{'status'}||='error';
204 0   0     0 $data->{'error_code'}||=$ecode;
205 0   0     0 $data->{'error_message'}||=$etext;
206 0   0     0 $data->{'error_time'}||=time;
207             }
208 27         235 };
209             }
210              
211             # Displaying the data. There is always a display method, even if
212             # it's a reference to default check_mode or display_data methods.
213             #
214 123 100       597 if($data) {
215 27         82 $display_sub->($self,$args,{
216             data => $data,
217             });
218             }
219             else {
220 96         246 $display_sub->($self,$args);
221             }
222             }
223              
224             ###############################################################################
225              
226             sub get_mode_sub ($$$$;$) {
227 248     248 0 708 my ($self,$prefix,$modecust,$modegen,$data_sub)=@_;
228              
229 248   100     824 my $mode=$modecust || $modegen || '-no-mode';
230              
231 248         329 my $subcache=$self->{'_sub_cache'};
232 248 100       390 if(!$subcache) {
233 112         243 $self->{'_sub_cache'}=$subcache={ };
234             }
235              
236 248         524 my $subcachekey=$prefix.':'.$mode;
237 248 100       440 if(exists $subcache->{$subcachekey}) {
238 14         26 return $subcache->{$subcachekey};
239             }
240              
241             # Converting mode to a sub name.
242             #
243 234         817 (my $subname=$mode)=~s/-/_/g;
244              
245             # Only lowercase alphanumerics are supported.
246             #
247 234 50       942 $subname=~/^[a-z0-9_]+$/ ||
248             throw $self "- bad mode '$mode'";
249              
250             # There may be data producing method and/or a display
251             # method. Checking for both.
252             #
253 234         1106 my $subref=$self->can($prefix.'_'.$subname);
254              
255             # When a non-generic mode is given ('datamode' or 'displaymode') not
256             # having a subroutine is a hard error.
257             #
258 234 50 66     523 if($modecust && !$subref) {
259 0         0 throw $self "- no $prefix routine found for '$modecust'";
260             }
261              
262             # When there is no display method we either call display_data
263             # when there is data, or the check_mode if there is no data for
264             # compatibility with legacy code.
265             #
266 234 100 100     629 if($prefix eq 'display' && !$subref) {
267 91 100       153 if($data_sub) {
268 11         34 $subref=$self->can('display_data');
269             }
270             else {
271 80         185 $subref=$self->can('check_mode');
272             }
273             }
274              
275             # Storing to speed up future calls
276             #
277 234         489 $subcache->{$subcachekey}=$subref;
278              
279 234         470 return $subref;
280             }
281              
282             ###############################################################################
283              
284             sub json ($) {
285 10     10 0 20 my $self=shift;
286              
287 10         95 my $json=JSON->new->utf8;
288              
289 10 100       35 $json->canonical(1) if $self->siteconfig->get('/xao/action/json_canonical');
290 10 50       561 $json->pretty(1) if $self->siteconfig->get('/xao/action/json_pretty');
291              
292 10         568 return $json;
293             }
294              
295             ###############################################################################
296              
297             # Default data display. Called by default for data_* methods and can
298             # also be called by other display_* methods as needed.
299              
300             sub display_data ($@) {
301 12     12 0 23 my $self=shift;
302 12         28 my $args=get_args(\@_);
303              
304 12   33     199 my $data=$args->{'data'} || throw $self "- no data";
305 12 50       27 ref($data) || throw $self "- invalid data";
306              
307 12   100     31 my $format=$args->{'format'} || 'json';
308              
309 12 100 66     63 if($format eq 'json') {
    100 33        
    50          
310 5         18 $self->object(objname => 'Web::Header')->expand(
311             type => 'application/json',
312             );
313              
314 5         37 $self->finaltextout($self->json->encode($data));
315             }
316             elsif($format eq 'js' || $format eq 'json-embed') {
317              
318             # The trick with embedded JSON is that it is printed as part of
319             # a larger page and as such has to be in characters that are
320             # then encoded into bytes of the page final encoding.
321             #
322 5         20 my $json=$self->json->utf8(0)->encode($data);
323              
324             # The data is typically embedded in a set
325             # of tags, so if the content of a data field has then
326             # that would close the outer script tag allowing that content to
327             # execute in the page context. Bad bad bad.
328             #
329 5         70 $json =~ s/([<>])/'\\u' . sprintf('%04x',ord($1))/esg;
  4         21  
330              
331 5         16 $self->textout($json);
332             }
333             elsif($format eq 'xml' || $format eq 'xml-embed') {
334 2   66     11 my $xml_sub=$self->get_mode_sub('xml',$args->{'xmlmode'} || $args->{'mode'},$args->{'mode'});
335              
336 2         8 my $xml=$xml_sub->($self,$args,{
337             data => $data,
338             });
339              
340 2 50       62 if($format eq 'xml') {
341 2         8 $self->object(objname => 'Web::Header')->expand(
342             type => 'text/xml',
343             );
344             }
345              
346 2         9 $self->finaltextout($xml);
347             }
348             else {
349 0         0 throw $self "- unknown format '$format'";
350             }
351             }
352              
353             ###############################################################################
354              
355             # Needs to be overriden in derived classes
356              
357             sub check_mode ($%) {
358 1     1 0 24 my $self=shift;
359 1         4 my $args=get_args(\@_);
360              
361 1   50     11 my $mode=$args->{'mode'} || '';
362 1         10 throw $self "- unknown mode ($mode)";
363             }
364              
365             ###############################################################################
366             1;
367             __END__