File Coverage

blib/lib/App/Dochazka/CLI/Commands/Schedule.pm
Criterion Covered Total %
statement 68 192 35.4
branch 22 98 22.4
condition 0 6 0.0
subroutine 23 27 85.1
pod 12 12 100.0
total 125 335 37.3


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             # Schedule commands
34             package App::Dochazka::CLI::Commands::Schedule;
35              
36 20     20   256 use 5.012;
  20         41  
37 20     20   61 use strict;
  20         22  
  20         276  
38 20     20   54 use warnings;
  20         18  
  20         390  
39              
40 20     20   69 use App::CELL qw( $CELL );
  20         17  
  20         1516  
41 20     20   81 use App::Dochazka::CLI qw( $debug_mode );
  20         21  
  20         1259  
42 20     20   74 use App::Dochazka::CLI::Shared qw( print_schedule_object show_as_at );
  20         19  
  20         759  
43 20     20   68 use App::Dochazka::CLI::Util qw( parse_test );
  20         19  
  20         636  
44 20     20   8359 use App::Dochazka::Common::Model::Schedule;
  20         8165  
  20         401  
45 20     20   80 use Data::Dumper;
  20         21  
  20         689  
46 20     20   63 use Exporter 'import';
  20         21  
  20         354  
47 20     20   58 use JSON;
  20         20  
  20         77  
48 20     20   1426 use Web::MREST::CLI qw( send_req );
  20         24  
  20         37355  
49              
50              
51              
52              
53             =head1 NAME
54              
55             App::Dochazka::CLI::Commands::Schedule - Schedule commands
56              
57              
58              
59              
60             =head1 PACKAGE VARIABLES
61              
62             =cut
63              
64             our @EXPORT_OK = qw(
65             $memsched
66             %dow_map
67             add_memsched_entry
68             assign_memsched_scode
69             clear_memsched_entries
70             dump_memsched_entries
71             fetch_all_schedules
72             replicate_memsched_entry
73             schedule_all
74             schedule_new
75             schedulespec
76             schedulespec_remark
77             schedulespec_scode
78             show_schedule_as_at
79             );
80              
81             # in-memory storage for working schedule
82             our $memsched;
83             our $memsched_scode;
84              
85             our %dow_map = (
86             'MON' => '2015-03-23',
87             'TUE' => '2015-03-24',
88             'WED' => '2015-03-25',
89             'THU' => '2015-03-26',
90             'FRI' => '2015-03-27',
91             'SAT' => '2015-03-28',
92             'SUN' => '2015-03-29',
93             );
94              
95             our %date_map = (
96             '2015-03-23' => 'MON',
97             '2015-03-24' => 'TUE',
98             '2015-03-25' => 'WED',
99             '2015-03-26' => 'THU',
100             '2015-03-27' => 'FRI',
101             '2015-03-28' => 'SAT',
102             '2015-03-29' => 'SUN',
103             );
104              
105              
106              
107              
108             =head1 FUNCTIONS
109              
110             The functions in this module are called from the parser when it recognizes a command.
111              
112             =cut
113              
114              
115             =head2 Command handlers
116              
117             The routines in this section are called as command handlers.
118              
119              
120             =head3 schedule_all
121              
122             SCHEDULE ALL
123             SCHEDULE ALL DISABLED
124              
125             =cut
126              
127             sub schedule_all {
128 0 0   0 1 0 print "Entering " . __PACKAGE__ . "::schedule_all\n" if $debug_mode;
129 0         0 my ( $ts, $th ) = @_;
130              
131             # parse test
132 0 0       0 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
133              
134 0         0 return $CELL->status_ok( 'UNDER_CONSTRUCTION' );
135             }
136              
137              
138             =head3 show_schedule_as_at
139              
140             SCHEDULE
141             EMPLOYEE_SPEC SCHEDULE
142             SCHEDULE _DATE
143             EMPLOYEE_SPEC SCHEDULE _DATE
144              
145             =cut
146              
147             sub show_schedule_as_at {
148 2 50   2 1 14 print "Entering " . __PACKAGE__ . "::show_schedule_as_at\n" if $debug_mode;
149 2         3 my ( $ts, $th ) = @_;
150              
151             # parse test
152 2 50       9 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
153              
154 0         0 return show_as_at( 'schedule', $th );
155             }
156              
157              
158             =head3 add_memsched_entry
159              
160             SCHEDULE _DOW _TIME _DOW1 _TIME1
161             SCHEDULE _DOW _TIME _HYPHEN _DOW1 _TIME1
162             SCHEDULE _DOW _TIMERANGE
163              
164             =cut
165              
166             sub add_memsched_entry {
167 3 50   3 1 10 print "Entering " . __PACKAGE__ . "::add_memsched_entry\n" if $debug_mode;
168 3         4 my ( $ts, $th ) = @_;
169              
170             # parse test
171 3 50       12 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
172              
173 0         0 my ( $dow_begin, $dow_end, $time_begin, $time_end ) = _canonicalize_th( $th );
174 0         0 my ( $date_begin, $date_end ) = ( $dow_map{$dow_begin}, $dow_map{$dow_end} );
175              
176 0 0       0 if ( exists( $memsched->{"$date_begin $time_begin"} ) ) {
177 0         0 push @{ $memsched->{"$date_begin $time_begin"} }, "$date_end $time_end"
178 0 0       0 unless grep { $_ eq "$date_end $time_end" } @{ $memsched->{"$date_begin $time_begin"} };
  0         0  
  0         0  
179             } else {
180 0         0 $memsched->{"$date_begin $time_begin"} = [ "$date_end $time_end" ];
181             }
182              
183 0 0       0 print Dumper( $memsched ) if $debug_mode;
184              
185 0         0 return _dump_memsched_entries();
186             }
187              
188              
189             =head3 replicate_memsched_entry
190              
191             SCHEDULE ALL _TIMERANGE
192              
193             Apply timerange to all five days MON-FRI
194              
195             =cut
196              
197             sub replicate_memsched_entry {
198 1 50   1 1 5 print "Entering " . __PACKAGE__ . "::add_memsched_entry\n" if $debug_mode;
199 1         2 my ( $ts, $th ) = @_;
200              
201             # parse test
202 1 50       5 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
203              
204 0         0 foreach my $dow ( qw( MON TUE WED THU FRI ) ) {
205 0         0 $th->{_DOW} = $dow;
206 0         0 add_memsched_entry( $ts, $th );
207             }
208              
209 0         0 return _dump_memsched_entries();
210             }
211              
212              
213             =head3 clear_memsched_entries
214              
215             SCHEDULE CLEAR
216              
217             =cut
218              
219             sub clear_memsched_entries {
220 1 50   1 1 4 print "Entering " . __PACKAGE__ . "::clear_memsched_entries\n" if $debug_mode;
221 1         2 my ( $ts, $th ) = @_;
222              
223             # parse test
224 1 50       6 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
225              
226 0         0 $memsched = {};
227 0         0 $memsched_scode = '';
228 0         0 return $CELL->status_ok( 'DOCHAZKA_CLI_MEMSCHED_EMPTY' );
229             }
230              
231              
232             =head3 fetch_all_schedules
233              
234             SCHEDULES FETCH ALL
235             SCHEDULES FETCH ALL DISABLED
236              
237             Get all schedules and dump them to the screen.
238              
239             =cut
240              
241             sub fetch_all_schedules {
242 2 50   2 1 6 print "Entering " . __PACKAGE__ . "::fetch_all_schedules\n" if $debug_mode;
243 2         3 my ( $ts, $th ) = @_;
244              
245             # parse test
246 2 50       9 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
247              
248             my $status = ( $th->{DISABLED} )
249 0 0       0 ? send_req( 'GET', 'schedule/all/disabled' )
250             : send_req( 'GET', 'schedule/all' );
251 0 0       0 if ( $status->ok ) {
252 0         0 my $pl = '';
253 0         0 foreach my $sch_hash ( @{ $status->payload } ) {
  0         0  
254 0         0 my $sch_obj = App::Dochazka::Common::Model::Schedule->spawn( %$sch_hash );
255 0         0 $pl .= print_schedule_object( $sch_obj );
256 0         0 $pl .= "\n";
257             }
258 0         0 return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $pl );
259             }
260 0         0 return $status;
261             }
262              
263              
264             =head3 dump_memsched_entries
265              
266             Dumps "memsched" (i.e. working schedule stored in memory) to the screen.
267              
268             Note that L will happily let you build up a completely
269             illegal and nonsensical schedule in memory, and submit it to the REST
270             server. Data integrity controls for new schedule records are performed
271             on server-side.
272              
273             SCHEDULE DUMP
274             SCHEDULE MEMORY
275              
276             =cut
277              
278             sub dump_memsched_entries {
279 2 50   2 1 5 print "Entering " . __PACKAGE__ . "::dump_memsched_entries\n" if $debug_mode;
280 2         4 my ( $ts, $th ) = @_;
281              
282             # parse test
283 2 50       8 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
284            
285 0         0 my $pl = '';
286              
287 0 0       0 if ( $memsched_scode ) {
288 0         0 $pl .= "Schedule code: $memsched_scode\n\n";
289             }
290              
291             # sort entries by beginning and ending timestamp
292 0         0 foreach my $start_str ( sort keys %$memsched ) {
293 0         0 my ( $start_date, $start_time ) = $start_str =~ m/(.*) (.*)/;
294 0         0 my $start_converted = $date_map{$start_date} . " " . $start_time;
295 0         0 foreach my $end_str ( sort @{ $memsched->{$start_str} } ) {
  0         0  
296 0         0 my ( $end_date, $end_time ) = $end_str =~ m/(.*) (.*)/;
297 0         0 my $end_converted = $date_map{$end_date} . " " . $end_time;
298 0         0 $pl .= "[ $start_converted, $end_converted )\n";
299             }
300             }
301              
302 0 0       0 my $code = $pl ? 'DOCHAZKA_CLI_MEMSCHED' : 'DOCHAZKA_CLI_MEMSCHED_EMPTY';
303 0         0 return $CELL->status_ok( $code, payload => $pl );
304             }
305              
306              
307             =head3 schedule_new
308              
309             Submits the "memsched" (i.e. working schedule stored in memory) to the REST
310             server via 'POST submit/new'.
311              
312             SCHEDULE NEW
313              
314             =cut
315              
316             sub schedule_new {
317 1 50   1 1 3 print "Entering " . __PACKAGE__ . "::schedule_new\n" if $debug_mode;
318 1         3 my ( $ts, $th ) = @_;
319              
320             # parse test
321 1 50       6 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
322              
323 0         0 my @pl;
324              
325             # make sure there are some memsched entries to begin with
326 0 0       0 if ( ! $memsched ) {
327 0         0 return $CELL->status_err( 'DOCHAZKA_CLI_NO_SCHEDULE_ENTRIES_IN_MEMORY' );
328             }
329              
330             # sort entries by beginning and ending timestamp
331 0         0 foreach my $start_str ( sort keys %$memsched ) {
332 0         0 foreach my $end_str ( sort @{ $memsched->{$start_str} } ) {
  0         0  
333 0         0 push @pl, "[ $start_str, $end_str )";
334             }
335             }
336              
337 0         0 my $sched = { "schedule" => \@pl };
338 0 0       0 $sched->{'scode'} = $memsched_scode if $memsched_scode;
339 0         0 my $json = encode_json $sched;
340              
341 0         0 my $status = send_req( 'POST', 'schedule/new', $json );
342 0 0       0 if ( $status->ok ) {
343 0         0 my $sch_obj = App::Dochazka::Common::Model::Schedule->spawn( %{ $status->payload } );
  0         0  
344 0         0 my $pl = '';
345 0 0       0 if ( my $http_status = $status->{'http_status'} ) {
346 0         0 $pl .= "HTTP status: $http_status\n";
347             }
348 0         0 $pl .= print_schedule_object( $sch_obj );
349 0         0 _clear_memsched_entries();
350 0         0 return $CELL->status_ok(
351             'DOCHAZKA_CLI_NORMAL_COMPLETION',
352             http_status => '200 OK',
353             payload => $pl
354             );
355             }
356 0         0 return $status;
357             }
358              
359              
360             =head3 assign_memsched_scode
361              
362             SCHEDULE SCODE _TERM
363              
364             Assign an 'scode' value to the "memsched" (local memory buffer) schedule.
365              
366             =cut
367              
368             sub assign_memsched_scode {
369 1 50   1 1 4 print "Entering " . __PACKAGE__ . "::assign_memsched_scode\n" if $debug_mode;
370 1         3 my ( $ts, $th ) = @_;
371              
372             # parse test
373 1 50       5 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
374              
375 0         0 $memsched_scode = $th->{_TERM};
376              
377 0         0 return _dump_memsched_entries();
378             }
379              
380              
381             =head3 schedulespec
382              
383             SCHEDULE_SPEC
384             SCHEDULE_SPEC SHOW
385              
386             =cut
387              
388             sub schedulespec {
389 2 50   2 1 8 print "Entering " . __PACKAGE__ . "::schedulespec\n" if $debug_mode;
390 2         2 my ( $ts, $th ) = @_;
391              
392             # parse test
393 2 50       9 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
394              
395 0         0 my ( $key_spec, $key ) = $th->{'SCHEDULE_SPEC'} =~ m/^(.*)\=(.*)$/;
396              
397 0         0 my ( $status, $pl );
398 0 0       0 if ( $key_spec =~ m/^sco/i ) {
    0          
399 0         0 $status = send_req( 'GET', "schedule/scode/$key" );
400             } elsif ( $key_spec =~ m/^sid/ ) {
401 0         0 $status = send_req( 'GET', "schedule/sid/$key" );
402             } else {
403 0 0       0 die "AAAHAAAHHH!!! Invalid schedule lookup key " . ( defined( $key_spec ) ? $key_spec : "undefined" )
404             }
405              
406 0 0       0 if ( $status->ok ) {
407 0         0 my $sch_obj = App::Dochazka::Common::Model::Schedule->spawn( %{ $status->payload } );
  0         0  
408 0         0 $pl = print_schedule_object( $sch_obj );
409 0         0 return $CELL->status_ok( "DOCHAZKA_CLI_NORMAL_COMPLETION", payload => $pl );
410             }
411              
412 0         0 return $status;
413             }
414              
415              
416             =head3 schedulespec_remark
417              
418             SCHEDULE_SPEC REMARK _TERM
419              
420             =cut
421              
422             sub schedulespec_remark {
423 2 50   2 1 7 print "Entering " . __PACKAGE__ . "::schedulespec_remark\n" if $debug_mode;
424 2         3 my ( $ts, $th ) = @_;
425            
426             # parse test
427 2 50       9 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
428              
429 0         0 my ( $key_spec, $key ) = $th->{'SCHEDULE_SPEC'} =~ m/^(.*)\=(.*)$/;
430 0         0 my $remark = $th->{'_REST'};
431 0         0 $remark =~ s/\"/\'/g;
432              
433 0         0 my $status;
434 0 0       0 if ( $key_spec =~ m/^sco/i ) {
    0          
435 0         0 $status = send_req( 'PUT', "schedule/scode/$key", <<"EOS" );
436             { "remark" : "$remark" }
437             EOS
438             } elsif ( $key_spec =~ m/^sid/ ) {
439 0         0 $status = send_req( 'PUT', "schedule/sid/$key", <<"EOS" );
440             { "remark" : "$remark" }
441             EOS
442             } else {
443 0 0       0 die "AAAHAAAHHH!!! Invalid schedule lookup key " . ( defined( $key_spec ) ? $key_spec : "undefined" )
444             }
445              
446 0 0 0     0 if ( $status->level eq 'OK' and $status->code eq 'DOCHAZKA_CUD_OK' ) {
447 0         0 my $sch_obj = App::Dochazka::Common::Model::Schedule->spawn( %{ $status->payload } );
  0         0  
448 0         0 my $pl = print_schedule_object( $sch_obj );
449 0         0 return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $pl );
450             }
451              
452 0         0 return $status;
453             }
454              
455             =head3 schedulespec_scode
456              
457             SCHEDULE_SPEC SCODE _TERM
458              
459             =cut
460              
461             sub schedulespec_scode {
462 2 50   2 1 7 print "Entering " . __PACKAGE__ . "::schedulespec_scode\n" if $debug_mode;
463 2         3 my ( $ts, $th ) = @_;
464            
465             # parse test
466 2 50       8 return parse_test( $ts, $th ) if $ts eq 'PARSE_TEST';
467              
468 0           my ( $key_spec, $key ) = $th->{'SCHEDULE_SPEC'} =~ m/^(.*)\=(.*)$/;
469 0           my $scode = $th->{'_TERM'};
470              
471 0           my $status;
472 0 0         if ( $key_spec =~ m/^sco/i ) {
    0          
473 0           $status = send_req( 'PUT', "schedule/scode/$key", <<"EOS" );
474             { "scode" : "$scode" }
475             EOS
476             } elsif ( $key_spec =~ m/^sid/ ) {
477 0           $status = send_req( 'PUT', "schedule/sid/$key", <<"EOS" );
478             { "scode" : "$scode" }
479             EOS
480             } else {
481 0 0         die "AAAHAAAHHH!!! Invalid schedule lookup key " . ( defined( $key_spec ) ? $key_spec : "undefined" )
482             }
483              
484 0 0 0       if ( $status->level eq 'OK' and $status->code eq 'DOCHAZKA_CUD_OK' ) {
485 0           my $sch_obj = App::Dochazka::Common::Model::Schedule->spawn( %{ $status->payload } );
  0            
486 0           my $pl = print_schedule_object( $sch_obj );
487 0           return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $pl );
488             }
489              
490 0           return $status;
491             }
492              
493              
494              
495             =head2 Helper functions
496              
497             Functions called by multiple command handlers
498              
499              
500             =head3 _canonicalize_th
501              
502             The canonical form is "SCHEDULE _DOW _TIME _DOW1 _TIME1"
503             so if we get one of the other forms, we "canonicalize th"
504              
505             =cut
506              
507             sub _canonicalize_th {
508 0     0     my $th = shift;
509 0 0         print "Entering " . __PACKAGE__ . "::_canonicalize_th with th: " . Dumper( $th ) . "\n" if $debug_mode;
510              
511 0           my ( $dow_begin, $dow_end, $time_begin, $time_end );
512              
513 0           $dow_begin = uc( $th->{'_DOW'} );
514 0 0         if ( $th->{_TIMERANGE} ) {
515 0           $dow_end = $dow_begin;
516 0           ( $time_begin, $time_end ) = $th->{_TIMERANGE} =~ m/(.*)-(.*)/;
517             } else {
518 0           $dow_end = uc( $th->{'_DOW1'} );
519 0           $time_begin = $th->{'_TIME'};
520 0           $time_end = $th->{'_TIME1'};
521             }
522 0           my ( $tbh, $tbm ) = $time_begin =~ m/(.*):(.*)/;
523 0           $time_begin = sprintf( "%02d:%02d", $tbh, $tbm );
524 0           my ( $teh, $tem ) = $time_end =~ m/(.*):(.*)/;
525 0           $time_end = sprintf( "%02d:%02d", $teh, $tem );
526              
527 0           return ( $dow_begin, $dow_end, $time_begin, $time_end );
528             }
529              
530              
531             =head3 _clear_memsched_entries
532              
533             Since clear_memsched_entries is a command handler, if we want to call it from
534             within this module we have to use a special argument. Thus we can have our cake
535             and eat it, too.
536              
537             =cut
538              
539             sub _clear_memsched_entries {
540 0     0     return clear_memsched_entries( 'DUMMY_ARG' => 0 );
541             }
542              
543              
544             =head3 _dump_memsched_entries
545              
546             Since dump_memsched_entries is a command handler, if we want to call it from
547             within this module we have to use a special argument. Thus we can have our cake
548             and eat it, too.
549              
550             =cut
551              
552             sub _dump_memsched_entries {
553 0     0     return dump_memsched_entries( 'DUMMY_ARG' => 0 );
554             }
555              
556              
557             1;