File Coverage

blib/lib/CASCM/CLI.pm
Criterion Covered Total %
statement 42 147 28.5
branch 0 40 0.0
condition 0 19 0.0
subroutine 14 26 53.8
pod 0 1 0.0
total 56 233 24.0


line stmt bran cond sub pod time code
1             package CASCM::CLI;
2              
3             #######################
4             # LOAD MODULES
5             #######################
6 1     1   631 use 5.008001;
  1         3  
  1         33  
7              
8 1     1   4 use strict;
  1         1  
  1         34  
9 1     1   12 use warnings FATAL => 'all';
  1         1  
  1         43  
10 1     1   4 use Carp qw(croak carp);
  1         1  
  1         74  
11              
12 1     1   4 use File::Spec;
  1         1  
  1         25  
13 1     1   435 use Config::Tiny;
  1         764  
  1         25  
14 1     1   458 use File::HomeDir;
  1         4554  
  1         62  
15 1     1   519 use CASCM::Wrapper;
  1         24061  
  1         56  
16 1     1   780 use Log::Any::Adapter;
  1         20123  
  1         7  
17 1     1   780 use Hash::Merge qw(merge);
  1         3195  
  1         110  
18 1     1   686 use Getopt::Mini ( later => 1 );
  1         50703  
  1         7  
19 1     1   509 use Log::Any::Adapter::Callback;
  1         2356  
  1         32  
20 1     1   661 use Getopt::Long qw(GetOptionsFromArray);
  1         8438  
  1         6  
21 1     1   687 use Object::Tiny qw(cascm exitval context);
  1         270  
  1         5  
22              
23             #######################
24             # VERSION
25             #######################
26             our $VERSION = '0.1.1';
27              
28             #######################
29             # RUNNER
30             #######################
31             sub run {
32 0     0 0   my ( $self, @args ) = @_;
33              
34             # Initialize
35 0           $self->_init();
36 0           local @ARGV = ();
37              
38             # Parse main arguments
39 0           my $main_options = {};
40 0 0         GetOptionsFromArray( \@args, $main_options, $self->_main_opt_spec() )
41             or $self->_print_bad_opts();
42              
43             # Get Subcommand
44 0           my $subcmd = shift @args;
45 0 0 0       if ( $subcmd and ( $subcmd !~ m{^[a-z]+$}xi ) ) {
46 0           $self->_print_bad_subcmd($subcmd);
47             }
48              
49             # Get Subcommand options
50 0           my %sub_options = getopt(
51             hungry_flags => 1,
52             argv => [@args],
53             );
54 0 0         delete $sub_options{_argv} if exists $sub_options{_argv};
55              
56             # Get Subcommand arguments
57 0           my @sub_args;
58 0 0         if ( exists $sub_options{''} ) {
59 0 0         if ( ref( $sub_options{''} ) eq 'ARRAY' ) {
60 0           push( @sub_args, @{ $sub_options{''} } );
  0            
61             }
62             else {
63 0           push( @sub_args, $sub_options{''} );
64             }
65 0           delete $sub_options{''};
66             } ## end if ( exists $sub_options...)
67              
68             # Make lowercase
69 0 0         $subcmd = '' if not defined $subcmd;
70 0           $subcmd = lc($subcmd);
71              
72             # Check for help
73 0 0 0       if ( ( $subcmd eq 'help' ) or ( $main_options->{help} ) ) {
74 0           $self->_print_help();
75 0           exit 0;
76             } ## end if ( ( $subcmd eq 'help'...))
77              
78             # Check for version
79 0 0 0       if ( ( $subcmd eq 'version' ) or ( $main_options->{version} ) ) {
80 0           $self->_print_version();
81 0           exit 0;
82             } ## end if ( ( $subcmd eq 'version'...))
83              
84             # Check for Subcommand
85 0 0         if ( not $subcmd ) {
86 0           $self->_print_help();
87 0           exit 1;
88             } ## end if ( not $subcmd )
89              
90             # Initialize Logger
91 0           $self->_init_logger();
92              
93             # Initialize context
94 0   0       $self->_init_context( $main_options->{context} || '' );
95              
96             # Initialize CASCM
97 0           $self->_init_cascm();
98              
99             # Check if subcommand is supported
100 0 0         if ( not $self->cascm()->can($subcmd) ) {
101 0           $self->_print_bad_subcmd($subcmd);
102             }
103              
104             # Run subcommand
105 0           $self->cascm()->$subcmd( {%sub_options}, @sub_args );
106 0           $self->{exitval} = $self->cascm()->exitval();
107              
108 0           return 1;
109             } ## end sub run
110              
111             #######################
112             # INTERNAL
113             #######################
114              
115             # Initialize
116             sub _init {
117 0     0     my ($self) = @_;
118              
119             # Setup getopt long
120 0           Getopt::Long::Configure('default');
121 0           Getopt::Long::Configure('pass_through');
122 0           Getopt::Long::Configure('no_auto_abbrev');
123              
124             # Set exit value
125 0           $self->{exitval} = 0;
126              
127 0           return 1;
128             } ## end sub _init
129              
130             # Main option spec
131             sub _main_opt_spec {
132              
133             return (
134 0     0     'help', # Print Help
135             'version', # Print Version
136             'context=s', # Set Context file
137             );
138              
139             } ## end sub _main_opt_spec
140              
141              
142             sub _print_bad_opts {
143 0     0     print STDERR "Invalid Options. See 'hv --help'\n";
144 0           exit 1;
145             } ## end sub _print_bad_opts
146              
147              
148             sub _print_bad_subcmd {
149 0     0     my ( $self, $cmd ) = @_;
150 0           print STDERR "Invalid command '$cmd'. See 'hv --help'\n";
151 0           exit 1;
152             } ## end sub _print_bad_subcmd
153              
154              
155             sub _print_help {
156 0     0     my ($self) = @_;
157              
158 0           $self->_print_version();
159              
160 0           print <<'_EO_HELP';
161             USAGE: hv [options] command [command_options] [arguments]
162              
163             Options:
164              
165             help Print this message
166             version Print version information
167             context Specify the context file
168              
169             Commands:
170              
171             This is typically your Harvest CLI command
172             Please see the documentation of CASCM::Wrapper for the list of
173             supported commands
174             Command options and arguments are passed through to the harvest CLI
175              
176             --
177             _EO_HELP
178              
179 0           return 1;
180             } ## end sub _print_help
181              
182              
183             sub _print_version {
184 0     0     my ($self) = @_;
185 0           print "hv version-${VERSION}\n";
186 0           return 1;
187             } ## end sub _print_version
188              
189              
190             sub _init_logger {
191 0     0     my ($self) = @_;
192              
193             Log::Any::Adapter->set(
194             'Callback',
195             min_level => 'info',
196             logging_cb => sub {
197 0     0     my ( $method, $self, $format, @params ) = @_;
198 0           chomp( $format, @params );
199 0           $method = uc($method);
200 0 0 0       if ( ( $method eq 'WARNING' ) or ( $method eq 'ERROR' ) ) {
201 0           print STDERR "[$method] $format\n";
202             }
203             else {
204 0           print "[$method] $format\n";
205             }
206             },
207 0           );
208              
209 0           return 1;
210             } ## end sub _init_logger
211              
212              
213             sub _init_context {
214 0     0     my ( $self, $main_ctx_file ) = @_;
215              
216             # Check for system-wide context in $CASCM_HOME
217 0           my $system_context = {};
218 0   0       my $cascm_home = $ENV{CA_SCM_HOME} || $ENV{HARVEST_HOME} || '';
219 0 0         if ($cascm_home) {
220 0           my $system_ctx_file = File::Spec->catfile( $cascm_home, 'hvcontext' );
221 0 0         if ( -e $system_ctx_file ) {
222 0           $system_context = $self->_load_context($system_ctx_file);
223             }
224             } ## end if ($cascm_home)
225              
226             # Check for user's context file
227 0           my $user_context = {};
228 0           my $user_ctx_file;
229 0 0         if ( $ENV{HVCONTEXT} ) {
230 0           $user_ctx_file = $ENV{HVCONTEXT};
231             }
232             else {
233 0           my $homedir = File::HomeDir->my_home();
234 0 0 0       if ( $homedir and -e $homedir ) {
235 0           $user_ctx_file = File::Spec->catfile( $homedir, '.hvcontext' );
236             }
237             } ## end else [ if ( $ENV{HVCONTEXT} )]
238 0 0         if ( -e $user_ctx_file ) {
239 0           $user_context = $self->_load_context($user_ctx_file);
240             }
241              
242             # Check for current context
243 0           my $current_context = {};
244 0           my $current_ctx_file;
245 0 0         if ($main_ctx_file) {
246 0           $current_ctx_file = $main_ctx_file;
247             }
248             else {
249 0           $current_ctx_file = '.hvcontext';
250             }
251 0 0         if ( -e $current_ctx_file ) {
252 0           $current_context = $self->_load_context($current_ctx_file);
253             }
254              
255             # Merge Context
256 0           my $current_and_user = merge( $current_context, $user_context );
257 0           my $context = merge( $current_and_user, $system_context );
258              
259 0           $self->{context} = $context;
260 0           return 1;
261             } ## end sub _init_context
262              
263              
264             sub _load_context {
265 0     0     my ( $self, $file ) = @_;
266              
267 0 0         my $config = Config::Tiny->read($file)
268             or die "ERROR: Failed to read $file";
269              
270 0           my $context = {};
271 0           foreach ( keys %{$config} ) {
  0            
272 0 0         if ( $_ eq '_' ) { $context->{global} = $config->{$_}; }
  0            
273 0           else { $context->{$_} = $config->{$_}; }
274             } ## end foreach ( keys %{$config} )
275              
276 0           return $context;
277             } ## end sub _load_context
278              
279              
280             sub _init_cascm {
281 0     0     my ($self) = @_;
282 0           my $cascm = CASCM::Wrapper->new(
283             {
284             parse_logs => 1,
285             }
286             );
287 0           $cascm->set_context( $self->context() );
288 0           $self->{cascm} = $cascm;
289 0           return 1;
290             } ## end sub _init_cascm
291              
292             #######################
293             1;
294              
295             __END__