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

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