File Coverage

blib/lib/App/Dochazka/CLI/Util.pm
Criterion Covered Total %
statement 131 198 66.1
branch 50 104 48.0
condition 16 53 30.1
subroutine 27 33 81.8
pod 13 13 100.0
total 237 401 59.1


line stmt bran cond sub pod time code
1             # *************************************************************************
2             # Copyright (c) 2014-2016, SUSE LLC
3             #
4             # All rights reserved.
5             #
6             # Redistribution and use in source and binary forms, with or without
7             # modification, are permitted provided that the following conditions are met:
8             #
9             # 1. Redistributions of source code must retain the above copyright notice,
10             # this list of conditions and the following disclaimer.
11             #
12             # 2. Redistributions in binary form must reproduce the above copyright
13             # notice, this list of conditions and the following disclaimer in the
14             # documentation and/or other materials provided with the distribution.
15             #
16             # 3. Neither the name of SUSE LLC nor the names of its contributors may be
17             # used to endorse or promote products derived from this software without
18             # specific prior written permission.
19             #
20             # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
21             # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22             # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23             # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
24             # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
25             # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
26             # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
27             # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
28             # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
29             # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30             # POSSIBILITY OF SUCH DAMAGE.
31             # *************************************************************************
32             #
33             # Util module - reusable components
34             #
35             package App::Dochazka::CLI::Util;
36              
37 23     23   1685 use 5.012;
  23         43  
38 23     23   71 use strict;
  23         24  
  23         335  
39 23     23   58 use warnings;
  23         20  
  23         491  
40              
41 23     23   453 use App::CELL qw( $CELL $log $meta $site );
  23         56668  
  23         1851  
42 23     23   9063 use App::Dochazka::Common qw( $t $today $tomorrow $yesterday init_timepiece );
  23         137031  
  23         2291  
43 23         2075 use App::Dochazka::CLI qw(
44             $current_emp
45             $current_priv
46             $debug_mode
47             $prompt_date
48             $prompt_century
49             $prompt_year
50             $prompt_month
51             $prompt_day
52 23     23   444 );
  23         21  
53 23     23   9457 use App::Dochazka::Common::Model::Employee;
  23         195366  
  23         525  
54 23     23   100 use Data::Dumper;
  23         26  
  23         933  
55 23     23   8532 use Date::Calc qw( check_date Add_Delta_Days );
  23         92860  
  23         1533  
56 23     23   161 use Exporter 'import';
  23         28  
  23         439  
57 23     23   72 use File::ShareDir;
  23         19  
  23         596  
58 23     23   9032 use Log::Any::Adapter;
  23         4633  
  23         61  
59 23     23   493 use Params::Validate qw( :all );
  23         23  
  23         2904  
60 23     23   94 use Scalar::Util qw( looks_like_number );
  23         23  
  23         725  
61 23     23   68 use Try::Tiny;
  23         26  
  23         869  
62 23     23   9160 use Web::MREST::CLI qw( normalize_filespec send_req );
  23         2549140  
  23         26405  
63              
64              
65              
66             =head1 NAME
67              
68             App::Dochazka::CLI::Util - Various reusable components
69              
70              
71              
72              
73             =head1 PACKAGE VARIABLES AND EXPORTS
74              
75             =cut
76              
77             our @EXPORT_OK = qw(
78             authenticate_to_server
79             datelist_from_token
80             determine_employee
81             lookup_employee
82             init_logger
83             init_prompt
84             month_alpha_to_numeric
85             normalize_date
86             normalize_time
87             parse_test
88             refresh_current_emp
89             rest_error
90             truncate_to
91             );
92              
93             our %month_map = (
94             'jan' => 1,
95             'feb' => 2,
96             'mar' => 3,
97             'apr' => 4,
98             'may' => 5,
99             'jun' => 6,
100             'jul' => 7,
101             'aug' => 8,
102             'sep' => 9,
103             'oct' => 10,
104             'nov' => 11,
105             'dec' => 12,
106             );
107              
108              
109              
110             =head1 FUNCTIONS
111              
112              
113             =head2 authenticate_to_server
114              
115             All communication between L and the L
116             server goes via the C routine in L. This
117             routine takes its connection parameters (address of REST server, nick and
118             password) from the following configuration parameters:
119              
120             $meta->MREST_CLI_URI_BASE
121             $meta->CURRENT_EMPLOYEE_NICK
122             $meta->CURRENT_EMPLOYEE_PASSWORD
123              
124             The first parameter, C, is assumed to be set before this
125             routine is called. The second and third are meta parameters and are set by
126             this routine.
127              
128             After setting the meta parameters, the routine causes a GET request for the
129             C resource to be send to the server, and uses the response
130             to initialize the C<$current_emp> and C<$current_priv> variables which are
131             imported from the L package.
132              
133             Takes PROPLIST with two properties:
134              
135             =over
136              
137             =item C<< user >>
138              
139             The username to authenticate as (defaults to 'demo')
140              
141             =item C<< password >>
142              
143             The password to use (defaults to the value of the C parameter)
144              
145             =back
146              
147             Since this routine returns the status object returned by the "GET
148             employee/self/priv" request, it is actually a wrapper around C.
149              
150             =cut
151              
152             sub authenticate_to_server {
153 15     15 1 1156 my %PROPLIST = (
154             user => 'demo',
155             @_,
156             );
157 15   33     78 $PROPLIST{'password'} = $PROPLIST{'password'} || $PROPLIST{'user'};
158              
159 15         62 $meta->set( 'CURRENT_EMPLOYEE_NICK', $PROPLIST{'user'} );
160 15         597 $meta->set( 'CURRENT_EMPLOYEE_PASSWORD', $PROPLIST{'password'} );
161              
162             # get info about us
163 15         466 my $status;
164             try {
165 15     15   298 $status = send_req( 'GET', '/employee/self/priv' );
166             } catch {
167 0     0   0 $status = $_;
168 15         92 };
169 15 50       157671 if ( !ref( $status ) ) {
170 0         0 die "AGHAUFF! $status\n";
171             }
172 15 50       56 return $status unless $status->ok;
173              
174             # authentication OK, initialize package variables
175 0         0 $current_emp = App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload->{'current_emp'} } );
  0         0  
176 0         0 $current_priv = $status->payload->{'priv'};
177 0         0 return $CELL->status_ok( 'DOCHAZKA_CLI_AUTHENTICATION_OK' );
178             }
179              
180              
181             =head2 datelist_from_token
182              
183             Takes a numeric month and a _DATELIST token - e.g. "5,6,10-13,2".
184              
185             Convert the token into an array of dates and return a reference. So, upon
186             success, the return value will look something like this:
187              
188             [ "2015-01-01", "2015-01-06", "2015-01-22" ]
189              
190             If there's a problem, writes an error message to the log and returns
191             undef.
192              
193             =cut
194              
195             sub datelist_from_token {
196 8     8 1 3130 my ( $token ) = @_;
197 8         21 $log->debug( "Entering " . __PACKAGE__ . "::datelist_from_token with token " . Dumper( $token ) );
198              
199 8 100 100     848 if ( $prompt_month < 1 or $prompt_month > 12 ) {
200 2         15 die "ASSERT ohayoa9I \$prompt_month set to illegal value";
201             }
202              
203 6         6 my @datelist;
204             #
205             # loop as long as subtokens are left
206 6   66     38 while ( defined( $token ) and my ( $subtoken ) = $token =~ m/^((\d{1,2})|(\d{1,2}-\d{1,2}))(?=(,|$))/ ) {
207              
208             #
209             # 1. chew off the subtoken
210 11 100       120 if ( $token =~ m/^$subtoken,/ ) {
    50          
211 5         26 $token =~ s/^$subtoken,//;
212             } elsif ( $token =~ m/^$subtoken$/ ) {
213 6         29 $token =~ s/^$subtoken$//;
214             } else {
215 0         0 die "AGACDKDFLQERIIeee!";
216             }
217              
218             #
219             # 2. if it's a range, convert it into a list of individual dates
220 11 100       27 if ( my ( $begin, $end ) = $subtoken =~ m/^(\d{1,2})-(\d{1,2})$/ ) {
221 4 50       9 if ( $begin >= $end ) {
222 0         0 die "AGHGGHSKSKDQ!!!!! Begin date must be less than end";
223             }
224 4         8 foreach my $n ( $begin..$end ) {
225 12         22 my $canonical_date = sprintf( "%04d-%02d-%02d", $prompt_year, $prompt_month, $n );
226 12         30 push @datelist, $canonical_date;
227             }
228             #
229             # 3. if not, convert it into a date
230             } else { # is a single date
231 7         19 my $canonical_date = sprintf( "%04d-%02d-%02d", $prompt_year, $prompt_month, $subtoken );
232 7         35 push @datelist, $canonical_date;
233             }
234             }
235              
236 6         13 return \@datelist;
237             }
238              
239              
240             =head2 determine_employee
241              
242             Given what might possibly be an employee specification (as obtained from the
243             user from the EMPLOYEE_SPEC token of the command line), return a status object
244             that will either be an error (not OK) or contain the employee object in the
245             payload.
246              
247             If the employee specification is empty or undefined, the payload will contain
248             the C<$current_emp> object.
249              
250             =cut
251              
252             sub determine_employee {
253 0     0 1 0 my $s_key = shift;
254 0 0       0 $log->debug( "Entering " . __PACKAGE__ . "::determine_employee with \$s_key ->" .
255             ( defined( $s_key ) ? $s_key : "undef" ) . "<-" );
256              
257 0 0       0 my $status = ( $s_key )
258             ? lookup_employee( key => $s_key, minimal => 1 )
259             : refresh_current_emp();
260             return ( $status->ok )
261             ? $CELL->status_ok( 'EMPLOYEE_LOOKUP',
262 0 0       0 payload => App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload } ) )
  0         0  
263             : rest_error( $status, "Employee lookup" );
264             }
265              
266              
267             =head2 lookup_employee
268              
269             EMPLOYEE_SPEC may be "nick=...", "sec_id=...", "eid=...", or simply
270             "employee=...", in which case we use a clever algorithm to look up employees
271             (i.e. try looking up search key as nick, sec_id, and EID - in that order).
272              
273             =cut
274              
275             sub lookup_employee {
276 0     0 1 0 my %ARGS = validate( @_,
277             {
278             key => { type => SCALAR },
279             minimal => { default => 0 },
280             }
281             );
282             print "Entering " . __PACKAGE__ . "::lookup_employee with search key " . Dumper( $ARGS{key} )
283 0 0       0 if $debug_mode;
284              
285 0 0       0 die( "AH! Not an EMPLOYEE_SPEC" ) unless $ARGS{key} =~ m/=/;
286              
287 0         0 my ( $key_spec, $key ) = $ARGS{key} =~ m/^(.*)\=(.*)$/;
288 0 0       0 my $minimal = $ARGS{minimal} ? '/minimal' : '';
289              
290 0         0 my $status;
291 0 0       0 if ( $key_spec =~ m/^emp/i ) {
    0          
    0          
    0          
292 0         0 $status = send_req( 'GET', "employee/nick/$key$minimal" );
293             BREAK_OUT: {
294 0 0 0     0 last BREAK_OUT if $status->not_ok and $status->payload and $status->payload->{'http_code'} == 403;
  0   0     0  
295 0 0 0     0 if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} == 404 ) {
      0        
296 0         0 $status = send_req( 'GET', "employee/sec_id/$key$minimal" );
297 0 0 0     0 if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} != 500 and looks_like_number( $key ) ) {
      0        
      0        
298 0         0 $status = send_req( 'GET', "employee/eid/$key$minimal" );
299             }
300             }
301             }
302             } elsif ( $key_spec =~ m/^nic/i ) {
303 0         0 $status = send_req( 'GET', "employee/nick/$key$minimal" );
304             } elsif ( $key_spec =~ m/^sec/i ) {
305 0         0 $status = send_req( 'GET', "employee/sec_id/$key$minimal" );
306             } elsif ( $key_spec =~ m/^eid/i ) {
307 0         0 $status = send_req( 'GET', "employee/eid/$key$minimal" );
308             } else {
309 0 0       0 die "AAAHAAAHHH!!! Invalid employee lookup key " . ( defined( $key_spec ) ? $key_spec : "undefined" )
310             }
311              
312 0         0 return $status;
313             }
314              
315              
316             =head2 init_logger
317              
318             Logger initialization routine
319              
320             =cut
321              
322             sub init_logger {
323 0     0 1 0 my $log_file = normalize_filespec( $site->DOCHAZKA_CLI_LOG_FILE );
324 0 0       0 unlink $log_file if $site->DOCHAZKA_CLI_LOG_FILE_RESET;
325 0         0 print "Logging to $log_file\n";
326 0         0 Log::Any::Adapter->set('File', $log_file );
327 0         0 $log->init( ident => 'dochazka-cli', debug_mode => 1 );
328 0         0 $log->debug( 'Logger initialized' );
329             }
330              
331              
332             =head2 init_prompt
333              
334             (Re-)initialize the date/time-related package variables
335              
336             =cut
337              
338             sub init_prompt {
339             #print "Entering " . __PACKAGE__ . "::init_prompt\n";
340 42     42 1 1127 init_timepiece();
341 42 100       6272 $prompt_date = $today unless $prompt_date;
342 42         270 ( $prompt_year, $prompt_month, $prompt_day ) =
343             $prompt_date =~ m/^(\d{4,4})-(\d{1,2})-(\d{1,2})/;
344 42         159 ( $prompt_century ) = $prompt_year =~ m/^(\d{2,2})/;
345             }
346              
347              
348             =head2 month_alpha_to_numeric
349              
350             Given a month written in English (e.g. "January"), return the ordinal
351             number of that month (i.e. 1 for January) or undef if it cannot be
352             determined.
353              
354             =cut
355              
356             sub month_alpha_to_numeric {
357 15     15 1 7910 my $alpha = shift;
358 15 100       33 return unless defined( $alpha );
359 14         52 my ( $month ) = $alpha =~ m/\A(\S\S\S)/;
360 14         17 $month = lc $month;
361 14 100       30 return unless exists( $month_map{ $month } );
362 12         18 return $month_map{ $month };
363             }
364              
365              
366             =head2 normalize_date
367              
368             Normalize a date entered by the user. A date can take the following forms
369             (case is insignificant):
370              
371             YYYY-MM-DD
372             YY-MM-DD
373             MM-DD
374             TODAY
375             TOMORROW
376             YESTERDAY
377             +n
378             -n
379              
380             and any of the two-digit forms can be fulfilled by a single digit,
381             for example 2014-3-4 is March 4th, 2014.
382              
383             All the forms except the first are converted into the YYYY-MM-DD form.
384             The last two forms listed, C<+n> and C<-n>, are calculated as offsets
385             from the "prompt date" (the date shown in the prompt), where C is
386             interpreted as a number of days.
387              
388             If an undefined or empty string is given, the prompt date is returned.
389              
390             If the string does not match any of the forms, undef is returned.
391              
392             Caveats:
393              
394             =over
395              
396             =item * two-digit years
397              
398             If only YY is given, it is converted into YYYY by appending two digits
399             corresponding to the prompt century (e.g. 22 becomes 2022 during 2000-2099).
400              
401             =item * special date forms
402              
403             The special date forms "TODAY", "TOMORROW", and "YESTERDAY" are recognized,
404             and only the first three letters are significant, so "todMUMBOJUMBO" converts
405             to today's date.
406              
407             =item * offsets
408              
409             The C in the offset can be any number in the range 0-999.
410              
411             =item * no year
412              
413             If no year is given, the prompt year is used.
414              
415             =item * no date
416              
417             If no date is given, the prompt date is used.
418              
419             =item * single-digit forms
420              
421             If a single-digit form is given for C or C
, a leading zero is appended.
422              
423             =back
424              
425             =cut
426              
427             sub normalize_date {
428 26     26 1 8886 my $rd = shift; # rd == raw date
429 26         23 my $nd; # nd == normalized date
430              
431             # initialize timepiece so we can do things like $today, $tomorrow, etc.
432 26         30 init_prompt();
433              
434             # return prompt date if no raw date provided
435 26 100 100     112 unless ( defined( $rd ) and length( $rd ) > 0 ) {
436             #print "normalize_date(): no date provided, returning prompt date\n";
437             #print "Prompt date is " . ( $prompt_date || 'undefined' ) . "\n";
438 2         6 return $prompt_date;
439             }
440              
441 24 100       111 if ( $rd =~ m/\A\d{4,4}-\d{1,2}-\d{1,2}\z/ ) {
    100          
    100          
    100          
    100          
    100          
    100          
442 5         7 $nd = $rd;
443             } elsif ( $rd =~ m/\A\d{2,2}-\d{1,2}-\d{1,2}\z/ ) {
444             # year has only two digits: add the prompt century
445 2         3 $nd = $prompt_century . $rd;
446             } elsif ( $rd =~ m/\A\d{1,2}-\d{1,2}\z/ ) {
447             # year omitted: add the prompt year
448 6         10 $nd = $prompt_year . '-' . $rd;
449             } elsif ( $rd =~ m/\Atod/i ) {
450 2         3 $nd = $today;
451             } elsif ( $rd =~ m/\Atom/i ) {
452 1         2 $nd = $tomorrow;
453             } elsif ( $rd =~ m/\Ayes/i ) {
454 1         2 $nd = $yesterday;
455             } elsif ( $rd =~ m/\A[\+\-]\d{1,3}\z/ ) {
456             # offset from prompt date
457 2         5 $prompt_date =~ m/\A(?\d{4,4})-(?\d{1,2})-(?
\d{1,2})\z/;
458 23 50   23   8973 if ( check_date( $+{'yyyy'}, $+{'mm'}, $+{'dd'} ) ) {
  23         7115  
  23         16072  
  2         19  
459             # prompt date is OK, apply delta
460             my ( $year, $month, $day ) = Add_Delta_Days(
461 2         17 $+{'yyyy'}, $+{'mm'}, $+{'dd'},
462             $rd,
463             );
464 2         7 $nd = "$year-$month-$day";
465             } else {
466 0         0 die "AAAAAAJAJAJAJADDEEEEE!!! Invalid prompt date $prompt_date";
467             }
468             } else {
469             # anything else - invalid timestamp
470 5         10 return undef;
471             }
472              
473             # add leading zeroes to month and day, if necessary
474 19         40 $nd =~ m/\A(?\d{4,4})-(?\d{1,2})-(?
\d{1,2})\z/;
475 19 100 33     186 return undef unless $+{yyyy} and $+{mm} and $+{dd};
      66        
476 17         107 $nd = sprintf( "%d-%02d-%02d", $+{yyyy}, $+{mm}, $+{dd} );
477              
478             # sanity check to ensure no weird dates slip by
479 17         61 my ( $year, $month, $day ) = $nd =~ m/\A(\d{4,4})-(\d{2,2})-(\d{2,2})\z/;
480 17 100       59 return undef unless check_date( $year, $month, $day );
481              
482 15         29 return "$nd";
483             }
484              
485              
486             =head2 normalize_time
487              
488             Normalize a time entered by the user. A time can take the following forms
489              
490             HH:MM:SS
491             HH:MM
492              
493             and any of the two-digit forms can be fulfilled by a single digit,
494             for example 6:4:9 is 6:04 a.m. and nine seconds
495              
496             =over
497              
498             =item * single-digit forms
499              
500             If a single-digit form is given, a leading zero is appended.
501              
502             =item * seconds
503              
504             If seconds are given, they are ignored.
505              
506             =item * no validation
507              
508             No attempt is made to validate the time -- this is done later, by
509             PostgreSQL.
510              
511             =back
512              
513             =cut
514              
515             sub normalize_time {
516 1     1 1 464 my $rt = shift; # rt == raw time
517              
518 1 50       3 return '00:00' unless $rt;
519              
520             # normalize time part
521 1         6 $rt =~ m/\A(?\d{1,2}):(?\d{1,2})(:\d{1,2})?\z/;
522 1         7 my ( $hours, $minutes ) = ( $+{hh}, $+{mm} );
523 1 50 33     6 return undef unless defined( $hours ) and defined( $minutes );
524             # handle single zeroes
525 1 50       3 $hours = '00' if $hours eq '0';
526 1 50       2 $minutes = '00' if $minutes eq '0';
527 1 50 33     4 return undef unless $hours and $minutes;
528 1         7 my $nt = sprintf( "%02d:%02d", $+{hh}, $+{mm} );
529            
530 1         3 return "$nt";
531             }
532              
533              
534             =head2 parse_test
535              
536             Given a reference to the PARAMHASH a command handler was called with, check
537             if there is a PARSE_TEST property there, and if it is true return the
538             full subroutine name of the caller.
539              
540             =cut
541              
542             sub parse_test {
543             #print ( 'parse_test arg list: ' . join( ' ', @_ ) . "\n" );
544 117     117 1 214 my ( %PARAMHASH ) = @_;
545 117 50       227 if ( $PARAMHASH{'PARSE_TEST'} ) {
546 117         877 return $CELL->status_ok( 'DOCHAZKA_CLI_PARSE_TEST',
547             payload => (caller(1))[3] );
548             }
549 0         0 return $CELL->status_not_ok( 'DOCHAZKA_CLI_PARSE_TEST' );
550             }
551              
552              
553             =head2 refresh_current_emp
554              
555             REST calls are cheap, so look up C<< $current_emp >> again just to make sure.
556              
557             =cut
558              
559             sub refresh_current_emp {
560 0     0 1 0 my $status = send_req( 'GET', 'employee/eid/' . $current_emp->eid );
561 0 0       0 if ( $status->not_ok ) {
562 0         0 $log->crit( "Problem with data integrity (current employee)" );
563 0         0 return $status;
564             }
565 0         0 $current_emp = App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload } );
  0         0  
566 0         0 return $status;
567             }
568              
569              
570             =head2 rest_error
571              
572             Given a non-OK status object and a string briefly identifying (for the user)
573             the operation during which the error occurred, construct and return a new
574             L object bearing (in the payload) a string containing the
575             "error report" - perhaps suitable for displaying to the user. The code of that
576             object is C and its level is taken from the passed-in status
577             object. The other attributes of the original (passed-in) status object are
578             preserved in the returned status object as follows:
579              
580             payload -> rest_payload
581             uri_path -> uri_path
582             http_status -> http_status
583              
584             =cut
585              
586             sub rest_error {
587 0     0 1 0 my ( $status, $oper_desc ) = @_;
588 0         0 my $rv = "\n";
589 0 0       0 $rv .= "Entering " . __PACKAGE__ . "::rest_error ($oper_desc)"
590             if $debug_mode;
591              
592 0         0 $rv .= "Error encountered on attempted operation \"$oper_desc\"\n";
593              
594             # special handling if payload is a string
595 0 0       0 if ( ref( $status->payload ) eq '' ) {
    0          
596              
597 0         0 $rv .= $status->payload;
598 0         0 $rv .= "\n";
599              
600             } elsif ( ref( $status->payload ) eq 'HASH' ) {
601              
602             my $http_status = $status->{'http_status'} ||
603 0   0     0 $status->payload->{'http_code'} ||
604             "Cannot be determined";
605 0   0     0 my $method = $status->payload->{'http_method'} ||
606             "Cannot be determined";
607 0   0     0 my $uri_path = $status->payload->{'uri_path'} ||
608             '';
609 0         0 $rv .= "REST operation: $method $uri_path\n";
610 0         0 $rv .= "HTTP status: $http_status\n";
611 0         0 $rv .= "Explanation: ";
612 0         0 $rv .= $status->code;
613 0 0       0 $rv .= ( $status->code eq $status->text )
614             ? "\n"
615             : ': ' . $status->text . "\n";
616 0         0 $rv .= "Permanent? ";
617 0 0       0 $rv .= ( $status->payload->{'permanent'} )
618             ? "YES\n"
619             : "NO\n";
620              
621             } else {
622 0         0 die "AH! in rest_error, payload is neither a hashref nor an ordinary scalar";
623             }
624              
625             my $status_clone = App::CELL::Status->new(
626             level => $status->level,
627             code => 'REST_ERROR',
628             payload => $rv,
629             rest_payload => $status->payload,
630             uri_path => $status->{'uri_path'},
631 0         0 http_status => $status->{'http_status'},
632             );
633 0         0 return $status_clone;
634             }
635              
636              
637             =head2 truncate_to
638              
639             Given a string and a maximum length (defaults to 32), truncates to that length.
640             Returns a copy of the string. If any characters were actually removed in the
641             truncate operation, '...' is appended -- unless the maximum length is zero, in
642             which case the empty string is returned.
643              
644             =cut
645              
646             sub truncate_to {
647             my ( $str, $mlen ) = validate_pos( @_,
648             { type => SCALAR|UNDEF },
649             {
650             callbacks => {
651 12     12   208 'greater than or equal to zero' => sub { shift() >= 0 },
652             },
653 16     16 1 1385 optional => 1,
654             type => SCALAR,
655             },
656             );
657 14 100       61 $mlen = 32 unless defined( $mlen );
658 14   100     36 my $len = length $str || 0; # $str might be undef
659 14 100       43 return $str unless $len > $mlen;
660 6         10 my $str_copy = substr( $str, 0, $mlen );
661 6 50       12 $str_copy .= '...' if $len > $mlen;
662 6 100       9 $str_copy = '' if $mlen == 0;
663 6         23 return $str_copy; # might be undef
664             }
665              
666              
667             1;