source: repository/lib/Metabrik/System/Virtualbox.pm

Last change on this file was 912:d7c4ded19eca, checked in by GomoR <gomor@…>, 7 months ago
  • update: lookup::countrycode: make search case insensitive
  • new: netword::address: ip*_reserved_subnets, is_ip*_reserved Commands
  • update: system::virtualbox: check for VBoxManage return codes on Commands
File size: 11.2 KB
Line 
1#
2# $Id$
3#
4# system::virtualbox Brik
5#
6package Metabrik::System::Virtualbox;
7use strict;
8use warnings;
9
10use base qw(Metabrik::Shell::Command Metabrik::System::Package);
11
12sub brik_properties {
13   return {
14      revision => '$Revision$',
15      tags => [ qw(unstable) ],
16      author => 'GomoR <GomoR[at]metabrik.org>',
17      license => 'http://opensource.org/licenses/BSD-3-Clause',
18      attributes => {
19         datadir => [ qw(datadir) ],
20         capture_mode => [ qw(0|1) ],
21         type => [ qw(gui|sdl|headless) ],
22      },
23      attributes_default => {
24         capture_mode => 1,
25         type => 'gui',
26      },
27      commands => {
28         install => [ ], # Inherited
29         command => [ qw(command) ],
30         list => [ ],
31         start => [ qw(name type|OPTIONAL) ],
32         restore => [ qw(name type|OPTIONAL) ], # Alias for start
33         stop => [ qw(name) ],
34         save => [ qw(name) ],
35         pause => [ qw(name) ],
36         resume => [ qw(resume) ],
37         snapshot_list => [ qw(name) ],
38         snapshot_live => [ qw(name snapshot_name description|OPTIONAL) ],
39         snapshot_delete => [ qw(name snapshot_name) ],
40         snapshot_restore => [ qw(name snapshot_name) ],
41         screenshot => [ qw(name output.png|OPTIONAL) ],
42         dumpguestcore => [ qw(name output.elf|OPTIONAL) ],
43         dumpvmcore => [ qw(name output.elf|OPTIONAL) ],
44         extract_memdump_from_dumpguestcore => [ qw(input output.vol|OPTIONAL) ],
45         restart => [ qw(name type|OPTIONAL) ],
46         info => [ qw(name) ],
47         is_started => [ qw(name) ],
48         is_stopped => [ qw(name) ],
49         get_current_snapshot_id => [ qw(name) ],
50      },
51      require_modules => {
52         'Data::Dumper' => [ ],
53         'Metabrik::File::Raw' => [ ],
54         'Metabrik::File::Read' => [ ],
55         'Metabrik::File::Readelf' => [ ],
56         'Metabrik::System::File' => [ ],
57      },
58      require_binaries => {
59         vboxmanage => [ ],
60      },
61      need_packages => {
62         ubuntu => [ qw(virtualbox) ],
63         debian => [ qw(virtualbox) ],
64      },
65   };
66}
67
68sub command {
69   my $self = shift;
70   my ($command) = @_;
71
72   $self->brik_help_run_undef_arg('command', $command) or return;
73
74   return $self->execute("vboxmanage $command");
75}
76
77sub list {
78   my $self = shift;
79
80   my %vms = ();
81   my $lines = $self->command('list vms') or return;
82   for my $line (@$lines) {
83      my ($name, $uuid) = $line =~ m/^\s*"([^"]+)"\s+{([^}]+)}\s*$/;
84      $vms{$uuid} = { uuid => $uuid, name => $name };
85   }
86
87   return \%vms;
88}
89
90sub start {
91   my $self = shift;
92   my ($name, $type) = @_;
93
94   $type ||= $self->type;
95   $self->brik_help_run_undef_arg('start', $name) or return;
96   $self->brik_help_run_undef_arg('start', $type) or return;
97
98   if ($self->is_started($name)) {
99      return $self->log->info("start: VM with name [$name] already started");
100   }
101
102   return $self->command("startvm \"$name\" --type $type");
103}
104
105sub restore {
106   my $self = shift;
107
108   return $self->start(@_);
109}
110
111sub stop {
112   my $self = shift;
113   my ($name) = @_;
114
115   $self->brik_help_run_undef_arg('stop', $name) or return;
116
117   if ($self->is_stopped($name)) {
118      return $self->log->info("start: VM with name [$name] already stopped");
119   }
120
121   return $self->command("controlvm \"$name\" poweroff");
122}
123
124sub save {
125   my $self = shift;
126   my ($name) = @_;
127
128   $self->brik_help_run_undef_arg('save', $name) or return;
129
130   return $self->command("controlvm \"$name\" savestate");
131}
132
133sub pause {
134   my $self = shift;
135   my ($name) = @_;
136
137   $self->brik_help_run_undef_arg('pause', $name) or return;
138
139   return $self->command("controlvm \"$name\" pause");
140}
141
142sub resume {
143   my $self = shift;
144   my ($name) = @_;
145
146   $self->brik_help_run_undef_arg('resume', $name) or return;
147
148   return $self->command("controlvm \"$name\" resume");
149}
150
151sub snapshot_list {
152   my $self = shift;
153   my ($name) = @_;
154
155   $self->brik_help_run_undef_arg('snapshot_list', $name) or return;
156
157   my $lines = $self->command("snapshot \"$name\" list");
158
159   if ($self->log->level > 1) {
160      print Dumper($lines)."\n";
161   }
162
163   # No snapshot: error code 256
164   if ($? != 0) {
165      return $self->log->error("snapshot_list: no snapshot found?");
166   }
167
168   my @list = ();
169   for my $line (@$lines) {
170      if ($line =~ m{^\s*Name:}) {
171         my ($descr, $id) = $line =~ m{^\s*Name:\s+([^\(]+)\(UUID:\s+([^\)]+)\)};
172         if (defined($descr) && defined($id)) {
173            my $current = 0;
174            if ($line =~ m{\*$}) {
175               $current = 1;
176            }
177            $descr =~ s{\s*$}{};
178            push @list, {
179               name => $descr,
180               uuid => $id,
181               current => $current,
182            };
183         }
184      }
185   }
186
187   return \@list;
188}
189
190sub snapshot_live {
191   my $self = shift;
192   my ($name, $snapshot_name, $description) = @_;
193
194   $description ||= 'snapshot';
195   $self->brik_help_run_undef_arg('snapshot_live', $name) or return;
196   $self->brik_help_run_undef_arg('snapshot_live', $snapshot_name) or return;
197
198   my $lines = $self->command("snapshot \"$name\" take \"$snapshot_name\" --description \"$description\" --live");
199
200   if ($self->log->level > 1) {
201      print Dumper($lines)."\n";
202   }
203
204   if ($? != 0) {
205      return $self->log->error("snapshot_live: snapshot failed");
206   }
207
208   return $self->log->info("snapshot_live: snapshot complete");
209}
210
211sub snapshot_delete {
212   my $self = shift;
213   my ($name, $snapshot_name) = @_;
214
215   $self->brik_help_run_undef_arg('snapshot_delete', $name) or return;
216   $self->brik_help_run_undef_arg('snapshot_delete', $snapshot_name) or return;
217
218   my $lines = $self->command("snapshot \"$name\" delete \"$snapshot_name\"");
219
220   # code 256: This machine does not have any snapshots
221   if ($? != 0) {
222      return $self->log->error("snapshot_delete: unable to delete snapshot [$snapshot_name] for vm [$name]");
223   }
224
225   return $self->log->info("snapshot_delete: snapshot [$snapshot_name] deleted successfully for vm [$name]");
226}
227
228sub snapshot_restore {
229   my $self = shift;
230   my ($name, $snapshot_name) = @_;
231
232   $self->brik_help_run_undef_arg('snapshot_restore', $name) or return;
233   $self->brik_help_run_undef_arg('snapshot_restore', $snapshot_name) or return;
234
235   return $self->command("snapshot \"$name\" restore \"$snapshot_name\"");
236}
237
238sub screenshot {
239   my $self = shift;
240   my ($name, $output) = @_;
241
242   $output ||= $self->datadir."/screenshot.png";
243   $self->brik_help_run_undef_arg('screenshot', $name) or return;
244
245   $self->command("controlvm \"$name\" screenshotpng \"$output\"") or return;
246
247   return $output;
248}
249
250#
251# Dump guestcore
252#
253sub dumpguestcore {
254   my $self = shift;
255   my ($name, $output) = @_;
256
257   $output ||= $self->datadir.'/output.elf';
258   $self->brik_help_run_undef_arg('dumpguestcore', $name) or return;
259
260   if (-f $output) {
261      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
262      $sf->remove($output) or return;
263   }
264
265   $self->command("debugvm \"$name\" dumpguestcore --filename \"$output\"") or return;
266
267   return $output;
268}
269
270#
271# Dump vmcore, same as dump guestcore but for newer versions of VirtualBox which renamed
272# the function
273#
274sub dumpvmcore {
275   my $self = shift;
276   my ($name, $output) = @_;
277
278   $output ||= $self->datadir.'/output.elf';
279   $self->brik_help_run_undef_arg('dumpvmcore', $name) or return;
280
281   if (-f $output) {
282      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
283      $sf->remove($output) or return;
284   }
285
286   $self->command("debugvm \"$name\" dumpvmcore --filename \"$output\"") or return;
287
288   return $output;
289}
290
291#
292# By taking information from:
293# http://wiki.yobi.be/wiki/RAM_analysis#RAM_dump_with_VirtualBox:_via_ELF64_coredump
294#
295sub extract_memdump_from_dumpguestcore {
296   my $self = shift;
297   my ($input, $output) = @_;
298
299   $output ||= $self->datadir.'/output.vol';
300   $self->brik_help_run_undef_arg('extract_memdump_from_dumpguestcore', $input) or return;
301
302   my $fraw = Metabrik::File::Raw->new_from_brik_init($self) or return;
303   my $fread = Metabrik::File::Read->new_from_brik_init($self) or return;
304   my $felf = Metabrik::File::Readelf->new_from_brik_init($self) or return;
305
306   my $headers = $felf->program_headers($input) or return;
307
308   my $offset = 0;
309   my $size = 0;
310   for my $section (@{$headers->{sections}}) {
311      if ($section->{type} eq 'LOAD') {
312         $offset = hex($section->{offset});
313         $size = hex($section->{filesiz});
314         last;
315      }
316   }
317   if (! $offset || ! $size) {
318      return $self->log->error("extract_memdump_from_dumpguestcore: unable to find memdump");
319   }
320
321   $self->log->verbose("extract_memdump_from_dumpguestcore: offset[$offset] size[$size]");
322
323   $fread->encoding('ascii');  # Raw mode
324   my $fdin = $fread->open($input) or return;
325   $fread->seek($offset) or return;
326
327   if (-f $output) {
328      my $sf = Metabrik::System::File->new_from_brik_init($self) or return;
329      $sf->remove($output) or return;
330   }
331
332   my $written = 0;
333   my $fdout = $fraw->open($output) or return;
334   while (<$fdin>) {
335      my $this = length($_);
336      if (($written + $this) <= $size) {
337         print $fdout $_;
338         $written += $this;
339      }
340      else {
341         my $rest = $size - $written;
342         if ($rest < 0) {
343            $self->log->warning("extract_memdump_from_dumpguestcore: error while reading input");
344            last;
345         }
346         my $tail = substr($_, 0, $rest);
347         print $fdout $tail;
348         last;
349      }
350   }
351   $fraw->close;
352   $fread->close;
353
354   return $output;
355}
356
357sub restart {
358   my $self = shift;
359   my ($name, $type) = @_;
360
361   $self->brik_help_run_undef_arg('restart', $name) or return;
362
363   $self->stop($name) or return;
364   sleep(2);
365   return $self->start($name, $type);
366}
367
368sub info {
369   my $self = shift;
370   my ($name) = @_;
371
372   $self->brik_help_run_undef_arg('info', $name) or return;
373
374   my $lines = $self->command("showvminfo \"$name\"") or return;
375
376   my $info = {};
377   if (@$lines > 0) {
378      for my $line (@$lines) {
379         my @t = split(/:/, $line, 2);
380         my $k = $t[0];
381         my $v = $t[1];
382         next unless defined($v);
383         $k =~ s{^\s*}{};
384         $k =~ s{\s*$}{};
385         $v =~ s{^\s*}{};
386         $v =~ s{\s*$}{};
387         if (length($k) && length($v)) {
388            $k =~ s{ }{_}g;
389            $k =~ s{(\(|\))}{}g;
390            $info->{lc($k)} = $v;
391         }
392      }
393   }
394
395   return $info;
396
397}
398
399sub is_started {
400   my $self = shift;
401   my ($name) = @_;
402
403   $self->brik_help_run_undef_arg('is_started', $name) or return;
404
405   my $info = $self->info($name) or return;
406   my $state = $info->{state} || 'undef';
407   if ($state =~ m{running}) {
408      return 1;
409   }
410
411   return 0;
412}
413
414sub is_stopped {
415   my $self = shift;
416   my ($name) = @_;
417
418   $self->brik_help_run_undef_arg('is_stopped', $name) or return;
419
420   return ! $self->is_started($name);
421}
422
423sub get_current_snapshot_id {
424   my $self = shift;
425   my ($name) = @_;
426
427   $self->brik_help_run_undef_arg('get_current_snapshot_id', $name) or return;
428
429   my $list = $self->snapshot_list($name) or return;
430
431   for my $this (@$list) {
432      if ($this->{current}) {
433         return $this->{uuid};
434      }
435   }
436
437   return 0;
438}
439
4401;
441
442__END__
443
444=head1 NAME
445
446Metabrik::System::Virtualbox - system::virtualbox Brik
447
448=head1 COPYRIGHT AND LICENSE
449
450Copyright (c) 2014-2017, Patrice E<lt>GomoRE<gt> Auffret
451
452You may distribute this module under the terms of The BSD 3-Clause License.
453See LICENSE file in the source distribution archive.
454
455=head1 AUTHOR
456
457Patrice E<lt>GomoRE<gt> Auffret
458
459=cut
Note: See TracBrowser for help on using the repository browser.