KVM.pm 66.9 KB
Newer Older
1
2
3
4
5
package Ravada::Domain::KVM;

use warnings;
use strict;

6
7
8
9
10
11
=head2 NAME

Ravada::Domain::KVM - KVM Virtual Machines library for Ravada

=cut

12
13
14
15
use Carp qw(cluck confess croak);
use Data::Dumper;
use File::Copy;
use File::Path qw(make_path);
Francesc Guasch's avatar
Francesc Guasch committed
16
use Hash::Util qw(lock_keys lock_hash);
17
use IPC::Run3 qw(run3);
18
use MIME::Base64;
19
20
use Moose;
use Sys::Virt::Stream;
JanFontanet's avatar
JanFontanet committed
21
use Sys::Virt::Domain;
22
use Sys::Virt;
23
24
use XML::LibXML;

25
26
27
no warnings "experimental::signatures";
use feature qw(signatures);

Francesc Guasch's avatar
Francesc Guasch committed
28
extends 'Ravada::Front::Domain::KVM';
29
30
31
32
33
with 'Ravada::Domain';

has 'domain' => (
      is => 'rw'
    ,isa => 'Sys::Virt::Domain'
34
    ,required => 0
35
36
37
);

has '_vm' => (
38
    is => 'rw'
39
40
41
42
    ,isa => 'Ravada::VM::KVM'
    ,required => 0
);

Francesc Guasch's avatar
Francesc Guasch committed
43
44
45
46
47
48
has readonly => (
    isa => 'Int'
    ,is => 'rw'
    ,default => 0
);

49
50
51
##################################################
#
our $TIMEOUT_SHUTDOWN = 60;
Roberto P. Rubio's avatar
Roberto P. Rubio committed
52
our $TIMEOUT_REBOOT = 60;
53
54
55
56
57
58
our $OUT;

our %SET_DRIVER_SUB = (
    network => \&_set_driver_network
     ,sound => \&_set_driver_sound
     ,video => \&_set_driver_video
59
60
61
62
63
     ,image => \&_set_driver_image
     ,jpeg => \&_set_driver_jpeg
     ,zlib => \&_set_driver_zlib
     ,playback => \&_set_driver_playback
     ,streaming => \&_set_driver_streaming
Francesc Guasch's avatar
Francesc Guasch committed
64
     ,disk => \&_set_driver_disk
65
66
);

67
68
our %GET_CONTROLLER_SUB = (
    usb => \&_get_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
69
    ,disk => \&_get_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
70
    ,network => \&_get_controller_network
71
72
73
    );
our %SET_CONTROLLER_SUB = (
    usb => \&_set_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
74
    ,disk => \&_set_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
75
    ,network => \&_set_controller_network
76
77
78
    );
our %REMOVE_CONTROLLER_SUB = (
    usb => \&_remove_controller_usb
Francesc Guasch's avatar
Francesc Guasch committed
79
    ,disk => \&_remove_controller_disk
Francesc Guasch's avatar
Francesc Guasch committed
80
    ,network => \&_remove_controller_network
81
    );
Francesc Guasch's avatar
Francesc Guasch committed
82
83
84

our %CHANGE_HARDWARE_SUB = (
    disk => \&_change_hardware_disk
85
86
    ,vcpus => \&_change_hardware_vcpus
    ,memory => \&_change_hardware_memory
Francesc Guasch's avatar
Francesc Guasch committed
87
    ,network => \&_change_hardware_network
Francesc Guasch's avatar
Francesc Guasch committed
88
);
89
90
##################################################

Francesc Guasch's avatar
Francesc Guasch committed
91
92
93
94
95
sub BUILD {
    my ($self, $arg) = @_;
    $self->readonly( $arg->{readonly} or 0);
}

96
97
98
99
100
101
102
103
104

=head2 name

Returns the name of the domain

=cut

sub name {
    my $self = shift;
105

106
    return $self->domain->get_name if $self->domain;
107
108

    confess "ERROR: Unknown domain name";
109
110
111
112
113
114
115
116
117
118
119
120
121
122
}

=head2 list_disks

Returns a list of the disks used by the virtual machine. CDRoms are not included

  my@ disks = $domain->list_disks();

=cut

sub list_disks {
    my $self = shift;
    my @disks = ();

123
    my $doc = XML::LibXML->load_xml(string => $self->xml_description);
124
125
126
127
128
129
130

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';

        for my $child ($disk->childNodes) {
            if ($child->nodeName eq 'source') {
                my $file = $child->getAttribute('file');
Francesc Guasch's avatar
Francesc Guasch committed
131
                next if $file =~ /\.iso$/;
132
133
134
135
136
137
138
                push @disks,($file);
            }
        }
    }
    return @disks;
}

Francesc Guasch's avatar
Francesc Guasch committed
139
sub xml_description($self, $inactive=0) {
140
141
142
    return $self->_data_extra('xml')
        if ($self->is_removed || !$self->domain )
            && $self->is_known;
143

144
    confess "ERROR: KVM domain not available ".$self->is_known   if !$self->domain;
145
146
    my $xml;
    eval {
Francesc Guasch's avatar
Francesc Guasch committed
147
148
149
150
151
152
153
154
155
        my @flags;
        @flags = ( Sys::Virt::Domain::XML_INACTIVE ) if $inactive;

        $xml = $self->domain->get_xml_description(@flags);
        $self->_data_extra('xml', $xml) if $self->is_known
                                        && ( $inactive
                                                || !$self->_data_extra('xml')
                                                || !$self->is_active
                                        );
156
157
158
159
160
161
162
163
    };
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
    if ( $@ ) {
        return $self->_data_extra('xml');
    }
    return $xml;
}

Francesc Guasch's avatar
Francesc Guasch committed
164
165
166
167
sub xml_description_inactive($self) {
    return $self->xml_description(1);
}

168
169
170
171
172
173
174
175
176
177
178
179
180
181
=head2 remove_disks

Remove the volume files of the domain

=cut

sub remove_disks {
    my $self = shift;

    my $removed = 0;

    my $id;
    eval { $id = $self->id };
    return if $@ && $@ =~ /No DB info/i;
182
    confess $@ if $@;
183
184

    $self->_vm->connect();
Francesc Guasch's avatar
Francesc Guasch committed
185
    for my $file ($self->list_disks( device => 'disk')) {
186
        if (! $self->_vm->file_exists($file) ) {
187
188
            next;
        }
189
        eval {
190
        $self->_vol_remove($file);
Francesc Guasch's avatar
Francesc Guasch committed
191
        $self->_vol_remove($file);
192
193
        };
        warn "Error: removing $file $@" if $@;
194
195
196
#        if ( -e $file ) {
#            unlink $file or die "$! $file";
#        }
197
198
199
        $removed++;

    }
200
    return if $self->is_removed;
201
202
203
204
205
206
    warn "WARNING: No disk files removed for ".$self->domain->get_name."\n"
            .Dumper([$self->list_disks])
        if !$removed && $0 !~ /\.t$/;

}

207
208
209
210
211
212
213
214
215
216
=head2 pre_remove_domain

Cleanup operations executed before removing this domain

    $self->pre_remove_domain

=cut

sub pre_remove_domain {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
217
    return if $self->is_removed;
218
    $self->xml_description();
219
220
221
    $self->domain->managed_save_remove()    if $self->domain->has_managed_save_image;
}

222
223
224
225
226
sub _vol_remove {
    my $self = shift;
    my $file = shift;
    my $warning = shift;

227
228
    confess "Error: I won't remove an iso file " if $file =~ /\.iso$/i;

229
230
    my $name;
    ($name) = $file =~ m{.*/(.*)}   if $file =~ m{/};
231

232
233
    my $removed = 0;
    for my $pool ( $self->_vm->vm->list_storage_pools ) {
234
        _pool_refresh($pool);
235
236
        my $vol;
        eval { $vol = $pool->get_volume_by_name($name) };
237
        if (! $vol ) {
238
            warn "VOLUME $name not found in $pool \n".($@ or '')
239
                if $@ !~ /libvirt error code: 50,/i;
240
241
            next;
        }
242
243
244
245
246
247
248
        for ( ;; ) {
            eval { $vol->delete() };
            last if !$@;
            sleep 1;
        }
        eval { $pool->refresh };
        warn $@ if $@;
249
250
251
252
    }
    return 1;
}

Francesc Guasch's avatar
Francesc Guasch committed
253
254
255
256
sub remove_volume {
    return _vol_remove(@_);
}

257
258
259
260
261
262
263
264
265
266
=head2 remove

Removes this domain. It removes also the disk drives and base images.

=cut

sub remove {
    my $self = shift;
    my $user = shift;

267
    my @volumes;
268
    if (!$self->is_removed ) {
269
270
271
272
273
274
275
276
       my @vols_info;
       for ( 1 .. 10 ) {
           eval { @vols_info = $self->list_volumes_info };
           last if !$@;
           warn "WARNING: remove, volumes info: $@";
           sleep 1;
       }
       for my $vol ( @vols_info ) {
Francesc Guasch's avatar
Francesc Guasch committed
277
278
279
280
            push @volumes,($vol->{file})
                if exists $vol->{file}
                   && exists $vol->{device}
                   && $vol->{device} eq 'file';
Francesc Guasch's avatar
Francesc Guasch committed
281
        }
282
283
    }

Francesc Guasch's avatar
Francesc Guasch committed
284
    if (!$self->is_removed && $self->domain && $self->domain->is_active) {
285
286
        eval { $self->_do_force_shutdown() };
        warn $@ if $@;
287
288
    }

Francesc Guasch's avatar
Francesc Guasch committed
289
    eval { $self->domain->undefine()    if $self->domain && !$self->is_removed };
290
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
291

Francesc Guasch's avatar
Francesc Guasch committed
292
    eval { $self->remove_disks() if $self->is_known };
293
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
294

295
    for my $file ( @volumes ) {
296
297
        eval { $self->remove_volume($file) };
        warn $@ if $@;
298
299
    }

300
    eval { $self->_remove_file_image() };
301
        warn $@ if $@;
302
    confess $@ if $@ && $@ !~ /libvirt error code: 42/;
303
304
305
306
307
#    warn "WARNING: Problem removing file image for ".$self->name." : $@" if $@ && $0 !~ /\.t$/;

#    warn "WARNING: Problem removing ".$self->file_base_img." for ".$self->name
#            ." , I will try again later : $@" if $@;

308
309
    # do a post remove but pass the remove flag = 1 ( it is 0 by default )
    $self->_post_remove_base_domain(1) if $self->is_base();
310
311
312
313
314
315
316

}


sub _remove_file_image {
    my $self = shift;
    for my $file ( $self->list_files_base ) {
317
        next if $file && $file =~ /\.iso$/i;
318
319
320
321
322
323

        next if !$file || ! -e $file;

        chmod 0770, $file or die "$! chmodding $file";
        chown $<,$(,$file    or die "$! chowning $file";
        eval { $self->_vol_remove($file,1) };
324
        warn $@ if $@;
325
326
327
328
329
330
331
332
333
334
335
336
337
338

        if ( -e $file ) {
            eval {
                unlink $file or die "$! $file" ;
                #TODO: do a refresh of all the storage pools in the VM if anything removed
                $self->_vm->storage_pool->refresh();
            };
            warn $@ if $@;
        }
        next if ! -e $file;
        warn $@ if $@;
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
339
sub _disk_device($self, $with_info=undef, $attribute=undef, $value=undef) {
340

Francesc Guasch's avatar
Francesc Guasch committed
341
342
    my $doc = XML::LibXML->load_xml(string
            => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
343
344
345
346
        or die "ERROR: $!\n";

    my @img;

Francesc Guasch's avatar
Francesc Guasch committed
347
    my $n_order = 0;
348
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
Francesc Guasch's avatar
Francesc Guasch committed
349
350
351
352
353
        my ($source_node) = $disk->findnodes('source');
        my $file;
        $file = $source_node->getAttribute('file')  if $source_node;

        my ($target_node) = $disk->findnodes('target');
354
355
        my ($driver_node) = $disk->findnodes('driver');
        my ($backing_node) = $disk->findnodes('backingStore');
Francesc Guasch's avatar
Francesc Guasch committed
356
357
358
359
360
361
        my $device = $disk->getAttribute('device');
        my $target = $target_node->getAttribute('dev');
        my $bus = $target_node->getAttribute('bus');

        my ($boot_node) = $disk->findnodes('boot');
        my $info = {};
362
363
        eval { $info = $self->_volume_info($file) if $file && $device eq 'disk' };
        die $@ if $@ && $@ !~ /not found/i;
Francesc Guasch's avatar
Francesc Guasch committed
364
365
366
367
368
369
        $info->{device} = $device;
        if (!$info->{name} ) {
            if ($file) {
                ($info->{name}) = $file =~ m{.*/(.*)};
            } else {
                $info->{name} = $target."-".$info->{device};
370
371
            }
        }
Francesc Guasch's avatar
Francesc Guasch committed
372
        $info->{target} = $target;
373
374
        # we use driver to make it compatible with other hardware but it is more accurate
        # to say bus
Francesc Guasch's avatar
Francesc Guasch committed
375
        $info->{driver} = $bus;
376
        $info->{bus} = $bus;
Francesc Guasch's avatar
Francesc Guasch committed
377
378
        $info->{n_order} = $n_order++;
        $info->{boot} = $boot_node->getAttribute('order') if $boot_node;
Francesc Guasch's avatar
Francesc Guasch committed
379
        $info->{file} = $file if defined $file;
380
381
382
383
        if ($driver_node) {
            for my $attr  ($driver_node->attributes()) {
                $info->{"driver_".$attr->name} = $attr->getValue();
            }
384
385
386
        }
        $info->{backing} = $backing_node->toString()
        if $backing_node && $backing_node->attributes();
Francesc Guasch's avatar
Francesc Guasch committed
387
388
389
390
391

        next if defined $attribute
           && (!exists $info->{$attribute}
                || $info->{$attribute} ne $value);

Francesc Guasch's avatar
Francesc Guasch committed
392
        if (!$with_info) {
Francesc Guasch's avatar
Francesc Guasch committed
393
            push @img,($file) if $file;
Francesc Guasch's avatar
Francesc Guasch committed
394
395
            next;
        }
396
        push @img,Ravada::Volume->new(file => $file, info => $info, domain => $self);
397
398
399
400
401
    }
    return @img;

}

402
403
404
405
406
407
408
409
410
sub _pool_refresh($pool) {
    for ( ;; ) {
        eval { $pool->refresh };
        return if !$@;
        warn "WARNING: on vol remove , pool refresh $@" if $@;
        sleep 1;
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
411
sub _volume_info($self, $file, $refresh=0) {
Francesc Guasch's avatar
Francesc Guasch committed
412
413
    confess "Error: No vm connected" if !$self->_vm->vm;

Francesc Guasch's avatar
Francesc Guasch committed
414
415
416
417
    my ($name) = $file =~ m{.*/(.*)};

    my $vol;
    for my $pool ( $self->_vm->vm->list_storage_pools ) {
418
        _pool_refresh($pool) if $refresh;
Francesc Guasch's avatar
Francesc Guasch committed
419
420
421
422
423
424
425
426
        eval { $vol = $pool->get_volume_by_name($name) };
        warn $@ if $@ && $@ !~ /^libvirt error code: 50,/;
        last if $vol;
    }
    if (!$vol && !$refresh) {
        return $self->_volume_info($file, ++$refresh);
    }

Francesc Guasch's avatar
Francesc Guasch committed
427
    if (!$vol) {
Francesc Guasch's avatar
Francesc Guasch committed
428
        confess "Error: Volume $file not found ".$self->name;
Francesc Guasch's avatar
Francesc Guasch committed
429
430
        return;
    }
Francesc Guasch's avatar
Francesc Guasch committed
431

Francesc Guasch's avatar
Francesc Guasch committed
432
433
434
    my $info;
    eval { $info = $vol->get_info };
    warn "WARNING: $@" if $@ && $@ !~ /^libvirt error code: 50,/;
Francesc Guasch's avatar
Francesc Guasch committed
435
436
    $info->{file} = $file;
    $info->{name} = $name;
Francesc Guasch's avatar
Francesc Guasch committed
437
    $info->{driver} = delete $info->{bus} if exists $info->{bus};
Francesc Guasch's avatar
Francesc Guasch committed
438
439
440
441

    return $info;
}

442
443
444
sub _disk_devices_xml {
    my $self = shift;

445
    my $doc = XML::LibXML->load_xml(string => $self->xml_description)
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
        or die "ERROR: $!\n";

    my @devices;

    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        my $is_disk = 0;
        for my $child ($disk->childNodes) {
            $is_disk++ if $child->nodeName eq 'source';
        }
        push @devices,($disk) if $is_disk;
    }
    return @devices;

}

=head2 disk_device

Returns the file name of the disk of the domain.

  my $file_name = $domain->disk_device();

=cut

sub disk_device {
    my $self = shift;
471
    return $self->_disk_device(@_);
472
473
}

474

475
476
477
478
479
480
481
482
483
=head2 pre_prepare_base

Run this before preparing the base. It is necessary to correctly
detect disks drivers for newer libvirts.

This is executed automatically so it shouldn't been called.

=cut

484
485
sub pre_prepare_base($self) {
    $self->_detect_disks_driver();
486
487
}

488
=head2 post_prepare_base
489

490
Task to run after preparing a base virtual machine
491

492
=cut
493
494


495
sub post_prepare_base {
496
497
    my $self = shift;

498
499
500
    $self->_set_volumes_backing_store();
    $self->_store_xml();
}
501

502
503
504
505
sub _set_volumes_backing_store($self) {
    my $doc = XML::LibXML->load_xml(string
            => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
        or die "ERROR: $!\n";
506

507
508
509
510
511
512
513
    my @volumes_info = grep { defined($_) && $_->file } $self->list_volumes_info;
    my %vol = map { $_->file => $_ } @volumes_info;
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';
        for my $source( $disk->findnodes('source')) {
            my $file = $source->getAttribute('file');
            my $backing_file = $vol{$file}->backing_file();
Francesc Guasch's avatar
Francesc Guasch committed
514

515
516
517

            my ($backing_store) = $disk->findnodes('backingStore');
            if ($backing_file) {
Francesc Guasch's avatar
Francesc Guasch committed
518
519
520
521
522
523
524
525
526
                my $vol_backing_file = Ravada::Volume->new(
                    file => $backing_file
                    ,vm => $self->_vm
                );
                my $backing_file_format = (
                    $vol_backing_file->_qemu_info('file format')
                        or 'qcow2'
                );

527
528
529
                $backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
                $backing_store->setAttribute('type' => 'file');

Francesc Guasch's avatar
Francesc Guasch committed
530
531
                my ($format) = $backing_store->findnodes('format');
                $format = $backing_store->addNewChild(undef,'format') if !$format;
532
533
                $format->setAttribute('type' => $backing_file_format);

534
535
536
                my ($source_bf) = $backing_store->findnodes('source');
                $source_bf = $backing_store->addNewChild(undef,'source') if !$source_bf;
                $source_bf->setAttribute('file' => $backing_file);
537
538
539
540
            } else {
                $disk->removeChild($backing_store) if $backing_store;
                $backing_store = $disk->addNewChild(undef,'backingStore') if !$backing_store;
            }
541
542
543

        }
    }
544
    $self->_post_change_hardware($doc);
545
546
547
}


548
sub _store_xml($self) {
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
    my $xml = $self->domain->get_xml_description(Sys::Virt::Domain::XML_INACTIVE);
    my $sth = $self->_dbh->prepare(
        "INSERT INTO base_xml (id_domain, xml) "
        ." VALUES ( ?,? ) "
    );
    $sth->execute($self->id , $xml);
    $sth->finish;
}

=head2 get_xml_base

Returns the XML definition for the base, only if prepare_base has been run befor

=cut

sub get_xml_base{

    my $self = shift;
    my $sth = $self->_dbh->prepare(
        "SELECT xml FROM base_xml WHERE id_domain=?"
    );
    $sth->execute($self->id);
571
572
    my $xml = $sth->fetchrow;
    return ($xml or $self->domain->get_xml_description);
573
574
}

575
sub _post_remove_base_domain($self, $remove=0) {
576
577
578
579
    my $sth = $self->_dbh->prepare(
        "DELETE FROM base_xml WHERE id_domain=?"
    );
    $sth->execute($self->id);
580
581
582
583
584

    if (!$remove) {
        $self->_set_volumes_backing_store();
        $self->_detect_disks_driver();
    }
585
586
}

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
sub _detect_disks_driver($self) {
    my $doc = XML::LibXML->load_xml(string
        => $self->xml_description(Sys::Virt::Domain::XML_INACTIVE))
        or die "ERROR: $!\n";

    my @img;

    my @vols = $self->list_volumes_info();

    my $n_order = 0;
    for my $disk ($doc->findnodes('/domain/devices/disk')) {
        next if $disk->getAttribute('device') ne 'disk';
        my ( $driver ) = $disk->findnodes('driver');
        my ( $source ) = $disk->findnodes('source');

        my $file = $source->getAttribute('file');
        next if $file =~ /iso$/;

        my ($vol) = grep { defined $_->file && $_->file eq $file } @vols;
        my $format = $vol->_qemu_info('file format');
        confess "Error: wrong format ".Dumper($format)." for file $file"
        unless $format =~ /^\w+$/;

        confess "Error: no file format for $file" if !$format;
        $driver->setAttribute(type => $format);
    }

    $self->_post_change_hardware($doc);
}
JanFontanet's avatar
JanFontanet committed
616

617
618
sub post_resume_aux($self, %args) {
    my $set_time = delete $args{set_time};
619
    $set_time = 1 if !defined $set_time;
JanFontanet's avatar
JanFontanet committed
620
    eval {
621
        $self->set_time() if $set_time;
JanFontanet's avatar
JanFontanet committed
622
    };
623
624
625
626
    # 55: domain is not running
    # 74: not configured
    # 86: no agent
    die "$@\n" if $@ && $@ !~ /libvirt error code: (55|74|86),/;
627
628
629
630
631
}

sub set_time($self) {
    my $time = time();
    $self->domain->set_time($time, 0, 0);
JanFontanet's avatar
JanFontanet committed
632
633
}

Francesc Guasch's avatar
Francesc Guasch committed
634
=head2 display_info
635

Francesc Guasch's avatar
Francesc Guasch committed
636
Returns the display information as a hashref. The display URI is in the display entry
637
638
639

=cut

Francesc Guasch's avatar
Francesc Guasch committed
640
sub display_info($self, $user) {
641

642
    my $xml = XML::LibXML->load_xml(string => $self->xml_description);
643
644
645
646
647
    my ($graph) = $xml->findnodes('/domain/devices/graphics')
        or die "ERROR: I can't find graphic";

    my ($type) = $graph->getAttribute('type');
    my ($port) = $graph->getAttribute('port');
Francesc Guasch's avatar
Francesc Guasch committed
648
    my ($tls_port) = $graph->getAttribute('tlsPort');
649
650
    my ($address) = $graph->getAttribute('listen');

651
    warn "ERROR: Machine ".$self->name." is not active in node ".$self->_vm->name."\n"
652
        if !$port && !$self->is_active;
653

Francesc Guasch's avatar
Francesc Guasch committed
654
655
656
657

    my %display = (
                type => $type
               ,port => $port
658
                 ,ip => $address
Francesc Guasch's avatar
Francesc Guasch committed
659
660
          ,tls_port => $tls_port
    );
661
662
663
    $port = '' if !defined $port;
    my $display = $type."://$address:$port";
    $display{display} = $display;
Francesc Guasch's avatar
Francesc Guasch committed
664
665
    lock_hash(%display);
    return \%display;
666
667
668
669
670
671
672
673
674
675
}

=head2 is_active

Returns whether the domain is running or not

=cut

sub is_active {
    my $self = shift;
676
    return 0 if $self->is_removed;
Francesc Guasch's avatar
Francesc Guasch committed
677
678
    my $is_active = 0;
    eval { $is_active = $self->domain->is_active };
679
680
681
    return 0 if $@ && (    $@->code == 1    # client socket is closed
                        || $@->code == 38   # broken pipe
                    );
Francesc Guasch's avatar
Francesc Guasch committed
682
683
    die $@ if $@ && $@ !~ /code: 42,/;
    return $is_active;
684
685
}

Francesc Guasch's avatar
Francesc Guasch committed
686
687
688
689
690
691
692
693
=head2 is_persistent

Returns wether the domain has a persistent configuration file

=cut

sub is_persistent($self) {
    return $self->domain->is_persistent;
694
695
696
697
698
699
700
701
702
703
}

=head2 start

Starts the domain

=cut

sub start {
    my $self = shift;
704
705
    my %arg;

706
    if (!(scalar(@_) % 2))  {
707
708
        %arg = @_;
    }
709

710
711
    my $remote_ip = delete $arg{remote_ip};
    my $request = delete $arg{request};
712
713
    my $listen_ip = ( delete $arg{listen_ip} or $self->_listen_ip);
    my $set_password = delete $arg{set_password};
714

715
    $self->_set_spice_ip($set_password, $listen_ip);
716
717
718
719
720
721
722
723

    my $is_active = $self->is_active();
    if (!$is_active) {
        $self->_check_qcow_format($request);
        $self->_set_volumes_backing_store();
        $self->_detect_disks_driver();
    }

724
    $self->status('starting');
Francesc Guasch's avatar
Francesc Guasch committed
725
726
727
728
729
730
731
732
733
734

    my $error;
    for ( ;; ) {
        eval { $self->domain->create() };
        $error = $@;
        next if $error && $error =~ /libvirt error code: 1, .* pool .* asynchronous/;
        last;
    }
    return if !$error || $error =~ /already running/i;
    if ($error =~ /libvirt error code: 38,/) {
735
736
        die "Error starting ".$self->name." on ".$self->_vm->name
            ."\n$error";
Francesc Guasch's avatar
Francesc Guasch committed
737
738
    } elsif ( $error =~ /libvirt error code: 9, .*already defined with uuid/) {
        die "TODO";
739
740
741
    } elsif ( $error =~ /libvirt error code: 1,.*smbios/) {
        $self->_remove_smbios();
        $self->domain->create();
Francesc Guasch's avatar
Francesc Guasch committed
742
743
744
745
746
747
    } elsif ( $self->domain->has_managed_save_image ) {
        $request->status("removing saved image") if $request;
        $self->domain->managed_save_remove();
        $self->domain->create();
    } else {
        die $error;
748
    }
749
750
}

751
752
753
754
755
756
757
758
759
760
761
762
763
764
sub _check_qcow_format($self, $request) {
    return if $self->is_active;
    for my $vol ( $self->list_volumes_info ) {
        next if !$vol->file || $vol->file =~ /iso$/;
        next if !$vol->backing_file;

        next if $vol->_qemu_info('backing file format') eq 'qcow2';

        $request->status("rebasing","rebasing to release 0.8 "
            .$vol->file."\n".$vol->backing_file) if $request;
        $vol->rebase($vol->backing_file);
    }
}

765
766
767
768
769
770
771
772
773
774
775
sub _remove_smbios($self) {
    my $doc = XML::LibXML->load_xml(string => $self->domain->get_xml_description(Sys::Virt::Domain::XML_INACTIVE));

    my ($os) = $doc->findnodes('/domain/os');
    my ($smbios) = $os->findnodes('smbios');
    $os->removeChild($smbios) if $smbios;

    my $new_domain = $self->_vm->vm->define_domain($doc->toString);
    $self->domain($new_domain);
}

Francesc Guasch's avatar
Francesc Guasch committed
776
777
sub _pre_shutdown_domain {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
778

Francesc Guasch's avatar
Francesc Guasch committed
779
780
    my ($state, $reason) = $self->domain->get_state();

Roberto P. Rubio's avatar
Roberto P. Rubio committed
781
782
    if ($state == Sys::Virt::Domain::STATE_PMSUSPENDED_UNKNOWN
         || $state == Sys::Virt::Domain::STATE_PMSUSPENDED_DISK_UNKNOWN
Francesc Guasch's avatar
Francesc Guasch committed
783
784
785
786
787
788
789
         || $state == Sys::Virt::Domain::STATE_PMSUSPENDED) {
        $self->domain->pm_wakeup();
        for ( 1 .. 10 ) {
            last if $self->is_active;
            sleep 1;
        }
    }
790
791
792

    $self->domain->managed_save_remove()
        if $self->domain->has_managed_save_image();
Francesc Guasch's avatar
Francesc Guasch committed
793

Francesc Guasch's avatar
Francesc Guasch committed
794
795
}

796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
=head2 shutdown

Stops the domain

=cut

sub shutdown {
    my $self = shift;

    my %args = @_;
    my $req = $args{req};

    if (!$self->is_active && !$args{force}) {
        $req->status("done")                if $req;
        $req->error("Domain already down")  if $req;
        return;
    }

    return $self->_do_force_shutdown() if $args{force};
    return $self->_do_shutdown();

}

sub _do_shutdown {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
821
822
823
    return if !$self->domain->is_active;
    eval { $self->domain->shutdown() };
    die $@ if $@ && $@ !~ /libvirt error code: 55,/;
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845

}

=head2 shutdown_now

Shuts down uncleanly the domain

=cut

sub shutdown_now {
    my $self = shift;
    return $self->_do_force_shutdown()  if $self->is_active;
}

=head2 force_shutdown

Shuts down uncleanly the domain

=cut

sub force_shutdown{
    my $self = shift;
846
    return $self->_do_force_shutdown() if $self->is_active;
847
848
849
850
}

sub _do_force_shutdown {
    my $self = shift;
851
852
853
854
    return if !$self->domain->is_active;

    eval { $self->domain->destroy   };
    warn $@ if $@;
855
856
}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
=head2 reboot

Stops the domain

=cut

sub reboot {
    my $self = shift;
    my %args = @_;
    my $req = $args{req};

    if (!$self->is_active) {
        $req->status("done")           if $req;
        $req->error("Domain is down")  if $req;
        return;
    }

Roberto P. Rubio's avatar
Roberto P. Rubio committed
874
    return $self->_do_force_shutdown() if $args{force};
Roberto P. Rubio's avatar
Roberto P. Rubio committed
875
876
877
878
    return $self->_do_reboot();

}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
879
880
881
882
883
884
885
886
887
888
889
890
sub force_reboot {
    my $self = shift;
    return $self->_do_force_reboot()  if $self->is_active;
}

sub _do_force_reboot {
    my $self = shift;
    return if !$self->domain->is_active;
    eval { $self->domain->reset() };
    warn $@ if $@;
}

Roberto P. Rubio's avatar
Roberto P. Rubio committed
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
sub _do_reboot {
    my $self = shift;
    return if !$self->domain->is_active;
    eval { $self->domain->reboot() };
    die $@ if $@;
}

=head2 reboot_now

Reboots uncleanly the domain

=cut

sub reboot_now {
    my $self = shift;
    return $self->_do_reboot()  if $self->is_active;
}
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927

=head2 pause

Pauses the domain

=cut

sub pause {
    my $self = shift;
    return $self->domain->suspend();
}

=head2 resume

Resumes a paused the domain

=cut

sub resume {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
928
    eval { $self->domain->resume() };
929
    confess $@ if $@ && $@ !~ /libvirt error code: 55/;
930
931
932
}


933
934
935
936
937
938
939
940
941
942
943
=head2 is_hibernated

Returns if the domain has a managed saved state.

=cut

sub is_hibernated {
    my $self = shift;
    return $self->domain->has_managed_save_image;
}

944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
=head2 is_paused

Returns if the domain is paused

=cut

sub is_paused {
    my $self = shift;
    my ($state, $reason) = $self->domain->get_state();



    return 0 if $state == 1;
    #TODO, find out which one of those id "1" and remove it from this list
    #
    return $state &&
        ($state == Sys::Virt::Domain::STATE_PAUSED_UNKNOWN
        || $state == Sys::Virt::Domain::STATE_PAUSED_USER
        || $state == Sys::Virt::Domain::STATE_PAUSED_DUMP
        || $state == Sys::Virt::Domain::STATE_PAUSED_FROM_SNAPSHOT
        || $state == Sys::Virt::Domain::STATE_PAUSED_IOERROR
        || $state == Sys::Virt::Domain::STATE_PAUSED_MIGRATION
        || $state == Sys::Virt::Domain::STATE_PAUSED_SAVE
        || $state == Sys::Virt::Domain::STATE_PAUSED_SHUTTING_DOWN
    );
    return 0;
}

972
973
974
975
976
977
978
979
=head2 can_hybernate

Returns true (1) for KVM domains

=cut

sub can_hybernate { 1 };

Francesc Guasch's avatar
Francesc Guasch committed
980
981
982
983
984
985
986
987
=head2 can_hybernate

Returns true (1) for KVM domains

=cut

sub can_hibernate { 1 };

988
989
990
991
992
993
994
995
996
997
998
=head2 hybernate

Take a snapshot of the domain's state and save the information to a
managed save location. The domain will be automatically restored with
this state when it is next started.

    $domain->hybernate();

=cut

sub hybernate {
Francesc Guasch's avatar
Francesc Guasch committed
999
    my $self = shift;
1000
    $self->hibernate(@_);
For faster browsing, not all history is shown. View entire blame