File Coverage

blib/lib/Metabrik/System/Virtualbox.pm
Criterion Covered Total %
statement 9 217 4.1
branch 0 144 0.0
condition 0 28 0.0
subroutine 3 27 11.1
pod 1 24 4.1
total 13 440 2.9


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