File Coverage

lib/Rex/Commands/Box.pm
Criterion Covered Total %
statement 35 172 20.3
branch 1 46 2.1
condition n/a
subroutine 12 21 57.1
pod 5 6 83.3
total 53 245 21.6


line stmt bran cond sub pod time code
1             #
2             # (c) Jan Gehring
3             #
4              
5             =head1 NAME
6              
7             Rex::Commands::Box - Functions / Class to manage Virtual Machines
8              
9             =head1 DESCRIPTION
10              
11             This is a Module to manage Virtual Machines or Cloud Instances in a simple way. Currently it supports Amazon, KVM and VirtualBox.
12              
13             Version <= 1.0: All these functions will not be reported.
14              
15             =head1 SYNOPSIS
16              
17             use Rex::Commands::Box;
18              
19             set box => "VBox";
20              
21             group all_my_boxes => map { get_box($_->{name})->{ip} } list_boxes;
22              
23             task mytask => sub {
24              
25             box {
26             my ($box) = @_;
27             $box->name("boxname");
28             $box->url("http://box.rexify.org/box/base-image.box");
29              
30             $box->network(1 => {
31             type => "nat",
32             });
33              
34             $box->network(1 => {
35             type => "bridged",
36             bridge => "eth0",
37             });
38              
39             $box->forward_port(ssh => [2222, 22]);
40              
41             $box->share_folder(myhome => "/home/myuser");
42              
43             $box->auth(
44             user => "root",
45             password => "box",
46             );
47              
48             $box->setup(qw/task_to_customize_box/);
49              
50             };
51              
52             };
53              
54             =head1 EXPORTED FUNCTIONS
55              
56             =cut
57              
58             package Rex::Commands::Box;
59              
60 1     1   14 use v5.12.5;
  1         3  
61 1     1   5 use warnings;
  1         3  
  1         48  
62              
63             our $VERSION = '1.14.3'; # VERSION
64              
65 1     1   5 use YAML;
  1         2  
  1         73  
66 1     1   6 use Data::Dumper;
  1         8  
  1         48  
67              
68 1     1   23 use Rex::Commands -no => [qw/auth/];
  1         4  
  1         22  
69 1     1   7 use Rex::Commands::Fs;
  1         2  
  1         7  
70 1     1   6 use Rex::Commands::Virtualization;
  1         7  
  1         10  
71 1     1   7 use Rex::Commands::Gather;
  1         2  
  1         9  
72              
73             $|++;
74              
75             ################################################################################
76             # BEGIN of class methods
77             ################################################################################
78              
79             require Exporter;
80 1     1   6 use base qw(Exporter);
  1         3  
  1         66  
81 1     1   6 use vars qw(@EXPORT %vm_infos $VM_STRUCT);
  1         2  
  1         73  
82 1     1   12 use Rex::Box;
  1         2  
  1         21  
83              
84             #@EXPORT = qw(box $box);
85             @EXPORT = qw(box list_boxes get_box boxes);
86              
87             Rex::Config->register_set_handler(
88             "box",
89             sub {
90             my ( $type, @data ) = @_;
91             Rex::Config->set( "box_type", $type );
92              
93             if ( ref( $data[0] ) ) {
94             Rex::Config->set( "box_options", $data[0] );
95             }
96             else {
97             Rex::Config->set( "box_options", {@data} );
98             }
99             }
100             );
101              
102             =head2 new(name => $box_name)
103              
104             Constructor if used in OO mode.
105              
106             my $box = Rex::Commands::Box->new(name => "box_name");
107              
108             =cut
109              
110             sub new {
111 0     0 1 0 my $class = shift;
112 0         0 return Rex::Box->create(@_);
113             }
114              
115             =head2 box(sub {})
116              
117             With this function you can create a new Rex/Box. The first parameter of this function is the Box object. With this object you can define your box.
118              
119             box {
120             my ($box) = @_;
121             $box->name("boxname");
122             $box->url("http://box.rexify.org/box/base-image.box");
123              
124             $box->network(1 => {
125             type => "nat",
126             });
127              
128             $box->network(1 => {
129             type => "bridged",
130             bridge => "eth0",
131             });
132              
133             $box->forward_port(ssh => [2222, 22]);
134              
135             $box->share_folder(myhome => "/home/myuser");
136              
137             $box->auth(
138             user => "root",
139             password => "box",
140             );
141              
142             $box->setup(qw/task_to_customize_box/);
143             };
144              
145              
146             =cut
147              
148             sub box(&) {
149 0     0 1 0 my $code = shift;
150              
151             #### too much black magic...
152             #my ($caller_box) = do {
153             # my $pkg = caller();
154             # no strict 'refs';
155             # \*{ $pkg . "::box" };
156             #};
157              
158 0         0 my $self = Rex::Box->create;
159              
160             #local( *$caller_box );
161             #*$caller_box = \$self;
162              
163 0         0 $code->($self);
164              
165             #*$caller_box = \{}; # undef $box
166              
167 0         0 $self->import_vm();
168              
169 0         0 $self->provision_vm();
170              
171 0         0 return $self->ip;
172             }
173              
174             =head2 list_boxes
175              
176             This function returns an array of hashes containing all information that can be gathered from the hypervisor about the Rex/Box. This function doesn't start a Rex/Box.
177              
178             use Data::Dumper;
179             task "get_infos", sub {
180             my @all_boxes = list_boxes;
181             print Dumper(\@all_boxes);
182             };
183              
184             =cut
185              
186             sub list_boxes {
187 0     0 1 0 my $box = Rex::Box->create;
188 0         0 my @ret = $box->list_boxes;
189              
190             my $ref = LOCAL {
191 0 0   0   0 if ( -f ".box.cache" ) {
192 0         0 my $yaml_str = eval { local ( @ARGV, $/ ) = (".box.cache"); <>; };
  0         0  
  0         0  
193 0         0 $yaml_str .= "\n";
194 0         0 my $yaml_ref = Load($yaml_str);
195              
196 0         0 for my $box ( keys %{$yaml_ref} ) {
  0         0  
197 0         0 my ($found_box) = grep { $_->{name} eq $box } @ret;
  0         0  
198 0 0       0 if ( !$found_box ) {
199 0         0 $yaml_ref->{$box} = undef;
200 0         0 delete $yaml_ref->{$box};
201             }
202             }
203              
204 0 0       0 open( my $fh, ">", ".box.cache" ) or die($!);
205 0         0 print $fh Dump($yaml_ref);
206 0         0 close($fh);
207             }
208              
209 0 0       0 if (wantarray) {
210 0         0 return @ret;
211             }
212              
213 0         0 return \@ret;
214 0         0 };
215              
216 0         0 return @{$ref};
  0         0  
217             }
218              
219             =head2 get_box($box_name)
220              
221             This function tries to gather all information of a Rex/Box. This function also starts a Rex/Box to gather all information of the running system.
222              
223             use Data::Dumper;
224             task "get_box_info", sub {
225             my $data = get_box($box_name);
226             print Dumper($data);
227             };
228              
229             =cut
230              
231             sub get_box {
232 0     0 1 0 my ($box_name) = @_;
233              
234 0         0 my $box = Rex::Box->create( name => $box_name );
235 0         0 $box->info;
236              
237 0 0       0 if ( $box->status eq "stopped" ) {
238 0         0 $box->start;
239 0         0 $box->wait_for_ssh;
240             }
241              
242 0         0 my $box_ip = $box->ip;
243 0         0 my $box_info = $box->info;
244              
245             return LOCAL {
246              
247 0 0   0   0 if ( -f ".box.cache" ) {
248 0         0 Rex::Logger::debug("Loading box information of cache file: .box.cache.");
249 0         0 my $yaml_str = eval { local ( @ARGV, $/ ) = (".box.cache"); <>; };
  0         0  
  0         0  
250 0         0 $yaml_str .= "\n";
251 0         0 my $yaml_ref = Load($yaml_str);
252 0         0 %vm_infos = %{$yaml_ref};
  0         0  
253             }
254              
255 0 0       0 if ( exists $vm_infos{$box_name} ) {
256 0         0 return $vm_infos{$box_name};
257             }
258              
259 0         0 my $pid = fork;
260 0 0       0 if ( $pid == 0 ) {
261 0         0 print
262             "Gathering system information from $box_name.\nThis may take a while..";
263 0         0 while (1) {
264 0         0 print ".";
265 0         0 sleep 1;
266             }
267              
268 0         0 CORE::exit;
269             }
270              
271 0         0 my $old_q = $::QUIET;
272 0         0 $::QUIET = 1;
273              
274             eval {
275 0         0 $vm_infos{$box_name} = run_task "Commands:Box:get_sys_info",
276             on => $box_ip;
277 0 0       0 } or do {
278 0         0 $::QUIET = $old_q;
279 0         0 print STDERR "\n";
280 0         0 Rex::Logger::info(
281             "There was an error connecting to your Box. Please verify the login credentials.\nERROR: $@\n",
282             "warn"
283             );
284 0         0 Rex::Logger::debug(
285             "You have to define login credentials before calling get_box()");
286              
287             # cleanup
288 0         0 kill 9, $pid;
289 0         0 CORE::exit(1);
290             };
291 0         0 $::QUIET = $old_q;
292              
293 0         0 for my $key ( keys %{$box_info} ) {
  0         0  
294 0         0 $vm_infos{$box_name}->{$key} = $box_info->{$key};
295             }
296              
297 0 0       0 open( my $fh, ">", ".box.cache" ) or die($!);
298 0         0 print $fh Dump( \%vm_infos );
299 0         0 close($fh);
300              
301 0         0 kill 9, $pid;
302 0         0 print "\n";
303              
304 0         0 return $vm_infos{$box_name};
305 0         0 };
306              
307             }
308              
309             =head2 boxes($action, @data)
310              
311             With this function you can control your boxes. Currently there are 3 actions.
312              
313             =over 4
314              
315             =item init
316              
317             This action can only be used if you're using a YAML file to describe your Rex/Boxes.
318              
319             task "prepare_boxes", sub {
320             boxes "init";
321             };
322              
323             =item start
324              
325             This action start one or more Rex/Boxes.
326              
327             task "start_boxes", sub {
328             boxes "start", "box1", "box2";
329             };
330              
331             =item stop
332              
333             This action stop one or more Rex/Boxes.
334              
335             task "stop_boxes", sub {
336             boxes "stop", "box1", "box2";
337             };
338              
339             =back
340              
341             =cut
342              
343             sub boxes {
344 0     0 1 0 my ( $action, @data ) = @_;
345              
346 0 0       0 if ( substr( $action, 0, 1 ) eq "-" ) {
347 0         0 $action = substr( $action, 1 );
348             }
349              
350 0 0       0 if ( $action eq "init" ) {
351              
352 0 0       0 if ( -f ".box.cache" ) {
353 0         0 unlink ".box.cache";
354             }
355              
356 0         0 my $yaml_ref = $VM_STRUCT;
357              
358 0         0 my @vms;
359              
360 0 0       0 if ( ref $yaml_ref->{vms} eq "HASH" ) {
361 0         0 for my $vm ( keys %{ $yaml_ref->{vms} } ) {
  0         0  
362             push(
363             @vms,
364             {
365             name => $vm,
366 0         0 %{ $yaml_ref->{vms}->{$vm} }
  0         0  
367             }
368             );
369             }
370             }
371             else {
372 0         0 @vms = @{ $yaml_ref->{vms} };
  0         0  
373             }
374              
375 0         0 my $box_vms = {};
376 0         0 for my $vm_ref (@vms) {
377 0         0 my $vm = $vm_ref->{name};
378             box {
379 0     0   0 my ($box) = @_;
380              
381 0         0 $box->name($vm);
382              
383 0         0 for my $key ( keys %{$vm_ref} ) {
  0         0  
384 0 0       0 if ( ref( $vm_ref->{$key} ) eq "HASH" ) {
    0          
385 0         0 $box->$key( %{ $vm_ref->{$key} } );
  0         0  
386             }
387             elsif ( ref( $vm_ref->{$key} ) eq "ARRAY" ) {
388 0         0 $box->$key( @{ $vm_ref->{$key} } );
  0         0  
389             }
390             else {
391 0         0 $box->$key( $vm_ref->{$key} );
392             }
393             }
394              
395 0         0 $box_vms->{$vm} = $box;
396 0         0 };
397             }
398              
399 0         0 return $box_vms;
400             }
401              
402 0 0       0 if ( $action eq "stop" ) {
403 0         0 for my $box (@data) {
404 0         0 my $o = Rex::Commands::Box->new( name => $box );
405 0         0 $o->stop;
406             }
407             }
408              
409 0 0       0 if ( $action eq "start" ) {
410 0         0 for my $box (@data) {
411 0         0 my $o = Rex::Commands::Box->new( name => $box );
412 0         0 $o->start;
413             }
414             }
415              
416             }
417              
418             task 'get_sys_info', sub {
419             return { get_system_information() };
420             }, { dont_register => 1, exit_on_connect_fail => 0 };
421              
422             sub load_init_file {
423 0     0 0 0 my ( $class, $file ) = @_;
424              
425 0 0       0 if ( !-f $file ) {
426 0         0 die("Error: Wrong configuration file: $file.");
427             }
428              
429 0         0 my $yaml_str = eval { local ( @ARGV, $/ ) = ($file); <>; };
  0         0  
  0         0  
430 0         0 $yaml_str .= "\n";
431              
432 0         0 my $yaml_ref = Load($yaml_str);
433              
434 0 0       0 if ( !exists $yaml_ref->{type} ) {
435 0         0 die("You have to define a type.");
436             }
437              
438 0         0 my $type = ucfirst $yaml_ref->{type};
439 0         0 set box_type => $type;
440              
441             # set special box options, like amazon out
442 0 0       0 if ( exists $yaml_ref->{"\L$type"} ) {
    0          
443 0         0 set box_options => $yaml_ref->{"\L$type"};
444             }
445             elsif ( exists $yaml_ref->{$type} ) {
446 0         0 set box_options => $yaml_ref->{$type};
447             }
448              
449 0         0 $VM_STRUCT = $yaml_ref;
450             }
451              
452             sub import {
453 3     3   588 my ( $class, %option ) = @_;
454              
455 3 50       27 if ( $option{init_file} ) {
456 0         0 my $file = $option{init_file};
457 0         0 $class->load_init_file($file);
458 0         0 @_ = ($class);
459             }
460              
461 3         646 __PACKAGE__->export_to_level( 1, @_ );
462             }
463              
464             1;