File Coverage

blib/lib/App/Dochazka/CLI/Commands/Interval.pm
Criterion Covered Total %
statement 68 266 25.5
branch 16 160 10.0
condition 0 18 0.0
subroutine 23 35 65.7
pod 10 10 100.0
total 117 489 23.9


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             # Interval commands
34             package App::Dochazka::CLI::Commands::Interval;
35              
36 20     20   286 use 5.012;
  20         42  
37 20     20   68 use strict;
  20         23  
  20         318  
38 20     20   60 use warnings;
  20         32  
  20         440  
39              
40 20     20   65 use App::CELL qw( $CELL $log );
  20         18  
  20         1730  
41 20         1660 use App::Dochazka::CLI qw(
42             $current_emp
43             $debug_mode
44             $prompt_date
45             $prompt_month
46             $prompt_year
47 20     20   86 );
  20         22  
48 20     20   76 use App::Dochazka::CLI::Shared qw( shared_generate_report );
  20         21  
  20         852  
49 20         1106 use App::Dochazka::CLI::Util qw(
50             datelist_from_token
51             determine_employee
52             month_alpha_to_numeric
53             normalize_date
54             normalize_time
55             parse_test
56             refresh_current_emp
57             rest_error
58             truncate_to
59 20     20   66 );
  20         19  
60 20     20   8068 use App::Dochazka::Common::Model::Interval;
  20         10617  
  20         399  
61 20     20   82 use Data::Dumper;
  20         22  
  20         754  
62 20     20   64 use Date::Calc qw( Days_in_Month );
  20         24  
  20         666  
63 20     20   57 use Exporter 'import';
  20         21  
  20         326  
64 20     20   52 use JSON;
  20         19  
  20         92  
65 20     20   1560 use Params::Validate qw( :all );
  20         23  
  20         2429  
66 20     20   74 use Text::Table;
  20         23  
  20         304  
67 20     20   56 use Web::MREST::CLI qw( send_req );
  20         22  
  20         43176  
68              
69              
70              
71              
72             =head1 NAME
73              
74             App::Dochazka::CLI::Commands::Interval - Interval commands
75              
76              
77              
78              
79             =head1 PACKAGE VARIABLES
80              
81             =cut
82              
83             our @EXPORT_OK = qw(
84             interval_date
85             interval_date_date1
86             interval_datelist
87             interval_month
88             interval_new_date_time_date1_time1
89             interval_new_time_time1
90             interval_new_timerange
91             interval_num_num1
92             interval_promptdate
93             interval_tsrange
94             );
95              
96              
97              
98              
99             =head1 FUNCTIONS
100              
101             The functions in this module are called from the parser when it recognizes a command.
102              
103              
104             =head2 Command handlers
105              
106             Functions called from the parser
107              
108              
109             =head3 interval_new_date_time_date1_time1
110              
111             INTERVAL NEW _DATE _TIME _DATE1 _TIME1 _TERM
112             INTERVAL NEW _DATE _TIME _HYPHEN _DATE1 _TIME1 _TERM
113              
114             =cut
115              
116             sub interval_new_date_time_date1_time1 {
117 2 50   2 1 6 print "Entering " . __PACKAGE__ . "::interval_new_date_time_date1_time1\n" if $debug_mode;
118 2         3 my ( $ts, $th ) = @_;
119              
120             # parse test
121 2 50       10 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
122              
123 0 0       0 print Dumper( $th ) if $debug_mode;
124              
125 0         0 my $status = _tsrange_from_dates_and_times( $th->{_DATE}, $th->{_DATE1}, $th->{_TIME}, $th->{_TIME1} );
126 0 0       0 return $status unless $status->ok;
127              
128 0         0 return _interval_new( $th->{_TERM}, $status->payload, $th->{_REST} );
129             }
130              
131              
132             =head3 interval_new_time_time1
133              
134             =cut
135              
136             sub interval_new_time_time1 {
137 9 50   9 1 21 print "Entering " . __PACKAGE__ . "::interval_new_time_time1\n" if $debug_mode;
138 9         15 my ( $ts, $th ) = @_;
139              
140             # parse test
141 9 50       33 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
142              
143 0 0       0 print Dumper( $th ) if $debug_mode;
144              
145 0         0 my $status = _tsrange_from_dates_and_times( $th->{_DATE}, undef, $th->{_TIME}, $th->{_TIME1} );
146 0 0       0 return $status unless $status->ok;
147              
148 0         0 return _interval_new( $th->{_TERM}, $status->payload, $th->{_REST} );
149             }
150              
151              
152             =head3 interval_new_timerange
153              
154             INTERVAL _TIMERANGE _TERM
155              
156             =cut
157              
158             sub interval_new_timerange {
159 4 50   4 1 11 print "Entering " . __PACKAGE__ . "::interval_new_timerange\n" if $debug_mode;
160 4         7 my ( $ts, $th ) = @_;
161              
162             # parse test
163 4 50       18 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
164              
165 0 0       0 print Dumper( $th ) if $debug_mode;
166              
167 0         0 my ( $rt0, $rt1 ) = $th->{_TIMERANGE} =~ m/\A(\d{1,2}:\d{1,2})-(\d{1,2}:\d{1,2})/;
168 0         0 my $status = _tsrange_from_dates_and_times( $th->{_DATE}, undef, $rt0, $rt1 );
169 0 0       0 return $status unless $status->ok;
170              
171 0 0       0 print "tsrange: " . $status->payload . "\n" if $debug_mode;
172              
173 0         0 return _interval_new( $th->{_TERM}, $status->payload, $th->{_REST} );
174             }
175              
176              
177             =head3 interval_date
178              
179             INTERVAL _DATE
180             EMPLOYEE_SPEC INTERVAL _DATE
181             INTERVAL FETCH _DATE
182             EMPLOYEE_SPEC INTERVAL FETCH _DATE
183             INTERVAL FILLUP _DATE
184             EMPLOYEE_SPEC INTERVAL FILLUP _DATE
185             INTERVAL FILLUP DRY_RUN _DATE
186             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _DATE
187             INTERVAL SUMMARY _DATE
188             EMPLOYEE_SPEC INTERVAL SUMMARY _DATE
189             INTERVAL REPORT _DATE
190             EMPLOYEE_SPEC INTERVAL REPORT _DATE
191             INTERVAL DELETE _DATE
192             EMPLOYEE_SPEC INTERVAL DELETE _DATE
193              
194             =cut
195              
196             sub interval_date {
197 6 50   6 1 15 print "Entering " . __PACKAGE__ . "::interval_date\n" if $debug_mode;
198 6         6 my ( $ts, $th ) = @_;
199              
200             # parse test
201 6 50       23 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
202              
203 0 0       0 print Dumper( $th ) if $debug_mode;
204              
205             # determine employee
206 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
207 0 0       0 return $status unless $status->ok;
208 0         0 my $emp = $status->payload;
209              
210             # determine date
211 0         0 my $date = normalize_date( $th->{'_DATE'} );
212 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date;
213              
214 0         0 return _interval_fillup_delete_print( $th, $emp, "[ $date 00:00, $date 24:00 )" );
215             }
216              
217             =head3 interval_date_date1
218              
219             INTERVAL _DATE _DATE1
220             EMPLOYEE_SPEC INTERVAL _DATE _DATE1
221             INTERVAL FETCH _DATE _DATE1
222             EMPLOYEE_SPEC INTERVAL FETCH _DATE _DATE1
223             INTERVAL FILLUP _DATE _DATE1
224             EMPLOYEE_SPEC INTERVAL FILLUP _DATE _DATE1
225             INTERVAL FILLUP DRY_RUN _DATE _DATE1
226             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _DATE _DATE1
227             INTERVAL DELETE _DATE _DATE1
228             EMPLOYEE_SPEC INTERVAL DELETE _DATE _DATE1
229             INTERVAL _DATE _HYPHEN _DATE1
230             EMPLOYEE_SPEC INTERVAL _DATE _HYPHEN _DATE1
231             INTERVAL FETCH _DATE _HYPHEN _DATE1
232             EMPLOYEE_SPEC INTERVAL FETCH _DATE _HYPHEN _DATE1
233             INTERVAL FILLUP _DATE _HYPHEN _DATE1
234             EMPLOYEE_SPEC INTERVAL FILLUP _DATE _HYPHEN _DATE1
235             INTERVAL FILLUP DRY_RUN _DATE _HYPHEN _DATE1
236             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _DATE _HYPHEN _DATE1
237             INTERVAL SUMMARY _DATE _HYPHEN _DATE1
238             EMPLOYEE_SPEC INTERVAL SUMMARY _DATE _HYPHEN _DATE1
239             INTERVAL REPORT _DATE _HYPHEN _DATE1
240             EMPLOYEE_SPEC INTERVAL REPORT _DATE _HYPHEN _DATE1
241             INTERVAL DELETE _DATE _HYPHEN _DATE1
242             EMPLOYEE_SPEC INTERVAL DELETE _DATE _HYPHEN _DATE1
243              
244             =cut
245              
246             sub interval_date_date1 {
247 12 50   12 1 32 print "Entering " . __PACKAGE__ . "::interval_date_date1\n" if $debug_mode;
248 12         16 my ( $ts, $th ) = @_;
249              
250             # parse test
251 12 50       51 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
252              
253 0 0       0 print Dumper( $th ) if $debug_mode;
254              
255             # determine employee
256 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
257 0 0       0 return $status unless $status->ok;
258 0         0 my $emp = $status->payload;
259              
260             # determine date
261 0         0 my $date = normalize_date( $th->{'_DATE'} );
262 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date;
263 0         0 my $date1 = normalize_date( $th->{'_DATE1'} );
264 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date1;
265              
266 0         0 return _interval_fillup_delete_print( $th, $emp, "[ $date 00:00, $date1 24:00 )" );
267             }
268              
269             =head3 interval_month
270              
271             INTERVAL _MONTH [_NUM]
272             EMPLOYEE_SPEC INTERVAL _MONTH [_NUM]
273             INTERVAL FETCH _MONTH [_NUM]
274             EMPLOYEE_SPEC INTERVAL FETCH _MONTH [_NUM]
275             INTERVAL FILLUP _MONTH [_NUM]
276             EMPLOYEE_SPEC INTERVAL FILLUP _MONTH [_NUM]
277             INTERVAL FILLUP DRY_RUN _MONTH [_NUM]
278             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _MONTH [_NUM]
279             INTERVAL SUMMARY _MONTH [_NUM]
280             EMPLOYEE_SPEC INTERVAL SUMMARY _MONTH [_NUM]
281             INTERVAL REPORT _MONTH [_NUM]
282             EMPLOYEE_SPEC INTERVAL REPORT _MONTH [_NUM]
283             INTERVAL DELETE _MONTH [_NUM]
284             EMPLOYEE_SPEC INTERVAL DELETE _MONTH [_NUM]
285              
286             =cut
287              
288             sub interval_month {
289 12 50   12 1 29 print "Entering " . __PACKAGE__ . "::interval_month\n" if $debug_mode;
290 12         17 my ( $ts, $th ) = @_;
291              
292             # parse test
293 12 50       44 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
294              
295 0 0       0 print Dumper( $th ) if $debug_mode;
296              
297             # determine employee
298 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
299 0 0       0 return $status unless $status->ok;
300 0         0 my $emp = $status->payload;
301              
302             # determine lower and upper bounds
303             # - month
304 0         0 my $nmonth = month_alpha_to_numeric( $th->{_MONTH} );
305             # - year
306 0   0     0 my $year = $th->{'_NUM'} || $prompt_year;
307             # - normalize
308 0         0 my $date = normalize_date( "$year-$nmonth-1" );
309 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date;
310 0         0 my $date1 = normalize_date( "$year-$nmonth-" .
311             Days_in_Month( $year, $nmonth ) );
312 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date1;
313              
314 0         0 return _interval_fillup_delete_print( $th, $emp, "[ $date 00:00, $date1 24:00 )" );
315             }
316              
317             =head3 interval_num_num1
318              
319             INTERVAL _NUM [_NUM1]
320             EMPLOYEE_SPEC INTERVAL _NUM [_NUM1]
321             INTERVAL FETCH _NUM [_NUM1]
322             EMPLOYEE_SPEC INTERVAL FETCH _NUM [_NUM1]
323             INTERVAL FILLUP _NUM [_NUM1]
324             EMPLOYEE_SPEC INTERVAL FILLUP _NUM [_NUM1]
325             INTERVAL FILLUP DRY_RUN _NUM [_NUM1]
326             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _NUM [_NUM1]
327             INTERVAL SUMMARY _NUM [_NUM1]
328             EMPLOYEE_SPEC INTERVAL SUMMARY _NUM [_NUM1]
329             INTERVAL REPORT _NUM [_NUM1]
330             EMPLOYEE_SPEC INTERVAL REPORT _NUM [_NUM1]
331             INTERVAL DELETE _NUM [_NUM1]
332             EMPLOYEE_SPEC INTERVAL DELETE _NUM [_NUM1]
333              
334             =cut
335              
336             sub interval_num_num1 {
337 12 50   12 1 33 print "Entering " . __PACKAGE__ . "::interval_num_num1\n" if $debug_mode;
338 12         17 my ( $ts, $th ) = @_;
339              
340             # parse test
341 12 50       51 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
342              
343 0 0       0 print Dumper( $th ) if $debug_mode;
344              
345             # determine employee
346 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
347 0 0       0 return $status unless $status->ok;
348 0         0 my $emp = $status->payload;
349              
350             # determine lower and upper bounds
351             # - numeric month
352 0         0 my $nmonth;
353 0 0 0     0 if ( $th->{'_NUM'} >= 0 and $th->{'_NUM'} <= 12 ) {
354 0         0 $nmonth = $th->{'_NUM'};
355             } else {
356 0         0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' );
357             }
358             # - year
359 0   0     0 my $year = $th->{'_NUM1'} || $prompt_year;
360             # - normalize
361 0         0 my $date = normalize_date( "$year-$nmonth-1" );
362 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date;
363 0         0 my $date1 = normalize_date( "$year-$nmonth-" .
364             Days_in_Month( $year, $nmonth ) );
365 0 0       0 return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE' ) unless $date1;
366              
367 0         0 return _interval_fillup_delete_print( $th, $emp, "[ $date 00:00, $date1 24:00 )" );
368             }
369              
370             =head3 interval_tsrange
371              
372             INTERVAL FILLUP _TSRANGE
373             EMPLOYEE_SPEC INTERVAL FILLUP _TSRANGE
374             INTERVAL FILLUP DRY_RUN _TSRANGE
375             EMPLOYEE_SPEC INTERVAL FILLUP DRY_RUN _TSRANGE
376             INTERVAL SUMMARY _TSRANGE
377             EMPLOYEE_SPEC INTERVAL SUMMARY _TSRANGE
378             INTERVAL REPORT _TSRANGE
379             EMPLOYEE_SPEC INTERVAL REPORT _TSRANGE
380              
381             =cut
382              
383             sub interval_tsrange {
384 0 0   0 1 0 print "Entering " . __PACKAGE__ . "::interval_tsrange\n" if $debug_mode;
385 0         0 my ( $ts, $th ) = @_;
386              
387             # parse test
388 0 0       0 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
389              
390 0 0       0 print Dumper( $th ) if $debug_mode;
391              
392             # determine employee
393 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
394 0 0       0 return $status unless $status->ok;
395 0         0 my $emp = $status->payload;
396            
397 0         0 return _interval_fillup_delete_print( $th, $emp, $th->{_TSRANGE} );
398             }
399              
400             =head3 interval_datelist
401              
402             =cut
403              
404             sub interval_datelist {
405 0 0   0 1 0 print "Entering " . __PACKAGE__ . "::interval_datelist\n" if $debug_mode;
406 0         0 my ( $ts, $th ) = @_;
407              
408             # parse test
409 0 0       0 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
410              
411 0 0       0 print Dumper( $th ) if $debug_mode;
412              
413             # determine employee
414 0         0 my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
415 0 0       0 return $status unless $status->ok;
416 0         0 my $emp = $status->payload;
417 0         0 $log->debug( "EID: " . $emp->eid );
418              
419             # determine dry_run
420 0 0       0 my $dry_run = exists( $th->{'DRY_RUN'} ) ? 1 : 0;
421 0         0 $log->debug( "dry_run: $dry_run" );
422              
423             # check datelist for sanity
424 0         0 my $regex = qr/^(\d{1,2},|\d{1,2}-\d{1,2},)*(\d{1,2}|\d{1,2}-\d{1,2})$/;
425 0 0       0 return $CELL->status_err( "Invalid datelist" ) unless $th->{"_REST"} =~ $regex;
426              
427             # convert datelist into reference to array of dates
428 0         0 my $dl = datelist_from_token( $prompt_month, $th->{_REST} );
429 0         0 $log->debug( "datelist: " . Dumper( $dl ) );
430            
431             return _fillup(
432             eid => $emp->eid,
433             code => $th->{_TERM},
434 0         0 date_list => $dl,
435             dry_run => $dry_run,
436             clobber => 1,
437             );
438             }
439              
440             =head3 interval_promptdate
441              
442             INTERVAL
443             EMPLOYEE_SPEC INTERVAL
444             INTERVAL FETCH
445             EMPLOYEE_SPEC INTERVAL FETCH
446             INTERVAL FILLUP
447             EMPLOYEE_SPEC INTERVAL FILLUP
448             INTERVAL SUMMARY
449             EMPLOYEE_SPEC INTERVAL SUMMARY
450             INTERVAL REPORT
451             EMPLOYEE_SPEC INTERVAL REPORT
452             INTERVAL DELETE
453             EMPLOYEE_SPEC INTERVAL DELETE
454              
455             =cut
456              
457             sub interval_promptdate {
458 6 50   6 1 14 print "Entering " . __PACKAGE__ . "::interval_promptdate\n" if $debug_mode;
459 6         9 my ( $ts, $th ) = @_;
460              
461             # parse test
462 6 50       24 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
463              
464 0 0         print Dumper( $th ) if $debug_mode;
465              
466             # determine employee
467 0           my $status = determine_employee( $th->{'EMPLOYEE_SPEC'} );
468 0 0         return $status unless $status->ok;
469 0           my $emp = $status->payload;
470              
471 0           return _interval_fillup_delete_print( $th, $emp, "[ $prompt_date 00:00, $prompt_date 24:00 )" );
472             }
473              
474             sub _interval_fillup_delete_print {
475 0     0     my ( $th, $emp, $tsr ) = @_;
476              
477 0 0         if ( $th->{'FILLUP'} ) {
    0          
    0          
    0          
478 0           my %ARGS;
479 0           $ARGS{eid} = $emp->eid;
480 0           $ARGS{tsrange} = $tsr;
481 0 0         $ARGS{dry_run} = exists( $th->{'DRY_RUN'} ) ? 1 : 0;
482 0           $ARGS{clobber} = 0;
483 0           return _fillup( %ARGS );
484             } elsif ( $th->{'DELETE'} ) {
485 0           return _delete_intervals_tsrange( $emp->eid, $tsr );
486             } elsif ( $th->{'SUMMARY'} ) {
487 0           return _interval_summary( $emp->eid, $tsr );
488             } elsif ( $th->{'REPORT'} ) {
489 0           return _interval_report( $emp, $tsr );
490             } else {
491 0           return _print_intervals_tsrange( $emp, $tsr );
492             }
493             }
494              
495              
496             =head2 Helper functions
497              
498             Functions called from command handlers
499              
500              
501             =head3 _interval_new
502              
503             Takes code, tsrange and, optionally, long_desc. Converts the code into an AID,
504             sets up and sends the "POST interval/new" REST request, and returns the
505             resulting status object.
506              
507             =cut
508              
509             sub _interval_new {
510 0     0     my ( $code, $tsrange, $long_desc ) = validate_pos( @_,
511             { type => SCALAR },
512             { type => SCALAR },
513             { type => SCALAR|UNDEF, optional => 1 },
514             );
515              
516             # get aid from code
517 0           my $status = send_req( 'GET', "activity/code/$code" );
518 0 0         if ( $status->not_ok ) {
519 0 0 0       if ( $status->code eq "DISPATCH_SEARCH_EMPTY" and
520             $status->text =~ m/Search over activity with key -\>code equals .+\<- returned nothing/
521             ) {
522 0           return $CELL->status_err( 'DOCHAZKA_CLI_WRONG_ACTIVITY', args => [ $code ] );
523             }
524 0 0         return rest_error( $status, "Determine AID from code" ) unless $status->ok;
525             }
526 0           my $aid = $status->payload->{'aid'};
527              
528             # assemble entity
529 0           my $entity_perl = {
530             'aid' => $aid,
531             'intvl' => $tsrange,
532             };
533 0 0         $entity_perl->{'long_desc'} = $long_desc if $long_desc;
534 0           my $entity = encode_json $entity_perl;
535              
536             # send the request
537 0           $status = send_req( 'POST', "interval/new", $entity );
538 0 0         if ( $status->not_ok ) {
539             # if ... possible future checks for common errors
540             # elsif ... other common errors
541 0 0         return rest_error( $status, "Insert new attendance interval" ) unless $status->ok;
542             }
543              
544 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION',
545             payload => _print_interval( $status->payload ) );
546             }
547              
548              
549             =head3 _tsrange_from_dates_and_times
550              
551             Given two dates and two times, returns a full-fledged tsrange.
552             If the first date is undef or empty, use the prompt date.
553             If the second date is undef or empty, use the first date.
554              
555             =cut
556              
557             sub _tsrange_from_dates_and_times {
558 0     0     my ( $d0, $d1, $t0, $t1 ) = @_;
559              
560             # normalize dates and times
561             BREAK_OUT: {
562 0           my $s = 1;
  0            
563 0           my $flagged;
564              
565             # normalize_date will replace an undefined or empty date with the prompt date
566 0 0         if ( $s = normalize_date( $d0 ) ) {
567 0           $d0 = $s;
568             } else {
569 0           $flagged = $d0;
570             }
571              
572             # for the second date, we have to check for undefined/empty-ness ourselves
573 0 0 0       $d1 = $d0 unless defined( $d1 ) and length( $d1 ) > 0;
574              
575 0 0         if ( $s = normalize_date( $d1 ) ) {
576 0           $d1 = $s;
577             } else {
578 0           $flagged = $d1;
579             }
580              
581 0 0         if ( $s = normalize_time( $t0 ) ) {
582 0           $t0 = $s;
583             } else {
584 0           $flagged = $t0;
585             }
586              
587 0 0         if ( $s = normalize_time( $t1 ) ) {
588 0           $t1 = $s;
589             } else {
590 0           $flagged = $t1;
591             }
592              
593 0 0         last BREAK_OUT unless $flagged;
594 0 0         $flagged = 'undefined' if not defined $flagged;
595 0           return $CELL->status_err( 'DOCHAZKA_CLI_INVALID_DATE_OR_TIME', args => [ $flagged ] );
596             }
597              
598 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => "[ $d0 $t0, $d1 $t1 )" );
599             }
600              
601             =head3 _print_interval
602              
603             Given an interval object (blessed or unblessed), construct a string
604             suitable for on-screen display.
605              
606             =cut
607              
608             sub _print_interval {
609 0     0     my ( $int ) = @_;
610            
611             # get the activity code from the 'aid' property
612 0           my $status = send_req( 'GET', "activity/aid/" . $int->{'aid'} );
613 0 0         return rest_error( $status, "Determine activity code from AID" ) unless $status->ok;
614 0           my $code = $status->payload->{'code'};
615              
616             # convert the interval into a readable form
617 0           my $intvl = $int->{'intvl'};
618 0           my $iid = $int->{'iid'};
619              
620 0           my $out = '';
621 0           $out .= "Interval IID $iid\n";
622 0           $out .= "$intvl $code";
623 0 0         $out .= " " . $int->{'long_desc'} if defined( $int->{'long_desc'} );
624 0           $out .= "\n";
625              
626 0           return $out;
627             }
628              
629             =head3 _print_intervals_tsrange
630              
631             Given an employee object and a tsrange, print all matching intervals
632              
633             =cut
634              
635             sub _print_intervals_tsrange {
636 0     0     my ( $emp, $tsr ) = @_;
637 0           my $eid = $emp->eid;
638 0           my $nick = $emp->nick;
639              
640 0           my $status = send_req( 'GET', "interval/eid/$eid/$tsr" );
641 0 0 0       if ( $status->not_ok and $status->code eq 'DISPATCH_NOTHING_IN_TSRANGE' ) {
642 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $status->text );
643             }
644 0 0         return rest_error( $status, "Get intervals for employee $nick (EID $eid) in range $tsr" )
645             unless $status->ok;
646              
647 0           my $pl = '';
648 0           $pl .= "Attendance intervals of $nick (EID $eid)\n";
649 0           $pl .= "in the range $tsr\n\n";
650              
651 0           my $t = Text::Table->new( 'IID', 'Begin', 'End', 'Code', 'Description' );
652 0           my $partial_intervals_present = 0;
653 0           for my $props ( @{ $status->payload } ) {
  0            
654 0           my $int = App::Dochazka::Common::Model::Interval->spawn( $props );
655 0           my $iid;
656 0 0         if ( $int->partial ) {
657 0           $partial_intervals_present = 1;
658 0           $iid = $int->iid . '**';
659             } else {
660 0           $iid = $int->iid;
661             }
662 0           $t->add(
663             $iid,
664             _begin_and_end_from_intvl( $int->intvl ),
665             $int->code,
666             truncate_to( $int->long_desc ),
667             );
668             }
669 0           $pl .= $t;
670 0 0         $pl .= "\nPartial intervals signified by **\n" if $partial_intervals_present;
671              
672 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $pl );
673             }
674              
675              
676             =head3 _begin_and_end_from_intvl
677              
678             =cut
679              
680             sub _begin_and_end_from_intvl {
681 0     0     my $intvl = shift;
682              
683 0           my ( $d0, $t0, $d1, $t1 ) = $intvl =~
684             m/(\d{4,4}-\d{2,2}-\d{2,2}).*(\d{2,2}:\d{2,2}):\d{2,2}.*(\d{4,4}-\d{2,2}-\d{2,2}).*(\d{2,2}:\d{2,2}):\d{2,2}/;
685              
686 0           return ( "$d0 $t0", "$d1 $t1" );
687             }
688              
689             =head3 _delete_intervals_tsrange
690              
691             Given an EID and a tsrange, delete all matching intervals
692              
693             =cut
694              
695             sub _delete_intervals_tsrange {
696 0     0     my ( $eid, $tsr ) = @_;
697 0           my $status = send_req( 'DELETE', "interval/eid/$eid/$tsr" );
698 0 0         return $status unless $status->ok;
699 0           my $count = $status->{'count'};
700 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION',
701             payload => "$count intervals deleted in range $tsr" );
702             }
703              
704             =head3 _interval_summary
705              
706             Given an EID and a tsrange, call the "interval/sumary/eid/:eid/:tsrange"
707             resource.
708              
709             =cut
710              
711             sub _interval_summary {
712 0     0     my ( $eid, $tsr ) = @_;
713 0           my $status = send_req( 'GET', "interval/summary/eid/$eid/$tsr" );
714 0 0         return $status unless $status->ok;
715 0           $status->code( 'DOCHAZKA_CLI_NORMAL_COMPLETION' );
716 0           return $status;
717             }
718              
719             =head3 _interval_report
720              
721             Given an employee object and a tsrange, POST to the "genreport" resource with
722             an entity body:
723              
724             {
725             "path" : "suse-cz-monthly.mc",
726             "parameters" : {
727             "employee" : $EMPLOYEE_OBJECT_JSON,
728             "tsrange" : "$TSRANGE"
729             }
730             }
731              
732             =cut
733              
734             sub _interval_report {
735 0     0     my ( $emp, $tsr ) = @_;
736 0           my $emp_json = JSON->new->convert_blessed->encode( $emp );
737 0           my $entity = <<"EOS";
738             {
739             "path" : "suse-cz-monthly.mc",
740             "parameters" : {
741             "employee" : $emp_json,
742             "tsrange" : "$tsr"
743             }
744             }
745             EOS
746 0           return shared_generate_report( $entity );
747             }
748              
749             =head3 _fillup
750              
751             =cut
752              
753             sub _fillup {
754 0     0     my ( %ARGS ) = validate( @_, {
755             eid => { type => SCALAR },
756             code => { type => SCALAR, optional => 1 },
757             date_list => { type => ARRAYREF, optional => 1 },
758             tsrange => { type => SCALAR, optional => 1 },
759             dry_run => { type => SCALAR },
760             clobber => { type => SCALAR, default => 1 },
761             } );
762              
763 0           my $request_body = encode_json( \%ARGS );
764              
765 0           my $status = send_req( 'POST', "interval/fillup", $request_body );
766 0 0         return $status unless $status->ok;
767              
768 0           my ( $pl, $count );
769 0 0         if ( $status->code eq 'DISPATCH_FILLUP_INTERVALS_CREATED' ) {
770 0           my $tmp = $status->payload->{'success'}->{'count'};
771 0           $pl .= "$tmp intervals successfully inserted\n";
772 0           $tmp = $status->payload->{'failure'}->{'count'};
773 0           $pl .= "$tmp intervals not inserted due to conflicts\n";
774 0 0         if ( exists( $status->payload->{'clobbered'} ) ) {
775 0           $tmp = $status->payload->{'clobbered'}->{'count'};
776 0           $pl .= "$tmp existing intervals clobbered\n";
777             }
778             }
779 0           $count = $status->{'count'};
780 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $pl );
781             }
782              
783             1;