File Coverage

blib/lib/Siebel/Srvrmgr/Daemon.pm
Criterion Covered Total %
statement 137 188 72.8
branch 40 90 44.4
condition 12 15 80.0
subroutine 25 31 80.6
pod 9 9 100.0
total 223 333 66.9


line stmt bran cond sub pod time code
1             package Siebel::Srvrmgr::Daemon;
2              
3             =pod
4              
5             =head1 NAME
6              
7             Siebel::Srvrmgr::Daemon - super class for sessions with Siebel srvrmgr program
8              
9             =head1 SYNOPSIS
10              
11             package MyDaemon;
12              
13             extends 'Siebel::Srvrmgr::Daemon';
14              
15             =head1 DESCRIPTION
16              
17             This is a super class, and alone it does not provide any functionaly to use srvrmgr to send commands and process returned data.
18              
19             The "private" method C<_setup_commands> must be overrided by subclasses of it or commands will not be sent to C<srvrmgr>.
20              
21             Logging of this class can be enabled by using L<Siebel::Srvrmgr> logging feature.
22              
23             The logic behind this class is easy: you can submit a pair of command/action to the class. It will then connect to the server by executing C<srvrmgr>, submit the command
24             to the server and recover the output generated. The action will be executed having this output as parameter. Anything could be considered as an action, from simple
25             storing the output to even generating new commands to be executed in the server.
26              
27             A command is an instance of L<Siebel::Srvrmgr::Daemon::Command> class. Any "list" command is supported, and also C<load preferences> and C<exit>. Anything else
28             is considered dangerous and will generated an exception. Beware that you will need to have an L<Siebel::Srvrmgr::ListParser::Output> class available to be
29             able to parse the command output.
30              
31             An action can be any class but is obligatory to create a subclass of L<Siebel::Srvrmgr::Daemon::Action> base class. See the <commands>
32             attribute for details.
33              
34             Implementation details are reserved to subclasses of Siebel::Srvrmgr::Daemon: be sure to check them for real usage cenarios.
35              
36             =cut
37              
38 5     5   457864 use Moose;
  5         736034  
  5         40  
39 5     5   38583 use Siebel::Srvrmgr::Regexes qw(SIEBEL_ERROR);
  5         13  
  5         352  
40 5     5   3457 use Siebel::Srvrmgr::ListParser;
  5         23  
  5         226  
41 5     5   47 use Siebel::Srvrmgr;
  5         10  
  5         137  
42 5     5   27 use Scalar::Util qw(weaken);
  5         13  
  5         354  
43 5     5   31 use Config;
  5         13  
  5         204  
44 5     5   31 use Siebel::Srvrmgr::Types;
  5         12  
  5         124  
45 5     5   29 use Fcntl ':flock'; # import LOCK_* constants
  5         11  
  5         730  
46 5     5   30 use Config;
  5         9  
  5         143  
47 5     5   27 use Carp;
  5         11  
  5         306  
48 5     5   29 use File::Spec;
  5         10  
  5         114  
49 5     5   26 use Data::Dumper;
  5         9  
  5         15810  
50              
51             my $SIG_INT = 0;
52             my $SIG_PIPE = 0;
53             my $SIG_ALARM = 0;
54              
55             # :TODO :19/08/2013 16:19:19:: enable Taint Mode
56              
57             =pod
58              
59             =head1 ATTRIBUTES
60              
61             =head2 server
62              
63             This is a string representing the servername where the instance should connect. This is a optional attribute during
64             object creation with the C<new> method.
65              
66             Beware that the C<run> method will verify if the C<server> attribute has a defined value or not: if it has, the C<run>
67             method will try to connect to the Siebel Enterprise specifying the given Siebel Server. If not, the method will try to connect
68             to the Enterprise only, not specifying which Siebel Server to connect.
69              
70             =cut
71              
72             has server => (
73             isa => 'NotNullStr',
74             is => 'rw',
75             required => 0,
76             reader => 'get_server',
77             writer => 'set_server'
78             );
79              
80             =head2 gateway
81              
82             This is a string representing the gateway where the instance should connect. This is a required attribute during
83             object creation with the C<new> method.
84              
85             =cut
86              
87             has gateway => (
88             isa => 'NotNullStr',
89             is => 'rw',
90             required => 1,
91             reader => 'get_gateway',
92             writer => 'set_gateway'
93             );
94              
95             =head2 enterprise
96              
97             This is a string representing the enterprise where the instance should connect. This is a required attribute during
98             object creation with the C<new> method.
99              
100             =cut
101              
102             has enterprise => (
103             isa => 'NotNullStr',
104             is => 'rw',
105             required => 1,
106             reader => 'get_enterprise',
107             writer => 'set_enterprise'
108             );
109              
110             =head2 user
111              
112             This is a string representing the login for authentication. This is a required attribute during
113             object creation with the C<new> method.
114              
115             =cut
116              
117             has user => (
118             isa => 'NotNullStr',
119             is => 'rw',
120             required => 1,
121             reader => 'get_user',
122             writer => 'set_user'
123             );
124              
125             =head2 password
126              
127             This is a string representing the password for authentication. This is a required attribute during
128             object creation with the C<new> method.
129              
130             =cut
131              
132             has password => (
133             isa => 'NotNullStr',
134             is => 'rw',
135             required => 1,
136             reader => 'get_password',
137             writer => 'set_password'
138             );
139              
140             =head2 commands
141              
142             An array reference containing one or more references of L<Siebel::Srvrmgr::Daemon::Commands> class.
143              
144             The commands will be executed in the exactly order as given by the indexes in the array reference (as FIFO).
145              
146             This is a required attribute during object creation with the C<new> method.
147              
148             =cut
149              
150             has commands => (
151             isa => 'ArrayRef[Siebel::Srvrmgr::Daemon::Command]',
152             is => 'rw',
153             required => 1,
154             reader => 'get_commands',
155             writer => 'set_commands',
156             trigger => sub { my $self = shift; $self->_setup_commands() }
157             );
158              
159             =pod
160              
161             =head2 bin
162              
163             An string representing the full path to the C<srvrmgr> program in the filesystem.
164              
165             This is a required attribute during object creation with the C<new> method.
166              
167             =cut
168              
169             has bin => (
170             isa => 'NotNullStr',
171             is => 'rw',
172             required => 1,
173             reader => 'get_bin',
174             writer => 'set_bin'
175             );
176              
177             =pod
178              
179             =head2 time_zone
180              
181             Required attribute.
182              
183             A string representing the time zone to be considered for all date/time values recovered from C<srvrmgr>.
184              
185             See L<DateTime::TimeZone> C<all_names> methods to list the available time zones that you can use. The on-liner
186             below show do it for you to find a proper value:
187              
188             perl -MDateTime::TimeZone -e 'foreach ( DateTime::TimeZone->all_names ) { print "$_\n" }'
189              
190             =cut
191              
192             has time_zone =>
193             ( isa => 'Str', is => 'ro', required => 1, reader => 'get_time_zone' );
194              
195             =pod
196              
197             =head2 alarm_timeout
198              
199             The an integer value that will raise an ALARM signal generated by C<alarm>. The default value is 30 seconds.
200              
201             Besides C<read_timeout>, this will raise an exception and exit the read loop from srvrmgr in cases were an output cannot be retrieved.
202              
203             This attribute will be reset every time a read can be done from the STDOUT or STDERR from srvrmgr.
204              
205             =cut
206              
207             has alarm_timeout => (
208             is => 'Int',
209             is => 'rw',
210             writer => 'set_alarm',
211             reader => 'get_alarm',
212             default => 30
213             );
214              
215             =pod
216              
217             =head2 use_perl
218              
219             A boolean attribute used mostly for testing of this class.
220              
221             If true, if will prepend the complete path of the Perl interpreter to the parameters before calling the C<srvrmgr> program (of course the "srvrmgr" must
222             be itself a Perl script).
223              
224             It defaults to false.
225              
226             =cut
227              
228             has use_perl =>
229             ( isa => 'Bool', is => 'ro', reader => 'use_perl', default => 0 );
230              
231             =head2 lang_id
232              
233             A string representing the LANG_ID parameter to connect to srvrmgr. If defaults to "ENU";
234              
235             =cut
236              
237             has lang_id => (
238             isa => 'Str',
239             is => 'rw',
240             reader => 'get_lang_id',
241             writer => 'set_lang_id',
242             default => 'ENU'
243             );
244              
245             =head2 child_runs
246              
247             An integer representing the number of times the child object was used in C<run> invocations. This is reset to zero if a new child process is created.
248              
249             =cut
250              
251             has child_runs => (
252             isa => 'Int',
253             is => 'ro',
254             reader => 'get_child_runs',
255             writer => '_set_child_runs',
256             default => 0
257             );
258              
259             =head2 maximum_retries
260              
261             The maximum times this class wil retry to launch a new process of srvrmgr if the previous one failed for any reason. This is intented to implement
262             robustness to the process.
263              
264             =cut
265              
266             has maximum_retries => (
267             isa => 'Int',
268             is => 'ro',
269             reader => 'get_max_retries',
270             writer => '_set_max_retries',
271             default => 5
272             );
273              
274             =head2 retries
275              
276             The number of retries of launching a new srvrmgr process. If this value reaches the value defined for C<maximum_retries>, the instance of Siebel::Srvrmgr::Daemon
277             will quit execution returning an error code.
278              
279             =cut
280              
281             has retries => (
282             isa => 'Int',
283             is => 'ro',
284             reader => 'get_retries',
285             writer => '_set_retries',
286             default => 0
287             );
288              
289             =head2 clear_raw
290              
291             A boolean attribute that defines if the raw data recovered from C<srvrmgr> should be kept or discarded as soon as possibly.
292              
293             Having a default value of true, it should help reducing memory usage or debugging, if set false.
294              
295             =cut
296              
297             has clear_raw => (
298             is => 'rw',
299             isa => 'Bool',
300             reader => 'clear_raw',
301             writer => 'set_clear_raw',
302             default => 1
303             );
304              
305             =head2 field_delimiter
306              
307             This is a single character attribute. It tells the Daemon class to consider a field delimiter, if such options was
308             set in the C<srvrmgr> program. If this option is used but this attribute is not set accordinly, parsing will probably
309             fail.
310              
311             Since this attribute should be defined during Daemon object instance, it is read-only.
312              
313             =cut
314              
315             has field_delimiter => ( is => 'ro', isa => 'Chr', reader => 'get_field_del' );
316              
317             =head2 has_lock
318              
319             Optional parameter.
320              
321             This is a boolean attribute (in the sense of Perl) that identifies if the L<Daemon> needs to use a lock or not. Default is false.
322              
323             Using a lock is useful to avoid two instances of the same C<Daemon> running. See also C<lock_dir> attribute.
324              
325             =cut
326              
327             has has_lock => ( is => 'ro', isa => 'Bool', default => 0 );
328              
329             =head2 lock_dir
330              
331             Optional parameter.
332              
333             This parameter is used to determine the location in the filesystem to create the lock file.
334              
335             Expects a string as parameter. The directory must be readable and writable to the user running the C<Daemon>.
336              
337             It defaults to the "home" directory of the user. The sense of "home" is the following as defined by the platform:
338              
339             This attribute is lazy and defined by the C<_define_lock_dir> "private" method.
340              
341             =over
342              
343             =item *
344              
345             Microsoft Windows: C<$ENV{HOMEDIR}>
346              
347             =item *
348              
349             UNIX-like: C<$ENV{HOME}>
350              
351             =back
352              
353             =cut
354              
355             has lock_dir => (
356             is => 'rw',
357             isa => 'Str',
358             reader => 'get_lock_dir',
359             writer => 'set_lock_dir',
360             lazy => 1,
361             builder => '_define_lock_dir'
362             );
363              
364             =pod
365              
366             =head2 cmd_stack
367              
368             This is an array reference with the stack of commands to be executed. It is maintained automatically by the class, so the attribute is read-only.
369              
370             =cut
371              
372             has cmd_stack => (
373             isa => 'ArrayRef',
374             is => 'ro',
375             writer => '_set_cmd_stack',
376             reader => 'get_cmd_stack'
377             );
378              
379             =pod
380              
381             =head1 METHODS
382              
383             =head2 get_time_zone
384              
385             Returns the content of the attribute C<time_zone>.
386              
387             =head2 get_cmd_stack
388              
389             Returns the content of the attribute C<cmd_stack>.
390              
391             =head2 get_field_del
392              
393             Getter for the C<field_delimiter> attribute.
394              
395             =head2 clear_raw
396              
397             Getter for the C<clear_raw> attribute.
398              
399             =head2 set_clear_raw
400              
401             Setter for the C<clear_raw> attribute.
402              
403             =head2 get_alarm
404              
405             Returns the content of the C<alarm_timeout> attribute.
406              
407             =head2 set_alarm
408              
409             Sets the attribute C<alarm_timeout>. Expects an integer as parameter, in seconds.
410              
411             =head2 get_child_runs
412              
413             Returns the value of the attribute C<child_runs>.
414              
415             =head2 use_perl
416              
417             Returns the content of the attribute C<use_perl>.
418              
419             =head2 get_buffer_size
420              
421             Returns the value of the attribute C<ipc_buffer_size>.
422              
423             =head2 set_buffer_size
424              
425             Sets the attribute C<ipc_buffer_size>. Expects an integer as parameter, multiple of 1024.
426              
427             =head2 get_lang_id
428              
429             Returns the value of the attribute C<lang_id>.
430              
431             =head2 set_lang_id
432              
433             Sets the attribute C<lang_id>. Expects a string as parameter.
434              
435             =head2 get_server
436              
437             Returns the content of C<server> attribute as a string.
438              
439             =head2 set_server
440              
441             Sets the attribute C<server>. Expects an string as parameter.
442              
443             =head2 get_gateway
444              
445             Returns the content of C<gateway> attribute as a string.
446              
447             =head2 set_gateway
448              
449             Sets the attribute C<gateway>. Expects a string as parameter.
450              
451             =head2 get_enterprise
452              
453             Returns the content of C<enterprise> attribute as a string.
454              
455             =head2 set_enterprise
456              
457             Sets the C<enterprise> attribute. Expects a string as parameter.
458              
459             =head2 get_user
460              
461             Returns the content of C<user> attribute as a string.
462              
463             =head2 set_user
464              
465             Sets the C<user> attribute. Expects a string as parameter.
466              
467             =head2 get_password
468              
469             Returns the content of C<password> attribute as a string.
470              
471             =head2 set_password
472              
473             Sets the C<password> attribute. Expects a string as parameter.
474              
475             =head2 get_commands
476              
477             Returns the content of the attribute C<commands>.
478              
479             =head2 set_commands
480              
481             Set the content of the attribute C<commands>. Expects an array reference as parameter.
482              
483             =head2 get_bin
484              
485             Returns the content of the C<bin> attribute.
486              
487             =head2 set_bin
488              
489             Sets the content of the C<bin> attribute. Expects a string as parameter.
490              
491             =head2 get_pid
492              
493             Returns the content of C<pid> attribute as an integer.
494              
495             =head2 BUILD
496              
497             L<Moose> BUILD method is used by this class to install signal handlers for the following signals:
498              
499             =over
500              
501             =item *
502              
503             INT
504              
505             =item *
506              
507             PIPE
508              
509             =item *
510              
511             ALRM
512              
513             =back
514              
515             Also the method sets the environment variable C<SIEBEL_TZ> if a time zone was set.
516              
517             If the logging is set to C<DEBUG> level all attribute values will be logged.
518              
519             =cut
520              
521             sub BUILD {
522              
523 3     3 1 9 my $self = shift;
524              
525 3     0   53 $SIG{INT} = sub { $SIG_INT = 1 };
  0         0  
526 3     0   35 $SIG{PIPE} = sub { $SIG_PIPE = 1 };
  0         0  
527 3     0   26 $SIG{ALRM} = sub { $SIG_ALARM = 1 };
  0         0  
528 3         142 $ENV{SIEBEL_TZ} = $self->get_time_zone();
529              
530 3         35 my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
531              
532 3 50       986 if ( $logger->is_debug() ) {
533              
534 0         0 $logger->debug('This instance attributes values:');
535              
536 0         0 foreach my $attrib ( $self->meta->get_all_attributes() ) {
537              
538 0         0 my $getter = $attrib->get_read_method();
539 0         0 my $value = $self->$getter;
540 0 0       0 $value = 'UNDEFINED' unless ( defined($value) );
541              
542 0 0       0 if ( ref($value) ne '' ) {
543              
544 0         0 $logger->debug(
545             'attribute ' . $attrib->name() . ' = ' . Dumper($value) );
546              
547             }
548             else {
549              
550 0         0 $logger->debug(
551             'attribute ' . $attrib->name() . ' = ' . $value );
552              
553             }
554              
555             }
556              
557             }
558              
559             }
560              
561             =head2 reset_retries
562              
563             Reset the retries of creating a new process of srvrmgr program, setting the attribute C<retries> to zero.
564              
565             =cut
566              
567             sub reset_retries {
568              
569 0     0 1 0 my $self = shift;
570              
571 0         0 $self->_set_retries(0);
572              
573 0         0 return 1;
574              
575             }
576              
577             =head2 check_cmd
578              
579             This methods expects as parameter a string representing a C<srvrmgr> command.
580              
581             The command will be checked and if considered insecure, an exception will be raised.
582              
583             Commands considered secure are:
584              
585             =over
586              
587             =item *
588              
589             load preferences
590              
591             =item *
592              
593             list <anything>
594              
595             =item *
596              
597             exit
598              
599             =item *
600              
601             set delimiter
602              
603             =back
604              
605             This method is also used internally through the C<_setup_commands> method.
606              
607             =cut
608              
609             sub check_cmd {
610              
611 38     38 1 84356 my $self = shift;
612 38         72 my $cmd = shift;
613              
614 38 50       107 confess( 'Invalid command received for execution: '
615             . Dumper( $self->get_cmd_stack() ) )
616             unless ( defined($cmd) );
617              
618 38 50 100     511 confess("Insecure command from command stack [$cmd]. Execution aborted")
      66        
      66        
619             unless ( ( $cmd =~ /^load/ )
620             or ( $cmd =~ /^list/ )
621             or ( $cmd =~ /^set\sdelimiter\s[[:graph:]]/ )
622             or ( $cmd =~ /^exit/ ) );
623              
624 28         80 return 1;
625              
626             }
627              
628             =pod
629              
630             =head2 shift_commands
631              
632             Does a C<shift> in the C<commands> attribute.
633              
634             Does not expects any parameter. Returns the C<shift>ed L<Siebel::Srvrmgr::Daemon::Command> instance or C<undef> if there is only B<one>
635             command left (which is not C<shift>ed).
636              
637             This method is useful specially if the Daemon will keep executing commands, but setup commands (like C<load preferences>) are not necessary to be executed
638             again.
639              
640             =cut
641              
642             sub shift_commands {
643              
644 4     4 1 33 my $self = shift;
645              
646 4         176 my $cmds_ref = $self->get_commands();
647              
648 4 50       12 if ( scalar( @{$cmds_ref} ) > 1 ) {
  4         14  
649              
650 4         13 my $shifted = shift( @{$cmds_ref} );
  4         11  
651 4         167 $self->set_commands($cmds_ref); # must trigger the attribute
652 4         26 return $shifted;
653              
654             }
655             else {
656              
657 0         0 return undef;
658              
659             }
660              
661             }
662              
663             =pod
664              
665             =head2 run
666              
667             This is the method used to execute commands in srvrmgr program and must be overrided by subclasses of Siebel::Srvrmgr::Daemon.
668             Subclasses should invoke L<Moose> C<super> to when doing override because this implementation will apply lock control when appropriate.
669              
670             =cut
671              
672             sub run {
673              
674 20     20 1 630 my $self = shift;
675              
676 20 100       1085 if ( $self->has_lock ) {
677              
678 8         60 $self->_create_lock;
679              
680             }
681              
682             }
683              
684             =pod
685              
686             =head2 normalize_eol
687              
688             Expects an array reference as parameter.
689              
690             Changes any EOL character to LF from each index value.
691              
692             See perlport -> Issues -> Newlines for details on this.
693              
694             =cut
695              
696             sub normalize_eol {
697              
698 27     27 1 106 my $self = shift;
699 27         86 my $data_ref = shift;
700              
701 27         93 my $ref_type = ref($data_ref);
702              
703 27 50 66     251 confess 'data parameter must be an array or scalar reference'
704             unless ( ( $ref_type eq 'ARRAY' ) or ( $ref_type eq 'SCALAR' ) );
705              
706 27         223 my $c_regex = qr/\015?\012/;
707              
708 27 100       138 if ( $ref_type eq 'ARRAY' ) {
709              
710 3         28 local $/ = \012;
711              
712 3         9 foreach ( @{$data_ref} ) {
  3         29  
713              
714 1047         13389 s/$c_regex/\n/g;
715              
716             }
717              
718             }
719             else {
720              
721 24         2764 $$data_ref =~ s/$c_regex/\n/g;
722              
723             }
724              
725             }
726              
727             =pod
728              
729             =head2 create_parser
730              
731             Returns an instance of a L<Siebel::Srvrmgr::ListParser> class.
732              
733             =cut
734              
735             sub create_parser {
736              
737 20     20 1 47 my $self = shift;
738              
739 20 50       990 if ( $self->get_field_del() ) {
740              
741 0         0 return Siebel::Srvrmgr::ListParser->new(
742             {
743             clear_raw => $self->clear_raw(),
744             field_delimiter => $self->get_field_del()
745             }
746             );
747              
748             }
749             else {
750              
751 20         833 return Siebel::Srvrmgr::ListParser->new(
752             { clear_raw => $self->clear_raw() } );
753              
754             }
755              
756             }
757              
758             sub _define_params {
759              
760 5     5   89 my $self = shift;
761              
762 5         264 my @params = (
763             $self->get_bin(), '/e',
764             $self->get_enterprise(), '/g',
765             $self->get_gateway(), '/u',
766             $self->get_user(), '/l',
767             $self->get_lang_id()
768              
769             );
770              
771 5 50       250 push( @params, '/s', $self->get_server() )
772             if ( defined( $self->get_server() ) );
773              
774 5 50       275 push( @params, '/k', $self->get_field_del() )
775             if ( defined( $self->get_field_del() ) );
776              
777             # :WORKAROUND:06/08/2013 21:05:32:: if a perl script will be executed (like for automated testing of this distribution)
778             # then the perl interpreter must be part of the command path to avoid calling cmd.exe in Microsoft Windows
779 5 50       236 unshift( @params, $Config{perlpath} ) if ( $self->use_perl() );
780              
781 5         39 return \@params;
782              
783             }
784              
785             =head2 get_lock_file
786              
787             Returns the complete path to the lock file as a string.
788              
789             =cut
790              
791             sub get_lock_file {
792              
793 12     12 1 28 my $self = shift;
794              
795 12         56 my $filename = blessed($self);
796 12         78 $filename =~ s/\:{2}/_/g;
797              
798 12         665 return File::Spec->catfile( $self->get_lock_dir, ( $filename . '.lock' ) );
799              
800             }
801              
802             our $adm_60070 = qr/^SBL-ADM-60070.*/;
803             our $adm_02043 = qr/^SBL-ADM-02043.*/;
804             our $adm_02071 = qr/^SBL-ADM-02071.*/;
805             our $adm_02049 = qr/^SBL-ADM-02049.*/;
806             our $adm_02751 = qr/^SBL-ADM-02751.*/;
807             our $siebel_error = SIEBEL_ERROR;
808              
809             # Fatal error (2555922): (null), exiting...
810             our $fatal_error = qr/Fatal error.*exiting\.\.\./;
811              
812             # this method will check for errors and warnings, specially if read from STDERR.
813             # the first parameter is the data to be check, which can be an array reference or scalar, both will be checked the same way
814             # the seconds parameter tells if the data was read from STDERR or not. If read from STDERR, data will be logged as warnings
815             # if no critical error was detected
816             sub _check_error {
817              
818 1115     1115   2281 my $self = shift;
819 1115         2041 my $content = shift;
820 1115         1955 my $is_error = shift; #boolean
821              
822 1115         6548 my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
823              
824             # :WORKAROUND: to enable the code to process both scalar and array reference data
825             # without duplicating code
826              
827 1115 100       34338 unless ( ref($content) eq 'ARRAY' ) {
828              
829 1091         1929 my $temp = $content;
830 1091         3144 $content = [$temp];
831              
832             }
833              
834 1115         1972 foreach my $line ( @{$content} ) {
  1115         3081  
835              
836 1115 50       6161 if ( $line =~ $fatal_error ) {
837              
838 0         0 $logger->logdie("Failed to connect to: [$line]");
839              
840             }
841              
842 1115 100       4596 if ( $line =~ $siebel_error ) {
843              
844             SWITCH: {
845              
846 1 50       4 if ( $line =~ $adm_60070 ) {
  1         9  
847              
848 0 0       0 if ( $logger->is_warn() ) {
849              
850 0         0 $logger->warn(
851             "Found [$line]. Trying to get additional information from next line"
852             );
853 0         0 return 1;
854              
855             }
856             }
857              
858 1 50       15 if ( $line =~ $adm_02043 ) {
859 1         19 $logger->logdie('Could not find the Siebel Server');
860             }
861              
862 0 0       0 if ( $line =~ $adm_02071 ) {
863 0         0 $logger->logdie('Could not find the Siebel Enterprise');
864             }
865              
866 0 0       0 if ( $line =~ $adm_02049 ) {
867 0         0 $logger->logdie('Generic error');
868             }
869              
870 0 0       0 if ( $line =~ $adm_02751 ) {
871 0         0 $logger->logdie('Unable to open file');
872             }
873             else {
874 0         0 $logger->logdie(
875             "Unknown error [$line], aborting execution");
876             }
877              
878             }
879              
880             }
881             else {
882              
883 1114 50       4126 $logger->debug(
884             "Got $line. Since it doesn't look like a Siebel error, I will try to keep running"
885             ) if ( $logger->is_debug );
886              
887 1114 100 100     9718 $logger->warn($line) if ( $logger->is_warn() and $is_error );
888              
889 1114         11658 return 1;
890              
891             }
892              
893             }
894              
895             }
896              
897             =pod
898              
899             =head2 DEMOLISH
900              
901             This method is invoked before the object instance is destroyed. It does really few things like writting messages to the define configuration of
902             L<Log::Log4perl> logger. It will also log if ALRM, INT or PIPE signals were received.
903              
904             Subclasses may want to C<override> the method "private" C<_my_cleanup> to do their properly laundry since the definition of C<_my_cleanup> for this class
905             is just to C<return> true. C<_my_cleanup> is called with a reference of a L<Log::Log4perl::Logger> instance for usage.
906              
907             =cut
908              
909             sub DEMOLISH {
910              
911 13     13 1 31 my $self = shift;
912              
913 13         110 my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
914              
915 13         3455 $logger->info('Terminating daemon: preparing cleanup');
916              
917 13         155 $self->_my_cleanup();
918              
919 13 100       565 if ( $self->has_lock() ) {
920              
921 2         37 $self->_del_lock();
922              
923             }
924              
925 13         59 $logger->info('Cleanup is finished');
926              
927 13 100       124 if ( $logger->is_warn() ) {
928              
929 12 50       91 $logger->warn('Program termination was forced by ALRM signal')
930             if ($SIG_ALARM);
931 12 50       32 $logger->warn('Program termination was forced by INT signal')
932             if ($SIG_INT);
933 12 50       32 $logger->warn('Program termination was forced by PIPE signal')
934             if ($SIG_PIPE);
935              
936             }
937              
938 13 50       57 $logger->info( ref($self) . ' says bye-bye' ) if ( $logger->is_info() );
939              
940 13         131 Log::Log4perl->remove_logger($logger);
941              
942             }
943              
944             =head1 CONSTANTS
945              
946             The following constants are available in this class:
947              
948             =over
949              
950             =item LOCK_EX
951              
952             =item LOCK_NB
953              
954             =back
955              
956             All of them from the L<Fcntl> module.
957              
958             =cut
959              
960             sub _create_lock {
961              
962 8     8   16 my $self = shift;
963              
964 8         163 my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
965              
966 8         346 my $lock_file = $self->get_lock_file;
967              
968 8 100       506 if ( -e $lock_file ) {
969              
970 6 50       355 open( my $in, '<', $lock_file )
971             or $logger->logdie("Cannot read $lock_file: $!");
972 6 50       75 flock( $in, LOCK_EX | LOCK_NB )
973             or $logger->logdie("Could not get exclusive lock on $lock_file: $!");
974 6         35 local $/ = undef;
975 6         131 my $pid = <$in>;
976 6         126 close($in);
977              
978 6 50       85 $logger->logdie(
979             "Previous executing is still running (PID $pid), cannot execute")
980             if ( $pid != $$ );
981              
982             }
983             else {
984              
985 2 50       346 open( my $out, '>', $lock_file )
986             or $logger->logdie("Cannot create $lock_file: $!");
987 2 50       29 flock( $out, LOCK_EX | LOCK_NB )
988             or $logger->logdie("Could not get exclusive lock on $lock_file: $!");
989 2         46 print $out $$;
990 2         196 close($out);
991              
992             }
993              
994             }
995              
996             sub _del_lock {
997              
998 2     2   6 my $self = shift;
999 2         14 my $lock_file = $self->get_lock_file;
1000              
1001 2         26 my $logger = Siebel::Srvrmgr->gimme_logger( blessed($self) );
1002              
1003 2 50       194 if ( -e $lock_file ) {
1004              
1005 2 50       329 unlink($lock_file)
1006             or $logger->logdie("Could not remove $lock_file: $!");
1007              
1008             }
1009             else {
1010              
1011 0         0 $logger->warn(
1012             'Could not find lock file to remove before program termination');
1013              
1014             }
1015              
1016             }
1017              
1018             sub _my_cleanup {
1019              
1020 0     0   0 return 1;
1021              
1022             }
1023              
1024             sub _define_lock_dir {
1025              
1026 0     0   0 my $lock_dir = undef;
1027              
1028             CASE: {
1029              
1030 0 0       0 if ( $Config{osname} =~ /^linux$/i ) {
  0         0  
1031              
1032 0         0 $lock_dir = $ENV{HOME};
1033 0         0 last CASE;
1034              
1035             }
1036              
1037 0 0       0 if ( $Config{osname} =~ /^aix$/i ) {
1038              
1039 0         0 $lock_dir = $ENV{HOME};
1040 0         0 last CASE;
1041              
1042             }
1043              
1044 0 0       0 if ( $Config{osname} =~ /^hpux$/i ) {
1045              
1046 0         0 $lock_dir = $ENV{HOME};
1047 0         0 last CASE;
1048              
1049             }
1050              
1051 0 0       0 if ( $Config{osname} =~ /^mswin32$/i ) {
1052              
1053 0 0       0 if ( defined( $ENV{HOMEDIR} ) ) {
1054              
1055 0         0 $lock_dir = $ENV{HOMEDIR};
1056              
1057             }
1058             else {
1059              
1060 0         0 $lock_dir = $ENV{USERPROFILE};
1061              
1062             }
1063              
1064 0         0 last CASE;
1065              
1066             }
1067              
1068 0 0       0 if ( $Config{osname} =~ /^solaris$/i ) {
1069              
1070 0         0 $lock_dir = $ENV{HOME};
1071 0         0 last CASE;
1072              
1073             }
1074             else {
1075              
1076 0         0 confess "don't know what to do with $Config{osname}";
1077              
1078             }
1079              
1080             }
1081              
1082 0 0       0 confess "could not defined a lock_dir for $Config{osname}"
1083             unless ( defined($lock_dir) );
1084              
1085 0         0 return $lock_dir;
1086              
1087             }
1088              
1089             sub _setup_commands {
1090              
1091 12     12   300 my $self = shift;
1092              
1093 12         22 foreach my $cmd ( @{ $self->get_commands } ) {
  12         539  
1094              
1095 28         1378 $self->check_cmd( $cmd->get_command() );
1096              
1097             }
1098              
1099             }
1100              
1101             =pod
1102              
1103             =head1 SEE ALSO
1104              
1105             =over
1106              
1107             =item *
1108              
1109             L<Moose>
1110              
1111             =item *
1112              
1113             L<Siebel::Srvrmgr::Daemon::ActionFactory>
1114              
1115             =item *
1116              
1117             L<Siebel::Srvrmgr::ListParser>
1118              
1119             =item *
1120              
1121             L<Siebel::Srvrmgr::Regexes>
1122              
1123             =item *
1124              
1125             L<POSIX>
1126              
1127             =item *
1128              
1129             L<Siebel::Srvrmgr::Daemon::Command>
1130              
1131             =item *
1132              
1133             L<Fcntl>
1134              
1135             =back
1136              
1137             =head1 AUTHOR
1138              
1139             Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.orgE<gt>
1140              
1141             =head1 COPYRIGHT AND LICENSE
1142              
1143             This software is copyright (c) 2012 of Alceu Rodrigues de Freitas Junior, E<lt>arfreitas@cpan.orgE<gt>
1144              
1145             This file is part of Siebel Monitoring Tools.
1146              
1147             Siebel Monitoring Tools is free software: you can redistribute it and/or modify
1148             it under the terms of the GNU General Public License as published by
1149             the Free Software Foundation, either version 3 of the License, or
1150             (at your option) any later version.
1151              
1152             Siebel Monitoring Tools is distributed in the hope that it will be useful,
1153             but WITHOUT ANY WARRANTY; without even the implied warranty of
1154             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1155             GNU General Public License for more details.
1156              
1157             You should have received a copy of the GNU General Public License
1158             along with Siebel Monitoring Tools. If not, see <http://www.gnu.org/licenses/>.
1159              
1160             =cut
1161              
1162             __PACKAGE__->meta->make_immutable;
1163              
1164             1;
1165