File Coverage

blib/lib/JSONP.pm
Criterion Covered Total %
statement 144 465 30.9
branch 43 242 17.7
condition 30 171 17.5
subroutine 31 57 54.3
pod 24 25 96.0
total 272 960 28.3


line stmt bran cond sub pod time code
1             package JSONP;
2             # some older 5.8.x perl versions on exotic platforms don't get the v5.10 syntax
3 1     1   57413 use 5.010;
  1         3  
4 1     1   8 use v5.10;
  1         3  
5 1     1   6 use strict;
  1         7  
  1         20  
6 1     1   4 use warnings;
  1         5  
  1         36  
7 1     1   530 use utf8;
  1         13  
  1         4  
8 1     1   463 use Time::HiRes qw(gettimeofday);
  1         1230  
  1         3  
9 1     1   854 use File::Temp qw();
  1         18302  
  1         24  
10 1     1   5 use File::Path;
  1         2  
  1         52  
11 1     1   504 use Encode;
  1         8498  
  1         60  
12 1     1   12 use Cwd qw();
  1         2  
  1         17  
13 1     1   4 use Scalar::Util qw(reftype blessed);
  1         2  
  1         46  
14 1     1   816 use CGI qw();
  1         27753  
  1         28  
15 1     1   504 use Digest::SHA;
  1         2748  
  1         40  
16 1     1   581 use JSON;
  1         8777  
  1         6  
17 1     1   583 use Want;
  1         1206  
  1         106  
18             use overload
19 7     7   486 'eq' => sub { _compare(@_)},
20 5     5   11 'ne' => sub {! _compare(@_)},
21 1     1   6 fallback => 1;
  1         2  
  1         8  
22              
23             sub _compare {
24 12     12   19 my ($self, $other, $swap) = @_;
25 12 100       32 return 0 unless defined $other;
26 10         21 my $reftype_self = reftype $self;
27 10         24 my $reftype_other = reftype $other;
28 10 50 66     30 return 0 if defined $reftype_other and $reftype_self ne $reftype_other;
29 10         56 my $j = JSON->new->canonical;
30 10 100       17 unless ($reftype_other) {
31 4         5 eval{
32 4         11 local $SIG{'__DIE__'};
33 4   50     44 $other = JSON->new->decode($other // '');
34             };
35 4 100       23 return 0 if $@;
36             }
37              
38 8         10 my $canonother;
39 8 100 66     28 if (blessed $other and $other->isa('JSONP')) {
40 2         5 $canonother = $other->serialize(0, 1);
41             } else {
42 6         52 $canonother = $j->encode($other);
43             }
44              
45 8         20 my $canonself = $self->serialize(0, 1);
46 8         45 return $canonself eq $canonother;
47             }
48              
49             our $VERSION = '2.26';
50              
51             =encoding utf8
52              
53             =head1 NAME
54              
55             JSONP - a module to quickly build JSON/JSONP web services, providing also some syntactic sugar acting a bit like a sort of DSL (domain specific language) for JSON.
56              
57             =head1 SYNOPSIS
58              
59             =over 2
60              
61             =item * under CGI environment:
62              
63             You can pass the name of instance variable, skipping the I<-Enew> call.
64             If you prefer, you can use I<-Enew> just passing nothing in I.
65              
66             use JSONP 'jsonp';
67             $jsonp->run;
68              
69             ...
70              
71             sub yoursubname
72             {
73             $j->table->fields = $sh->{NAME};
74             $j->table->data = $sh->fetchall_arrayref;
75             }
76              
77             OR
78              
79             use JSONP;
80              
81             my $j = JSONP->new;
82             $j->run;
83              
84             ...
85              
86             sub yoursubname
87             {
88             $j->table->fields = $sh->{NAME};
89             $j->table->data = $sh->fetchall_arrayref;
90             }
91              
92             =item * under mod_perl:
93              
94             You must declare the instance variable, remember to use I.
95              
96             use JSONP;
97             local our $j = JSONP->new;
98             $j->run;
99              
100             ...
101              
102             sub yoursubname
103             {
104             my $namedparam = $j->params->namedparam;
105             $j->table->fields = $sh->{NAME};
106             $j->table->data = $sh->fetchall_arrayref;
107             }
108              
109             option setting methods allow for chained calls:
110              
111             use JSONP;
112             local our $j = JSONP->new;
113             $j->aaa('your_session_sub')->login('your_login_sub')->debug->insecure->run;
114              
115             ...
116              
117             sub yoursubname
118             {
119             my $namedparam = $j->params->namedparam;
120             $j->table->fields = $sh->{NAME};
121             $j->table->data = $sh->fetchall_arrayref;
122             }
123              
124             just make sure I it is the last element in chain.
125              
126             =back
127              
128             the module will call automatically the sub which name is specified in the req parameter of GET/POST request. JSONP will check if the sub exists in current script namespace by looking in typeglob and only in that case the sub will be called. The built-in policy about function names requires also a name starting by a lowercase letter, followed by up to 63 characters chosen between ASCII letters, numbers, and underscores. Since this module is intended to be used by AJAX calls, this will spare you to define routes and mappings between requests and back end code. In your subroutines you will therefore add all the data you want to the JSON/JSONP object instance in form of hashmap of any deep and complexity, JSONP will return that data automatically as JSON object with/without padding (by using the function name passed as 'callback' in GET/POST request, or using simply 'callback' as default) to the calling javascript. The supplied callback name wanted from calling javascript must follow same naming conventions as function names above. Please note that I and I keys on top of JSONP object hierarchy are reserved. See also "I" paragraph at the end of the POD.
129             The jQuery call:
130              
131             // note that jQuery will automatically chose a non-clashing callback name when you insert callback=? in request
132             $.getJSON(yourwebserverhost + '?req=yoursubname&firstparam=firstvalue&...&callback=?', function(data){
133             //your callback code
134             });
135              
136             processed by JSONP, will execute I in your script if it exists, otherwise will return a JSONP codified error. The default error object returned by this module in its root level has a boolean "error" flag and an "errors" array where you can put a list of your customized errors. The structure of the elements of the array is of course free so you can adapt it to your needs and frameworks.
137              
138             you can autovivify the response hash omiting braces
139              
140             $jsonp->firstlevelhashvalue = 'I am a first level hash value';
141             $jsonp->first->second = 'I am a second level hash value';
142              
143             you can then access hash values either with or without braces notation
144              
145             $jsonp->firstlevelhashvalue = 5;
146             print $jsonp->firstlevelhashvalue; # will print 5
147              
148             it is equivalent to:
149              
150             $jsonp->{firstlevelhashvalue} = 5;
151             print $jsonp->{firstlevelhashvalue};
152              
153             you can even build a tree:
154              
155             $jsonp->first->second = 'hello!';
156             print $jsonp->first->second; # will print "hello!"
157              
158             it is the same as:
159              
160             $jsonp->{first}->{second} = 'hello!';
161             print $jsonp->{first}->{second};
162              
163             or (the perl "array rule"):
164              
165             $jsonp->{first}{second} = 'hello!';
166             print $jsonp->{first}{second};
167              
168             or even (deference ref):
169              
170             $$jsonp{first}{second} = 'hello!';
171             print $$jsonp{first}{second};
172              
173             you can insert hashes at any level of structure and they will become callable with the built-in convenience shortcut:
174              
175             my $obj = {a => 1, b => 2};
176             $jsonp->first->second = $obj;
177             print $jsonp->first->second->b; # will print 2
178             $jsonp->first->second->b = 3;
179             print $jsonp->first->second->b; # will print 3
180              
181             you can insert also array at any level of structure and the nodes (hashrefs) within resulting structure will become callable with the built-in convenience shortcut. You will need to call C<-E[index]> in order to access them, though:
182              
183             my $ary = [{a => 1}, 2];
184             $jsonp->first->second = $ary;
185             print $jsonp->first->second->[1]; # will print 2
186             print $jsonp->first->second->[0]->a; # will print 1
187             $jsonp->first->second->[0]->a = 9;
188             print $jsonp->first->second->[0]->a; # will print 9 now
189              
190             you can almost freely interleave above listed styles in order to access to elements of JSONP object. As usual, respect I<_private> variables if you don't know what you are doing. One value-leaf/object-node element set by the convenience notation shortcut will be read by normal hash access syntax. You can delete elements from the hash tree, though it is not supported via the convenience notation. You can use it, but the last node has to be referenced via braces notation:
191              
192             my $j = JSONP->new;
193             $j->firstnode->a = 5;
194             $j->firstnode->b = 9;
195             $j->secondnode->thirdnode->a = 7;
196             delete $j->secondnode->{thirdnode}; # will delete thirdnode as expected in hash structures.
197              
198             you can compare the JSONP object with another JSONP object, Perl data structure or JSON string via C and C overloaded operators, it will return true if the two operands will result in same JSON structure and values:
199              
200             my $j = JSONP->new(
201             {
202             firstkey => 5,
203             secondkey => [1, 2, 3],
204             thirdkey => {
205             nested => \1
206             }
207             }
208             );
209              
210             my $json = '
211             {
212             "thirdkey": {"nested": true},
213             "firstkey": 5,
214             "secondkey": [1, 2, 3]
215             }
216             ';
217              
218             say $j eq $json ? 'the same' : 'different'; # will print 'the same'
219             say $j ne $json ? 'different' : 'the same'; # will print 'the same'
220             say $j eq $j ? 'the same' : 'different'; # will print 'the same'
221             say $j ne $j ? 'different' : 'the same'; # will print 'the same'
222             say $j eq 'a random string, not a valid JSON' ? 'the same' : 'different'; # will print 'different'
223             say $j eq '{"akey": "something"}' ? 'the same' : 'different'; # will print 'different'
224              
225             TODO: will investigate if possible to implement deletion using exclusively the convenience notation feature.
226              
227             IMPORTANT NOTE: while using the convenience notation without braces, if you autovivify a hierarchy without assigning anything to the last item, or assigning it an B>ined value, JSONP will assign to the last element a zero string ( '' ). Since it evaluates to false in a boolean context and can be safely catenated to other strings without causing runtime errors you can avoid several I checks without the risk to incur in runtime errors. The only dangerous tree traversal can occur if you try to treat an object node as an array node, or vice versa.
228              
229             IMPORTANT NOTE 2: remember that all the method names of the module cannot be used as key names via convenience notation feature, at any level of the response tree. You can set such key names anyway by using the braces notation. To retrieve their value, you will need to use the brace notation for the node that has the key equal to a native method name of this very module. It is advisable to assign the branch that contains them to an higher level node:
230              
231             my $j = JSONP->new;
232             $j->firstnode = 5;
233             my $branch = {};
234             $branch->{debug} = 0; # debug is a native method name
235             $branch->{serialize} = 1; # serialize is a native method name
236             $j->secondnode = $branch; # $branch structure will be grafted and relative nodes blessed accordingly
237             say $j->secondnode->{serialize}; # will print 1
238              
239             IMPORTANT NOTE 3: deserialized booleans from JSON are turned into referenes to scalars by JSON module, to say JSON I will turn into a Perl I<\1> and JSON I will turn into a Perl I<\0>. JSONP module detects boolen context so when you try to evaluate one of these values in a boolean context it correctly returns the actual boolean value hold by the leaf instead of the reference (that would always evaluate to I even for I<\0>), to say will dereference I<\0> and I<\1> in order to return I<0> and I<1> respectively.
240              
241             $j->graft('testbool', q|{"true": true, "false":false}|);
242             say $j->testbool->true;
243             say $j->testbool->false;
244             say !! $j->testbool->true;
245             say !! $j->testbool->false;
246              
247             NOTE: in order to get a "pretty print" via serialize method you will need to either call I or I methods before serialize, use I if you want to serialize a deeper branch than the root one. If your JSONP object/branch is an ARRAY object the internal I<_pretty> member that stores the related setting for I in the object branch cannot exist and hence cannot be set/used, to circumvent this inconvenience you can pass a true value to I:
248              
249             my $j = JSONP->new->debug;
250             $j->firstnode->a = 5;
251             $j->firstnode->b = 9;
252             $j->secondnode->thirdnode->a = 7;
253             my $pretty = $j->serialize; # will get a pretty print
254             my $deepser = $j->firstnode->serialize; # won't get a pretty print, because deeper than root
255             my $prettydeeper = $j->firstnode->pretty->serialize; # will get a pretty print, because we called I first
256              
257             my $j = JSONP->new(['one', 'two', 'three']);
258             $j->serialize(1); # will get a pretty print
259             $j->serialize; # will get a normal print
260             $j->pretty->serialize; # ->pretty call will be ignored cause $j is an array, you will get a normal print
261              
262             =head1 DESCRIPTION
263              
264             The purpose of JSONP is to give an easy and fast way to build JSON-only web services that can be used even from a different domain from which one they are hosted on. It is supplied only the object interface: this module does not export any symbol, apart the optional pointer to its own instance in the CGI environment (not possible in mod_perl environment).
265             Once you have the instance of JSONP, you can build a response hash tree, containing whatever data structure, that will be automatically sent back as JSON object to the calling page. The built-in automatic cookie session keeping uses a secure SHA256 to build the session key. The related cookie is HttpOnly, Secure (only SSL) and with path set way down the one of current script (keep the authentication script in the root of your scripts path to share session among all scripts). For high trusted intranet environments a method to disable the Secure flag has been supplied. The automatically built cookie key will be long exactly 64 chars (hex format).
266             You can retrieve parameters supplied from browser either via GET, POST, PUT, or DELETE by accessing the reserved I key of JSONP object. For example the value of a parameter named I will be accessed via $j->params->test. In case of POSTs or PUTs of application/json requests (JSONP application/javascript requests are always loaded as GETs) the JSONP module will transparently detect them and populate the I key with the deserialization of posted JSON, note that in this case the JSON being P(OS|U)Ted must be an object and not an array, having a I param key on the first level of the structure in order to point out the corresponding function to be invoked.
267             You have to provide the string name or sub ref (the module accepts either way) of your own I and I functions. The AAA (aaa) function will get called upon every request with the session key (retrieved from session cookie or newly created for brand new sessions) as argument. That way you will be free to implement routines for authentication, authorization, access, and session tracking that most suit your needs, together with rules for user/groups to access the methods you expose. Your AAA function must return the session string (if you previously saved it, read on) if a valid session exists under the given key. A return value evaluated as false by perl will result in a 'forbidden' response (you can add as much errors as you want in the I array of response object). B otherwise you will give access to all users. If you want you can check the invoked method under the req parameter (see query method) in order to implement your own access policies. B the request has been B (B)The AAA function will be called a second time just before the response to client will be sent out, the module checks for changes in session by concurrent requests that would have executed in meanwhile, and merges their changes with current one by a smart recursive data structure merge routine. Then it will call the AAA function again with the session key as first argument, and a serialized string of the B branch as second (as you would have modified it inside your called function). This way if your AAA function gets called with only one paramenter it is the begin of the request cycle, and you have to retrieve and check the session saved in your storage of chose (memcached, database, whatever), if it gets called with two arguments you can save the updated session object (already serialized as JSON) to the storage under the given key. The B key of JSONP object will be reserved for session tracking, everything you will save in that branch will be passed serialized to your AAA function right before the response to client. It will be also populated after the serialized string you will return from your AAA function at the beginning of the request cycle. The login function will get called with the current session key (from cookie or newly created) as parameter, you can retrieve the username and password passed by the query method, as all other parameters. This way you will be free to give whatever name you like to those two parameters. Return the outcome of login attempt in order to pass back to login javascript call the state of authentication. Whatever value that evaluates to true will be seen as "authentication ok", whatever value that Perl evaluates to false will be seen as "authentication failed". Subsequent calls (after authentication) will track the authentication status by mean of the session string you return from AAA function.
268             If you need to add a method/call/feature to your application you have only to add a sub with same name you will pass under I parameter from frontend.
269              
270             =head2 METHODS
271              
272             =cut
273              
274             sub import {
275 1     1   11 my ($self, $name) = @_;
276 1 50       3 return if $ENV{MOD_PERL};
277 1 50       13 return unless $name;
278 0 0       0 die 'not valid variable name' unless $name =~ /^[a-z][0-9a-zA-Z_]{0,63}$/;
279 0         0 my $symbol = caller() . '::' . $name;
280             {
281 1     1   366 no strict 'refs'; ## no critic
  1         2  
  1         897  
  0         0  
282 0         0 *$symbol = \JSONP->new;
283             }
284             }
285              
286             =head3 new
287              
288             class constructor. The options have to be set by calling correspondant methods (see below). You can pass a Perl object reference (hash or array) or a JSON string to the constructor, and it will populate automatically the objext, note that when you are using the object as a manager for a web service, .
289              
290             my $h = {
291             a => 1,
292             b => 2
293             }:
294             my $j = JSONP->new($h);
295             say $j->serialize;
296              
297             my $a = ['a', 'b', 'c'];
298             my $j = JSONP->new($a);
299             say $j->serialize;
300              
301             my $json = '{"a" : 1, "b" : 2}';
302             my $j = JSONP->new($json);
303             say $j->serialize;
304              
305             =cut
306              
307             sub new {
308 4     4 1 85 my ($class, $json) = @_;
309              
310 4 100       11 return bless {}, $class unless defined $json;
311              
312 3   50     8 my $type = reftype($json) // '';
313 3 50 33     8 if ($type eq 'HASH' || $type eq 'ARRAY') {
314             # shallow blessing to avoid constructor overhead on large data structures
315             # on-fly blessing is performed on dynamic traversal in AUTOLOAD and loop
316 3         7 return bless $json, $class;
317             }
318              
319 0 0       0 if ($type eq '') {
320 0         0 eval{
321 0         0 local $SIG{'__DIE__'};
322 0   0     0 $json = JSON->new->decode($json // '');
323             };
324              
325 0 0       0 unless($@) {
326             # shallow blessing to avoid constructor overhead on large data structures
327             # on-fly blessing is performed on dynamic traversal in AUTOLOAD and loop
328 0         0 return bless $json, $class;
329             }
330             }
331              
332 0         0 my $self = bless {}, $class;
333 0         0 $self->raiseError('incorrect argument (JSON string or Perl data structure) passed to JSONP constructor');
334 0         0 $self;
335             }
336              
337             =head3 run
338              
339             executes the subroutine specified by req paramenter, if it exists, and returns the JSON output object to the calling browser. This have to be the last method called from JSONP object, because it will call the requested function and return the set object as JSON one.
340              
341             =cut
342              
343             sub _auth {
344 0     0   0 my ($self, $sid, $session) = @_;
345 0         0 my $authenticated = eval {
346 0         0 local $SIG{'__DIE__'};
347 0         0 $self->{_aaa_sub}->($sid, $session);
348             };
349              
350 0 0       0 if($@){
351 0 0       0 $self->{eval} = $@ if $self->{_debug};
352 0         0 $self->raiseError('unclassified error');
353 0         0 $authenticated = 0;
354             }
355              
356 0         0 $authenticated;
357             }
358              
359             sub run {
360 0     0 1 0 my $self = shift;
361 0         0 $self->{_is_root_element} = 1;
362 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
363 0         0 $self->{_authenticated} = 0;
364 0         0 $self->{error} = \0;
365 0         0 $self->errors = [];
366 0         0 $self->{_passthrough} = 0;
367 0         0 $self->{_mimetype} = 'text/html';
368 0         0 $self->{_html} = 0;
369 0         0 $self->{_mod_perl} = defined $ENV{MOD_PERL};
370 0         0 $self->{_jsonp_version} = $VERSION;
371             # File::Temp will remove the tempdir and its content on after request end
372 0         0 $self->{_tempdir} = File::Temp->newdir;
373 0         0 my $curdir = Cwd::cwd;
374             # Taint mode
375 0 0       0 $curdir = $curdir =~ m{(/.*)} ? $1 : '';
376 0         0 $self->{_curdir} = $curdir;
377             #$ENV{PATH} = '' if $self->{_taint_mode} = ${^TAINT};
378 0 0       0 die "you have to provide an AAA function" unless $self->{_aaa_sub};
379 0         0 my $r = CGI->new;
380 0         0 $$self{_cgi} = $r;
381             # this will enable us to give back the unblessed reference
382 0         0 my %params = $r->Vars;
383             # we assume all inputs are UTF-8, (XHR default encoding anyway) but check if params are already decoded for safety
384 0         0 for (keys %params) {
385 0 0       0 next if utf8::is_utf8($params{$_});
386             # be wary on input UTF-8 format (use strict UTF-8 mode, not loose utf8)
387 0         0 $params{$_} = Encode::decode('UTF-8', $params{$_});
388             }
389 0   0     0 my $contype = $r->content_type // '';
390 0         0 my $method = $r->request_method;
391 0         0 $self->{_request_method} = $method;
392 0 0 0     0 if($contype =~ m{application/json} && scalar keys %params == 1){
393 0         0 my $payload;
394 0 0       0 if($method eq 'POST'){
    0          
395 0         0 $payload = $params{POSTDATA};
396             } elsif ($method eq 'PUT'){
397 0         0 $payload = $params{PUTDATA};
398             } else {
399 0         0 $payload = '{}'; # dummy one, fallback for invalid requests
400             }
401              
402 0         0 my $success = $self->graft('params', $payload);
403              
404 0 0       0 unless($success){
405 0         0 $self->raiseError('invalid input JSON');
406             }
407              
408             } else {
409 0         0 $self->params = \%params;
410             }
411              
412 0 0 0     0 unless((reftype $self->params // '') eq 'HASH'){
413 0         0 $self->params = {};
414 0         0 $self->raiseError('invalid input JSON type (array)');
415             }
416              
417 0 0       0 if($self->{_rest}){
418 0         0 my $name = $0;
419 0         0 $name =~ m{([^/]+)$};
420 0   0     0 $name = $1 // '';
421 0         0 $self->{params}->{req} = $name;
422             }
423              
424 0   0     0 my $req = $self->{params}->{req} // '';
425 0   0     0 $req =~ /^([a-z][0-9a-zA-Z_\.]{1,63})$/; $req = $1 // '';
  0         0  
426 0         0 my $sid = $r->cookie('sid');
427              
428 0         0 my $map = caller() . '::' . $req;
429 0         0 my $session = $self->_auth($sid);
430 0         0 $self->{_authenticated} = ! ! $session;
431 0 0       0 if($self->{_authenticated}){
432 0 0       0 $self->session = {} unless $self->graft('session', $session);
433             } else {
434 0         0 $self->session = {};
435             }
436              
437 0         0 my $isloginsub = \&$map == $self->{_login_sub};
438              
439 0         0 my $header = {-type => 'application/javascript', -charset => 'UTF-8'};
440 0 0 0     0 unless ( $sid && !$isloginsub) {
441 0         0 my $h = Digest::SHA->new(256);
442 0         0 my @us = gettimeofday;
443 0 0       0 $h->add(@us, map($r->http($_) , $r->http() )) if $self->{_insecure_session};
444 0 0       0 $h->add(@us, map($r->https($_), $r->https())) unless $self->{_insecure_session};
445 0         0 $sid = $h->hexdigest;
446 0         0 my $current_path = $r->url(-absolute=>1);
447 0         0 $current_path =~ s|/[^/]*$||;
448             my $cookie = {
449             -name => 'sid',
450             -value => $sid,
451             -path => $current_path,
452             -secure => !$self->{_insecure_session},
453 0         0 -httponly => 1,
454             # TODO test SameSite on IE11 on Windows 8 and Safari on MacOS X
455             #-samesite => 'Strict'
456             };
457 0 0       0 $cookie->{-expires} = "+$$self{_session_expiration}s" if $self->{_session_expiration};
458 0         0 $header->{-cookie} = $r->cookie($cookie);
459             }
460              
461 0 0 0     0 if (! ! $session && defined &$map || $isloginsub) {
    0 0        
462 0         0 eval {
463 0         0 local $SIG{'__DIE__'};
464 1     1   7 no strict 'refs'; ## no critic
  1         2  
  1         1647  
465 0         0 my $outcome = &$map($sid);
466 0 0       0 $self->{_authenticated} = $outcome if $isloginsub;
467             };
468              
469 0 0       0 if($@){
470 0 0       0 $self->{eval} = $@ if $self->{_debug};
471 0         0 $self->raiseError('unclassified error');
472             }
473              
474             # save back the session only during responses to PUT and POST HTTP methods
475 0 0 0     0 if($self->{_authenticated} && ($method eq 'POST' || $method eq 'PUT')){
      0        
476             # get session last changes made by concurrent requests
477             # and merge them with current session right before to
478             # pass it back to aaa sub that will save it to storage
479             # note that current session keys/values will override
480             # concurrent ones, see _merge function for details
481 0         0 my $concurrentSession = $self->_auth($sid);
482 0         0 my $thisSession = $self->session->serialize;
483 0         0 $self->graft('thisSession', $thisSession);
484 0         0 delete $self->{session};
485 0         0 $self->graft('session', $concurrentSession);
486 0         0 $self->_merge($self->session, $self->thisSession);
487 0         0 delete $self->{thisSession};
488 0         0 $self->_auth($sid, $self->session->serialize);
489             }
490              
491             } elsif (! $req) {
492 0         0 $self->raiseError('invalid request');
493             } else {
494 0         0 $self->raiseError('forbidden');
495             }
496              
497             # give a nice JSON "true"/"false" output for authentication
498 0 0       0 $self->authenticated = $self->{_authenticated} ? \1 : \0;
499 0   0     0 $header->{'-status'} = $self->{_status_code} || 200;
500 0         0 $header->{"$_"} = $self->{_headers}->{$_} for keys %{$self->{_headers}};
  0         0  
501 0         0 my $callback;
502              
503             # debug
504             # my @layers = PerlIO::get_layers(select);
505              
506 0         0 my $ofh = select;
507             # avoid putting multiple encoding layers on STDOUT
508 0 0       0 binmode($ofh) && binmode($ofh, ':encoding(UTF-8)');
509 0 0       0 unless($self->{_passthrough}){
510 0 0       0 $callback = $self->params->callback if $self->{_request_method} eq 'GET';
511 0 0       0 if($callback){
512 0 0       0 $callback = $callback =~ /^([a-z][0-9a-zA-Z_]{1,63})$/ ? $1 : '';
513 0 0       0 $self->raiseError('invalid callback') unless $callback;
514             }
515              
516 0 0       0 $self->{_mimetype} = $callback ? 'application/javascript' : 'application/json';
517 0         0 $header->{'-type'} = $self->{_mimetype};
518 0         0 print $r->header($header);
519 0 0       0 print "$callback(" if $callback;
520 0         0 print $self->serialize;
521 0 0       0 print ')' if $callback;
522             } else {
523 0         0 $header->{'-type'} = $self->{_mimetype};
524 0 0       0 $header->{'-content-length'} = $self->{_blobsize} if $self->{_blobsize};
525 0 0       0 if ($self->{_html}) {
    0          
526 0         0 print $r->header($header);
527 0         0 print $self->{_html};
528             } elsif ($self->{_sendblob}) {
529 0 0       0 if ($self->{_inline}) {
530 0         0 $header->{'-disposition'} = 'inline';
531             } else {
532 0         0 $header->{'-attachment'} = $self->{_blobname};
533             }
534 0         0 print $r->header($header);
535 0         0 binmode $ofh;
536 0         0 print $self->{_sendblob};
537 0         0 delete $self->{_sendblob}; # release memory ASAP
538             } else {
539 0 0       0 if ($self->{_inline}) {
540 0         0 $header->{'-disposition'} = 'inline';
541             } else {
542 0 0 0     0 $header->{'-attachment'} = ($self->{_sendfile} // '') =~ /([^\/]+)$/ ? $1 : '';
543             }
544 0         0 print $r->header($header);
545 0         0 binmode $ofh;
546 0         0 print $self->_slurp($self->{_sendfile});
547             unlink $self->{_sendfile} if $self->{_delete_after_download}
548 0 0       0 }
549             }
550              
551             # exit any eventual temp directory before it is removed by File::Temp
552 0         0 chdir $self->{_curdir};
553              
554 0 0       0 if($self->{_mod_perl}){
555 0         0 my $rh = $r->r;
556             # suppress default Apache response
557 0   0     0 $rh->custom_response($self->{_status_code} || 200, '');
558 0         0 $rh->rflush;
559             }
560              
561 0         0 delete $self->{$_} for keys %$self; # force Perl to release memory in persistent environments
562              
563 0         0 $self;
564             }
565              
566             sub _slurp {
567 0     0   0 my ($self, $filename) = @_;
568 0 0 0     0 return '' unless $filename && -e -f -r $filename;
569 0         0 open my $fh, '<', $filename;
570 0         0 local $/;
571 0         0 <$fh>;
572             }
573              
574             sub _merge {
575             # merge $_[2] into $_[1]
576             # you must use params directly to make changes
577             # directly on referenced objects, otherwise
578             # perl will work on local copies of them
579              
580 0 0 0 0   0 unless((reftype $_[1] // '') eq 'HASH'){
581 0         0 $_[1] = $_[2];
582 0         0 return;
583             } # if $_[0] points to a scalar or array, $_[1] will prevail
584              
585 0 0       0 unless(scalar keys %{$_[1]}){
  0         0  
586 0         0 $_[1] = $_[2];
587 0         0 return;
588             } # if $_[0] is an empty hash, $_[1] will prevail
589              
590 0         0 my @keys = keys %{$_[1]};
  0         0  
591 0         0 push @keys, keys %{$_[2]};
  0         0  
592 0         0 my $resultOK = 1;
593 0         0 for(@keys){
594 0 0 0     0 if((reftype $_[1]->{$_} // '') ne 'HASH' || (reftype $_[2]->{$_} // '') ne 'HASH'){
      0        
      0        
595 0 0       0 $_[1]->{$_} = defined $_[2]->{$_} ? $_[2]->{$_} : $_[1]->{$_};
596 0         0 next;
597             }
598 0         0 $_[0]->_merge($_[1]->{$_}, $_[2]->{$_});
599             }
600             }
601              
602             =head3 html
603              
604             use this method if you need to return HTML instead of JSON, pass the HTML string as argument
605              
606             yoursubname
607             {
608             ...
609             $j->html($html);
610             }
611              
612             =cut
613              
614             sub html {
615 0     0 1 0 my ($self, $html, $mime) = @_;
616 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
617 0         0 $self->{_mimetype} = $mime;
618 0         0 $self->{_passthrough} = 1;
619 0         0 $self->{_html} = $html;
620 0         0 $self;
621             }
622              
623             =head3 sendblob
624              
625             use this method if you need to return a file held in memory instead of JSON, pass the bin/string blob as argument. MIME type will be set always to I.
626              
627             yoursubname
628             {
629             ...
630             $j->sendblob($fullfilepath, $isTmpFileToDelete);
631             }
632              
633             =cut
634              
635             sub sendblob {
636 0     0 1 0 my ($self, $blob, $attachmentName, $size, $inline) = @_;
637 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
638 0         0 $self->{_passthrough} = 1;
639 0         0 $self->{_mimetype} = 'application/octet-stream';
640 0   0     0 $self->{_sendblob} = $blob // '';
641 0   0     0 $self->{_blobname} = $attachmentName || 'file';
642 0         0 $self->{_blobsize} = 0 + $size;
643 0         0 $self->{_inline} = ! ! $inline;
644 0         0 $self;
645             }
646              
647             =head3 sendfile
648              
649             use this method if you need to return a file instead of JSON, pass the full file path as as argument. MIME type will be set always to I. The last parameter is evaluated as boolean and if true will make JSONP to delete the passed file after it has been downloaded.
650              
651             yoursubname
652             {
653             ...
654             $j->sendfile($fullfilepath, $isTmpFileToDelete);
655             }
656              
657             =cut
658              
659             sub sendfile {
660 0     0 1 0 my ($self, $filepath, $isTmpFileToDelete) = @_;
661 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
662 0         0 $self->{_passthrough} = 1;
663 0         0 $self->{_mimetype} = 'application/octet-stream';
664 0         0 $self->{_sendfile} = $filepath;
665 0         0 $self->{_delete_after_download} = ! ! $isTmpFileToDelete;
666 0         0 $self;
667             }
668              
669             =head3 file
670              
671             call this method to send a file with custom MIME type and/or if you want to set it as inline. The last parameter is evaluated as boolean and if true will make JSONP to delete the passed file after it has been downloaded.
672              
673             $j->file('path to file', $mimetype, $isInline, $isTmpFileToDelete);
674              
675             =cut
676              
677             sub file {
678 0     0 1 0 my ($self, $filepath, $mime, $inline, $isTmpFileToDelete) = @_;
679 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
680 0         0 $self->{_passthrough} = 1;
681 0         0 $self->{_mimetype} = $mime;
682 0         0 $self->{_sendfile} = $filepath;
683 0         0 $self->{_inline} = ! ! $inline;
684 0         0 $self->{_delete_after_download} = ! ! $isTmpFileToDelete;
685 0         0 $self;
686             }
687              
688             =head3 debug
689              
690             call this method before to call C to enable debug mode in a test environment, basically this one will output pretty printed JSON instead of "compressed" one. Furthermore with debug mode turned on the content of session will be returned to the calling page in its own json branch. You can pass a switch to this method (that will be parsed as bool) to set it I or I. It could be useful if you want to pass a variable. If no switch (or undefined one) is passed, the switch will be set as true. Example:
691              
692             $j->debug->run;
693              
694             is the same as:
695              
696             $j->debug(1)->run;
697              
698             =cut
699              
700             sub debug {
701 0     0 1 0 my ($self, $switch) = @_;
702 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
703 0 0       0 $switch = defined $switch ? !!$switch : 1;
704 0         0 $self->{_debug} = $switch;
705 0         0 $self->{_pretty} = $switch;
706 0         0 $self;
707             }
708              
709             =head3 pretty
710              
711             call this method before to call C to enable pretty output on I method, basically this one will output pretty printed JSON instead of "compressed" one. You can pass a switch to this method (that will be parsed as bool) to set it I or I. It could be useful if you want to pass a variable. If no switch (or undefined one) is passed, the switch will be set as true. Example:
712              
713             $j->pretty->run;
714              
715             is the same as:
716              
717             $j->pretty(1)->run;
718              
719             =cut
720              
721             sub pretty {
722 0     0 1 0 my ($self, $switch) = @_;
723 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
724 0 0       0 $switch = defined $switch ? !!$switch : 1;
725 0         0 $self->{_pretty} = $switch;
726 0         0 $self;
727             }
728              
729             =head3 insecure
730              
731             call this method if you are going to deploy the script under plain http protocol instead of https. This method can be useful during testing of your application. You can pass a switch to this method (that will parsed as bool) to set it on or off. It could be useful if you want to pass a variable. If no switch (or undefined one) is passed, the switch will be set as true.
732              
733             =cut
734              
735             sub insecure {
736 0     0 1 0 my ($self, $switch) = @_;
737 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
738 0 0       0 $switch = defined $switch ? !!$switch : 1;
739 0         0 $self->{_insecure_session} = $switch;
740 0         0 $self;
741             }
742              
743             =head3 rest
744              
745             call this method if you want to omit the I parameter and want that a sub with same name of the script will be called instead, so if your script will be I the sub I will be called instead of the one passed with I (that can be omitted at this point). You can pass a switch to this method (that will parsed as bool) to set it on or off. It could be useful if you want to pass a variable. If no switch (or undefined one) is passed, the switch will be set as true.
746              
747             =cut
748              
749             sub rest {
750 0     0 1 0 my ($self, $switch) = @_;
751 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
752 0 0       0 $switch = defined $switch ? !!$switch : 1;
753 0         0 $self->{_rest} = $switch;
754 0         0 $self;
755             }
756              
757             =head3 set_session_expiration
758              
759             call this method with desired expiration time for cookie in B, the default behavior is to keep the cookie until the end of session (until the browser is closed).
760              
761             =cut
762              
763             sub set_session_expiration {
764 0     0 1 0 my ($self, $expiration) = @_;
765 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
766 0         0 $self->{_session_expiration} = $expiration;
767 0         0 $self;
768             }
769              
770             =head3 query
771              
772             call this method to retrieve a named parameter, $jsonp->query(paramenter_name) will return the value of paramenter_name from query string. The method called without arguments returns all parameters in hash form
773              
774             =cut
775              
776             # TODO remove query method, now it is useless
777             sub query {
778 0     0 1 0 my ($self, $param) = @_;
779 0 0       0 $param ? $self->params->{$param} : $self->params;
780             }
781              
782             =head3 plain_json
783              
784             B parameter will be provided.>
785             call this function to enable output in simple JSON format (not enclosed within jquery_callback_name()... ). Do this only when your script is on the same domain of static content. This method can be useful also during testing of your application. You can pass a switch to this method (that will parsed as bool) to set it on or off. It could be useful if you want to pass a variable. If no switch (or undefined one) is passed, the switch will be set as true.
786              
787             =cut
788              
789             sub plain_json {
790 0     0 1 0 my ($self, $switch) = @_;
791 0 0 0     0 return $self unless (reftype $self // '') eq 'HASH';
792 0 0       0 $switch = defined $switch ? !!$switch : 1;
793 0         0 $self->{_plain_json} = $switch;
794 0         0 $self;
795             }
796              
797             =head3 aaa
798              
799             pass to this method the reference (or the name, either way will work) of the function under which you will manage AAA stuff, like session check, tracking and expiration, and ACL to exposed methods
800              
801             =cut
802              
803             sub aaa {
804 0     0 1 0 my ($self, $sub) = @_;
805 0 0       0 if (ref $sub eq 'CODE') {
806 0         0 $self->{_aaa_sub} = $sub;
807             }
808             else {
809 0         0 my $map = caller() . '::' . $sub;
810             {
811 1     1   7 no strict 'refs'; ## no critic
  1         2  
  1         128  
  0         0  
812 0 0       0 die "given AAA function does not exist" unless defined &$map;
813 0         0 $self->{_aaa_sub} = \&$map;
814             }
815             }
816 0         0 $self;
817             }
818              
819             =head3 login
820              
821             pass to this method the reference (or the name, either way will work) of the function under which you will manage the login process. The function will be called with the current session key (from cookie or automatically created). It will be your own business to save the key-value pair to the storage you choose (database, memcached, NoSQL, and so on). It is advised to keep the initial value associated with the key void, as the serialized I branch of JSONP object will be automatically passed to your aaa function at the end or request cycle, so you should save it from that place. If you want to access/modify the session value do it through the I branch via I<$jsonp-Esession-Ewhatever(value)> or I<$jsonp-E{session}{whatever} = value> or I<$jsonp-E{session}-E{whatever} = value> calls.
822              
823             =cut
824              
825             sub login {
826 0     0 1 0 my ($self, $sub) = @_;
827 0 0       0 if (ref $sub eq 'CODE') {
828 0         0 $self->{_login_sub} = $sub;
829             }
830             else {
831 0         0 my $map = caller() . '::' . $sub;
832             {
833 1     1   6 no strict 'refs'; ## no critic
  1         2  
  1         112  
  0         0  
834 0 0       0 die "given login function does not exist" unless defined &$map;
835 0         0 $self->{_login_sub} = \&$map;
836             }
837             }
838 0         0 $self;
839             }
840              
841             =head3 logout
842              
843             pass to this method the reference (or the name, either way will work) of the function under which you will manage the logout process. The function will be called with the current session key (from cookie or automatically created). It will be your own business to delete the key-value pair from the storage you choose (database, memcached, NoSQL, and so on).
844              
845             =cut
846              
847             sub logout {
848 0     0 1 0 my ($self, $sub) = @_;
849 0 0       0 if (ref $sub eq 'CODE') {
850 0         0 $self->{_logout_sub} = $sub;
851             }
852             else {
853 0         0 my $map = caller() . '::' . $sub;
854             {
855 1     1   6 no strict 'refs'; ## no critic
  1         2  
  1         1510  
  0         0  
856 0 0       0 die "given logout function does not exist" unless defined &$map;
857 0         0 $self->{_logout_sub} = \&$map;
858             }
859             }
860 0         0 $self;
861             }
862              
863             =head3 raiseError
864              
865             call this method in order to return an error message to the calling page. You can add as much messages you want, calling the method several times, it will be returned an array of messages to the calling page. The first argument could be either a string or a B. The second argument is an optional HTTP status code, the default will be 200.
866              
867             =cut
868              
869             sub raiseError {
870 2     2 1 5 my ($self, $message, $code, $customHeaders) = @_;
871 2 50 50     10 return $self unless (reftype $self // '') eq 'HASH';
872 2         9 $self->error = \1;
873 2 100 100     4 push @{$self->{errors}}, (reftype $message // '') eq 'ARRAY' ? @$message : $message;
  2         12  
874 2 100       7 $self->{_status_code} = $code if defined $code;
875 2 50       4 $self->{_headers} = $customHeaders if defined $customHeaders;
876              
877 2         4 $self;
878             }
879              
880             =head3 graft
881              
882             call this method to append a JSON object as a perl subtree on a node. This is a native method, only function notation is supported, lvalue assignment notation is reserved to autovivification shortcut feature. Examples:
883             $j->subtree->graft('newbranchname', '{"name" : "JSON object", "count" : 2}');
884             print $j->subtree->newbranchname->name; # will print "JSON object"
885             $j->sublist->graft->('newbranchname', '[{"name" : "first one"}, {"name" : "second one"}]');
886             print $j->sublist->newbranchname->[1]->name; will print "second one"
887             my $index = 1; print $j->sublist->newbranchname->$index->name; will print "second one" as well
888              
889             This method will return the reference to the newly added element if added successfully, a false value otherwise.
890              
891             =cut
892              
893             sub graft {
894 0     0 1 0 my ($self, $name, $json) = @_;
895              
896 0 0 0     0 return 0 unless (reftype $self // '') eq 'HASH';
897              
898 0         0 eval{
899 0         0 local $SIG{'__DIE__'};
900 0   0     0 $self->{$name} = JSON->new->decode($json // '');
901             };
902              
903 0 0       0 return 0 if $@;
904              
905             #_bless_tree returns the node passed to it blessed as JSONP
906 0         0 $self->_bless_tree($self->{$name});
907             }
908              
909             =head3 stack
910              
911             call this method to add a JSON object to a node-array. This is a native method, only function notation is supported, lvalue assignment notation is reserved to autovivification shortcut feature. Examples:
912              
913             $j->first->second = [{a => 1}, {b = 2}];
914             $j->first->second->stack('{"c":"3"}');
915             say $j->first->second->[2]->c; # will print 3;
916             my $index = 2; say $j->first->second->$index->c; # will print 3 as well
917              
918             this method of course works only with nodes that are arrays. Be warned that the decoded JSON string will be added as B to the array, so depending of the JSON string you pass, you can have an element that is an hashref (another "node"), a scalar (a "value") or an arrayref (array of arrays, if you want). This method will return the reference to the newly added element if added successfully, a false value otherwise. Combining this to graft method you can do crazy things like this:
919              
920             my $j = JSONP->new;
921             $j->firstnode->graft('secondnode', '{"a" : 1}')->thirdnode = [];
922             $j->firstnode->secondnode->thirdnode->stack('{"b" : 9}')->fourthnode = 10;
923             say $j->firstnode->secondnode->a; # will print 1
924             say $j->firstnode->secondnode->thirdnode->[0]->b; # will print 9
925             say $j->firstnode->secondnode->thirdnode->[0]->fourthnode; # will print 10
926             my $index = 0; say $j->firstnode->secondnode->thirdnode->$index->fourthnode; # will print 10 as well
927              
928             =cut
929              
930             sub stack {
931 0     0 1 0 my ($self, $json) = @_;
932              
933 0 0 0     0 return 0 unless (reftype $self // '') eq 'ARRAY';
934              
935 0         0 eval{
936 0         0 local $SIG{'__DIE__'};
937 0   0     0 push @$self, JSON->new->decode($json // '');
938             };
939 0 0       0 return 0 if $@;
940              
941             #_bless_tree returns the node passed to it blessed as JSONP
942 0         0 $self->_bless_tree($self->[$#{$self}]);
  0         0  
943             }
944              
945             =head3 append
946              
947             call this method to add a Perl object to a node-array. This is a native method, only function notation is supported, lvalue assignment notation is reserved to autovivification shortcut feature. Examples:
948              
949             $j->first->second = [{a => 1}, {b = 2}];
950             $j->first->second->append({c => 3});
951             say $j->first->second->[2]->c; # will print 3;
952              
953             this method of course works only with nodes that are arrays. Be warned that the element will be added as B to the array, so depending of the element you pass, you can have an element that is an hashref (another "node"), a scalar (a "value") or an arrayref (array of arrays, if you want). This method will return the reference to the newly added element if added successfully, a false value otherwise. You can do crazy things like this:
954              
955             my $j = JSONP->new;
956             $j->firstnode->secondnode->a = 1;
957             $j->firstnode->secondnode->thirdnode = [];
958             $j->firstnode->secondnode->thirdnode->append({b => 9})->fourthnode = 10;
959             say $j->firstnode->secondnode->a; # will print 1
960             say $j->firstnode->secondnode->thirdnode->[0]->b; # will print 9
961             say $j->firstnode->secondnode->thirdnode->[0]->fourthnode; # will print 10
962              
963             =cut
964              
965             sub append {
966 0     0 1 0 my ($self, $el) = @_;
967              
968 0 0 0     0 return 0 unless (reftype $self // '') eq 'ARRAY';
969              
970 0         0 push @$self, $el;
971              
972             #_bless_tree returns the node passed to it blessed as JSONP
973 0         0 $self->_bless_tree($self->[$#{$self}]);
  0         0  
974             }
975              
976             =head3 loop
977              
978             when called from an array node it will loop over its elements returning the B> to the current one, so I
979             or copy its value to perform calculation with a copy. Returning the reference assure that loops over arrays items that evaluate as false
980             won't stop until actual array end.
981             Of course this method has the overhead of a function call on every cycle, so use it for convenience on small arrays when performance is not critical.
982             You can also want to use this when the operation to perform on each cycle take a significant amount of time where the overhead becomes negligible.
983             In general avoid to use it in tight high-performance needing loops. Note that the returned item will be a JSONP object (or a JSONP derived type if you subclass it) B, in case the returned item is a raw HASH or ARRAY, it will be blessed with the same class of the array we are looping onto (typically JSONP itself), so the item will hold all the JSONP syntactic sugar and methods.
984             Never exit $array->loop cycles using I to avoid memory leaks, you should avoid to use this method when you expect to early exit the cycle.
985              
986             my $j = JSONP->new;
987             $j->an->array = [
988             [11, 12],
989             [21, 22]
990             ];
991              
992             say $j->an->pretty->serialize;
993              
994             while (my $row = $j->an->array->loop) {
995             while (my $field = $$row->loop){
996             my $acopy = $$field;
997             $$field++;
998             }
999             }
1000              
1001             say $j->an->pretty->serialize;
1002              
1003             =cut
1004              
1005             sub loop {
1006 0     0 1 0 my ($self) = @_;
1007 0   0     0 my $refself = reftype $self // '';
1008 0         0 my $class = ref $self; # bless in cases we have not a deep recursive blessing
1009 0 0       0 return undef unless $refself eq 'ARRAY'; ## no critic
1010             # use different counter for every array
1011 0         0 state $indexes = {};
1012 0         0 my $addr = 0 + $self;
1013 0         0 my $index = $indexes->{$addr};
1014 0         0 $index += 0;
1015             # array can change during loop
1016 0         0 my $size = @$self;
1017              
1018 0 0       0 if ($index < $size){
1019             # refs are never undef so we can loop
1020             # over false scalar items as well
1021 0         0 my $item = $self->[$indexes->{$addr}++];
1022 0         0 my $reftype = ref $item;
1023             # bless the item if it is an unblessed hash or array reference (avoid to touch blessed objects)
1024 0 0 0     0 bless $item, $class if $reftype eq 'HASH' || $reftype eq 'ARRAY';
1025 0         0 return \$item;
1026             } else {
1027             # reset counter for next loops
1028             # and avoid memory leaks...
1029             # note that the loops exited with "last"
1030             # will leak few bytes until program end,
1031             # with about 8 bytes per loop it's safe
1032 0         0 delete $indexes->{$addr};
1033 0         0 return undef; ## no critic
1034             }
1035             }
1036              
1037             =head3 serialize
1038              
1039             call this method to serialize and output a subtree:
1040              
1041             $j->subtree->graft('newbranchname', '{"name" : "JSON object", "count" : 2}');
1042             print $j->subtree->newbranchname->name; # will print "JSON object"
1043             $j->sublist->graft->('newbranchname', '[{"name" : "first one"}, {"name" : "second one"}]');
1044             print $j->sublist->newbranchname->[1]->name; will print "second one"
1045             $j->subtree->newbranchname->graft('subtree', '{"name" : "some string", "count" : 4}');
1046             print $j->subtree->newbranchname->subtree->serialize; # will print '{"name" : "some string", "count" : 4}'
1047              
1048             if you have a JSONP ARRAY object I call won't be effective. To circumvent this limitation you can pass an override I switch to serialize:
1049              
1050             $j = JSONP->new(['one', 'two', 'three']);
1051             print $j->serialize(1);
1052              
1053             IMPORTANT NOTE: do not assign any reference to a sub to any node, example:
1054              
1055             $j->donotthis = sub { ... };
1056              
1057             for now the module does assume that nodes/leafs will be scalars/hashes/arrays, so same thing is valid for filehandles.
1058              
1059             =cut
1060              
1061             sub serialize {
1062 10     10 1 16 my ($self, $prettyoverride, $canonical) = @_;
1063 10         12 $canonical = !! $canonical;
1064             # $prettyoverride to be used with ARRAY objects where we cannot have _pretty member
1065 10   50     19 $prettyoverride //= 0;
1066 10         9 my $out;
1067 10 50 66     46 my $pretty = (reftype $self // '') eq 'HASH' && $self->{_pretty} ? 1 : 0;
1068 10   33     29 $pretty ||= $prettyoverride;
1069              
1070 10 50       13 eval{
1071 10         25 local $SIG{'__DIE__'};
1072 10         79 $out = JSON->new->canonical($canonical)->pretty($pretty)->allow_unknown->allow_blessed->convert_blessed->encode($self);
1073             } || $@;
1074             }
1075              
1076             =head3 tempdir
1077              
1078             returns a temporary directory whose content will be removed at the request end.
1079             if you pass a relative path, it will be created under the random tmp directory.
1080             if creation fails, a boolean false will be retured (void string).
1081              
1082             my $path = $j->tempdir; # will return something like /tmp/systemd-private-af123/tmp/nRmseALe8H
1083             my $path = $j->tempdir('DIRNAME'); # will return something like /tmp/systemd-private-af123/tmp/nRmseALe8H/DIRNAME
1084              
1085             =cut
1086              
1087             sub tempdir {
1088 0     0 1 0 my ($self, $path) = @_;
1089 0 0 0     0 return '' unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
1090 0 0       0 return $self->{_tempdir}->dirname unless $path;
1091 0         0 return $self->_makePath($path);
1092             }
1093              
1094             =head3 ctwd
1095              
1096             changes current working directory to a random temporary directory whose content will be removed at the request end.
1097             if you pass a path, it will be appended to the temporary directory before cwd'ing on it, bool outcome will be returned.
1098             if creation fails, a boolean false will be returned (void string).
1099              
1100             my $cwdOK = $j->ctwd;
1101              
1102             =cut
1103              
1104             sub ctwd {
1105 0     0 1 0 my ($self, $path) = @_;
1106 0 0 0     0 return '' unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
1107 0 0       0 return chdir $self->{_tempdir} unless $path;
1108 0         0 $path = $self->_makePath($path);
1109 0 0       0 return $path ? chdir $path : '';
1110             }
1111              
1112             sub _makePath {
1113 0     0   0 my ($self, $path) = @_;
1114 0 0 0     0 return '' unless (reftype $self // '') eq 'HASH' && $self->{_is_root_element};
      0        
1115 0         0 my $mkdirerr;
1116 0         0 $path = "$$self{_tempdir}/$path";
1117 0         0 File::Path::make_path($path, {error => \$mkdirerr});
1118 0 0       0 if(@$mkdirerr){
1119 0         0 for my $direrr (@$mkdirerr){
1120 0         0 my ($curdir, $curmessage) = %$direrr;
1121 0         0 say STDERR "error while attempting to create $curdir: $curmessage";
1122             }
1123              
1124             # if creation fails set $path to a "false" string
1125 0         0 $path = '';
1126             }
1127              
1128 0         0 $path;
1129             }
1130              
1131             sub _bless_tree {
1132 183     183   233 my ($self, $node) = @_;
1133 183         218 my $class = ref $self;
1134 183         214 my $refnode = ref $node;
1135             # proceed only with hashes or arrays not already blessed
1136 183 100       301 return $node if $refnode eq $class;
1137             #my $reftype = reftype($node) // '';
1138             #return unless $reftype eq 'HASH' || $reftype eq 'ARRAY';
1139             # to not change class to objects grafted to JSONP tree
1140 90 100 100     256 return $node unless $refnode eq 'HASH' || $refnode eq 'ARRAY';
1141 25         31 bless $node, $class;
1142 25 100       40 if ($refnode eq 'HASH'){
1143 17         51 $self->_bless_tree($node->{$_}) for keys %$node;
1144             }
1145 25 100       42 if ($refnode eq 'ARRAY'){
1146 8         18 $self->_bless_tree($_) for @$node;
1147             }
1148 25         33 $node;
1149             }
1150              
1151             sub TO_JSON {
1152 10     10 0 16 my $self = shift;
1153 10         10 my $output;
1154              
1155 10 100 50     42 return [@$self] if (reftype $self // '') eq 'ARRAY';
1156              
1157 8         10 $output = {};
1158 8         19 for(keys %$self){
1159 24         26 my $skip = 0;
1160              
1161 24 50       33 unless($self->{_debug}){
1162 24 50       32 if($self->{_is_root_element}){
1163 0 0       0 $skip++ if $_ =~ /_sub$/;
1164 0 0       0 $skip++ if $_ eq 'session';
1165 0 0       0 $skip++ if $_ eq 'params';
1166             }
1167 24 50       45 $skip++ if $_ =~ /^_/;
1168             }
1169              
1170 24 50       31 next if $skip;
1171              
1172 24         34 $output->{$_} = $self->{$_};
1173             }
1174 8         69 return $output;
1175             }
1176              
1177             # avoid calling AUTOLOAD on destroy
1178       0     sub DESTROY{}
1179              
1180             sub AUTOLOAD : lvalue {
1181 149     149   789 my $classname = ref $_[0];
1182 149         154 my $validname = q{[^:'[:cntrl:]]{0,1024}};
1183 149         649 our $AUTOLOAD =~ /^${classname}::($validname)$/;
1184 149         277 my $key = $1;
1185 149 50       237 die "illegal key name, must be of $validname form\n$AUTOLOAD" unless $key;
1186 149   50     372 my $arraynode = (reftype($_[0]) // '') eq 'ARRAY';
1187 149 50 33     248 die "array indexes must be unsigned integers" if $arraynode && $key !~ /^\d+$/;
1188 149 100       245 my $miss = want('OBJECT') ? {} : undef;
1189 149 50       5833 my $retval = $arraynode ? $_[0]->[$key] : $_[0]->{$key}; # can be undef
1190 149   100     462 $retval = $_[1] // $retval // $miss;
      100        
1191 149 50 66     220 return '' if want('RVALUE') && ! defined $retval;
1192 149 0 0     5108 return $$retval if want('BOOL') && (reftype($retval) // '') eq 'SCALAR' && $$retval == $$retval % 2;
      33        
      33        
1193              
1194 149 50       6107 if ($arraynode){
1195 0         0 $_[0]->[$key] = $retval;
1196 0         0 $_[0]->_bless_tree($_[0]->[$key]);
1197 0         0 return $_[0]->[$key];
1198             } else {
1199 149         207 $_[0]->{$key} = $retval;
1200 149         310 $_[0]->_bless_tree($_[0]->{$key});
1201 149         662 return $_[0]->{$key};
1202             }
1203             }
1204              
1205             =head1 NOTES
1206              
1207             =head2 NOTATION CONVENIENCE FEATURES
1208              
1209             In order to achieve autovivification notation shortcut, this module does not make use of perlfilter but does rather some gimmick with AUTOLOAD. Because of this, when you are using the convenience shortcut notation you cannot use all the names of public methods of this module (such I, I, I, and others previously listed on this document) as hash keys, and you must always use hash keys composed from any Unicode char that is not a posix defined control char, ' (apostrophe) and : (colon). You can also use keys composed of only digits, but then it must not be a literal, put it in a variable. In that case the key wil be interpreted as array index or hash key depending of the type of node you are calling it upon. The total lenght of the key must be not bigger than 1024 Unicode chars, this is an artificial limit set for security purposes. You can still set/access hash branches of whatever name using the brace notation. It is nonetheless highly discouraged the usage of underscore beginning keys through brace notation, at least at the top level of response hash hierarchy, in order to avoid possible clashes with private variable members of this very module.
1210              
1211             =head2 MINIMAL REQUIREMENTS
1212              
1213             this module requires at least perl 5.10 for its usage of "defined or" // operator
1214              
1215             =head2 DEPENDENCIES
1216              
1217             JSON and Want are the only non-core module used by this one, use of JSON::XS is strongly advised for the sake of performance. JSON::XS is been loaded transparently by JSON module when installed. CGI module is a core one at the moment of writing, but deprecated and likely to be removed from core modules in next versions of Perl.
1218              
1219             =head1 SECURITY
1220              
1221             Remember to always:
1222              
1223             =over 4
1224              
1225             =item 1. use taint mode
1226              
1227             =item 2. use parametrized queries to access databases via DBI
1228              
1229             =item 3. avoid as much as possible I, I, I, and so on
1230              
1231             =item 4. use SSL when you are keeping track of sessions
1232              
1233             =back
1234              
1235             =head1 HELP and development
1236              
1237             the author would be happy to receive suggestions and bug notification. If somebody would like to send code and automated tests for this module, I will be happy to integrate it.
1238             The code for this module is tracked on this L.
1239              
1240             =head1 LICENSE
1241              
1242             This library is free software and is distributed under same terms as Perl itself.
1243              
1244             =head1 COPYRIGHT
1245              
1246             Copyright 2014-2038 by Anselmo Canfora.
1247              
1248             =cut
1249              
1250             1;