Ravada.pm 16.5 KB
Newer Older
1
2
3
4
5
package Ravada;

use warnings;
use strict;

6
use Carp qw(carp croak);
7
use Data::Dumper;
8
use DBIx::Connector;
9
use Hash::Util qw(lock_hash);
10
use Moose;
Francesc Guasch's avatar
Francesc Guasch committed
11
use POSIX qw(WNOHANG);
12
13
use YAML;

Francesc Guasch's avatar
Francesc Guasch committed
14
use Ravada::Auth;
15
use Ravada::Request;
16
use Ravada::VM::KVM;
17
use Ravada::VM::LXC;
18
use Ravada::VM::Void;
19

Francesc Guasch's avatar
Francesc Guasch committed
20
21
22
23
24
25
26
27
28
29
30
31
=head1 NAME

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

32
33
34
35
36
37
38

our $FILE_CONFIG = "/etc/ravada.conf";

###########################################################################

our $CONNECTOR;
our $CONFIG = {};
39
our $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
40
our $CAN_FORK = 0;
41
42
43
44
45
46
47
48
49
50


has 'vm' => (
          is => 'ro'
        ,isa => 'ArrayRef'
       ,lazy => 1
     , builder => '_create_vm'
);

has 'connector' => (
51
52
53
54
55
56
        is => 'rw'
);

has 'config' => (
    is => 'ro'
    ,isa => 'Str'
57
58
);

Francesc Guasch's avatar
Francesc Guasch committed
59
60
61
62
63
64
65
=head2 BUILD

Internal constructor

=cut


66
67
sub BUILD {
    my $self = shift;
68
    if ($self->config()) {
69
        _init_config($self->config);
70
    } else {
Francesc Guasch's avatar
Francesc Guasch committed
71
        _init_config($FILE_CONFIG) if -e $FILE_CONFIG;
72
    }
73

Francesc Guasch's avatar
Francesc Guasch committed
74
75
76
77
    if ( $self->connector ) {
        $CONNECTOR = $self->connector 
    } else {
        $CONNECTOR = $self->_connect_dbh();
78
        $self->connector($CONNECTOR);
Francesc Guasch's avatar
Francesc Guasch committed
79
    }
Francesc Guasch's avatar
Francesc Guasch committed
80
    Ravada::Auth::init($CONFIG);
81
82
83
84
85
86
}

sub _connect_dbh {
    my $driver= ($CONFIG->{db}->{driver} or 'mysql');;
    my $db_user = ($CONFIG->{db}->{user} or getpwnam($>));;
    my $db_pass = ($CONFIG->{db}->{password} or undef);
Francesc Guasch's avatar
Francesc Guasch committed
87
88
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
89
90
91
92
93
94
95
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

sub _init_config {
    my $file = shift;
96
97

    my $connector = shift;
98
    confess "Deprecated connector" if $connector;
99

100
    $CONFIG = YAML::LoadFile($file);
101
#    $CONNECTOR = ( $connector or _connect_dbh());
102
103
}

104
sub _create_vm_kvm {
105
    my $self = shift;
106

107
108
109
110
    my $cmd_qemu_img = `which qemu-img`;
    chomp $cmd_qemu_img;

    return(undef,"ERROR: Missing qemu-img") if !$cmd_qemu_img;
111
112

    my $vm_kvm;
113

114
115
    eval { $vm_kvm = Ravada::VM::KVM->new( connector => ( $self->connector or $CONNECTOR )) };
    my $err_kvm = $@;
116
    return (undef, $err_kvm)    if !$vm_kvm;
117
118
119
120
121
122
123
124
125

    my ($internal_vm , $storage);
    eval {
        $internal_vm = $vm_kvm->vm;
        $internal_vm->list_all_domains();

        $storage = $vm_kvm->dir_img();
    };
    $vm_kvm = undef if $@ || !$internal_vm || !$storage;
Francesc Guasch's avatar
Francesc Guasch committed
126
127
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
128
129
}

130
131
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
132
    sleep 1;
133
134
135
136
137
138
139
140
141
142
    for my $n ( 0 .. $#{$self->vm}) {
        my $vm = $self->vm->[$n];
        next if ref $vm !~ /KVM/i;
        warn "Refreshing VM $n $vm" if $DEBUG;
        my ($vm2, $err) = $self->_create_vm_kvm();
        $self->vm->[$n] = $vm2;
        warn $err if $err;
    }
}

143
144
145
146
147
148
149
sub _create_vm {
    my $self = shift;

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();

150
151
152
153
154
155
156
157
    push @vms,($vm_kvm) if $vm_kvm;

    my $vm_lxc;
    eval { $vm_lxc = Ravada::VM::LXC->new( connector => ( $self->connector or $CONNECTOR )) };
    push @vms,($vm_lxc) if $vm_lxc;
    my $err_lxc = $@;

    if (!@vms) {
Francesc Guasch's avatar
Francesc Guasch committed
158
        confess "No VMs found: $err_lxc\n$err_kvm\n";
159
160
161
    }
    return \@vms;

162
163
}

164
165
166
167
168
169
170
171
172
173
174
175
176
177
sub check_vms {
    my $self = shift;

    my @vm = @{$self->vm};
    for my $n ( 0 .. $#vm ) {
        if ($vm[$n] && ref $vm[$n] =~ /KVM/i) {
            if (!$vm[$n]->is_alive) {
                warn "$vm[$n] dead" if $DEBUG;
                $vm[$n] = $self->_create_vm_kvm();
            }
        }
    }
}

Francesc Guasch's avatar
Francesc Guasch committed
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
=head2 create_domain

Creates a new domain based on an ISO image or another domain.

  my $domain = $ravada->create_domain( 
         name => $name
    , id_iso => 1
  );


  my $domain = $ravada->create_domain( 
         name => $name
    , id_base => 3
  );


=cut


197
sub create_domain {
198
199
    my $self = shift;

200
201
    my %args = @_;

202
203
204
    croak "Argument id_owner required "
        if !$args{id_owner};

205
206
    my $vm_name = $args{vm};
    delete $args{vm};
207

Francesc Guasch's avatar
Francesc Guasch committed
208
209
210
    my $request = $args{request}            if $args{request};

    $request->status("Searching for VM")    if $request;
Francesc Guasch's avatar
Francesc Guasch committed
211

212
    my $vm = $self->vm->[0];
213
    $vm = $self->search_vm($vm_name)   if $vm_name;
214

215
216
    carp "WARNING: no VM defined, we will use ".$vm->name
        if !$vm_name;
Francesc Guasch's avatar
Francesc Guasch committed
217

218
    confess "I can't find any vm ".Dumper($self->vm) if !$vm;
Francesc Guasch's avatar
Francesc Guasch committed
219

220
    $request->status("creating domain in ".ref($vm))    if $request;
221
    return $vm->create_domain(@_);
222
223
}

Francesc Guasch's avatar
Francesc Guasch committed
224
225
226
227
228
229
230
231
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

232
233
sub remove_domain {
    my $self = shift;
234
235
    my %arg = @_;

236
    confess "Argument name required "
237
238
        if !$arg{name};

239
240
    confess "Argument uid required "
        if !$arg{uid};
241
242
243
244

    lock_hash(%arg);

    my $domain = $self->search_domain($arg{name}, 1)
245
        or die "ERROR: I can't find domain '$arg{name}', maybe already removed.";
246

247
248
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
249
250
}

Francesc Guasch's avatar
Francesc Guasch committed
251
252
253
254
255
256
=head2 search_domain

  my $domain = $ravada->search_domain($name);

=cut

257
258
259
sub search_domain {
    my $self = shift;
    my $name = shift;
260
    my $import = shift;
261
262

    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
263
        my $domain = $vm->search_domain($name, $import);
264
        next if !$domain;
265
        next if !$domain->_select_domain_db && !$import;
266
267
268
        my $id;
        eval { $id = $domain->id };
        # TODO import the domain in the database with an _insert_db or something
Francesc Guasch's avatar
Francesc Guasch committed
269
        warn $@ if $@   && $DEBUG;
270
        return $domain if $id || $import;
271
    }
272
273
274
275
276
277
278
279

    my $vm = $self->search_vm('Void');
    warn "No Void VM" if !$vm;
    return if !$vm;

    my $domain = $vm->search_domain($name, $import);
    return $domain if $domain;

280
    return;
281
}
282

Francesc Guasch's avatar
Francesc Guasch committed
283
284


285
286
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
287
List all created domains
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303

  my @list = $ravada->list_domains();

=cut

sub list_domains {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
            push @domains,($domain);
        }
    }
    return @domains;
}

304
305
306
307
308
309
310
311
312
313
314
315
316
=head2 list_domains_data

List all domains in raw format. Return a list of id => { name , id , is_active , is_base }

   my $list = $ravada->list_domains_data();

   $c->render(json => $list);

=cut

sub list_domains_data {
    my $self = shift;
    my @domains;
317
318
319
320
321
322
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
323
    }
324
    $sth->finish;
325
    return \@domains;
326
327
}

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
# sub list_domains_data {
#     my $self = shift;
#     my @domains;
#     for my $domain ($self->list_domains()) {
#         eval { $domain->id };
#         warn $@ if $@;
#         next if $@;
#         push @domains, {                id => $domain->id 
#                                     , name => $domain->name
#                                   ,is_base => $domain->is_base
#                                 ,is_active => $domain->is_active
                               
#                            }
#     }
#     return \@domains;
# }

345

Francesc Guasch's avatar
Francesc Guasch committed
346
347
348
349
350
351
352
353
354
355
356
357
358
359
=head2 list_bases

List all base domains

  my @list = $ravada->list_domains();


=cut

sub list_bases {
    my $self = shift;
    my @domains;
    for my $vm (@{$self->vm}) {
        for my $domain ($vm->list_domains) {
360
361
362
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
363
364
365
366
367
368
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
=head2 list_bases_data

List information about the bases

=cut

sub list_bases_data {
    my $self = shift;
    my @data;
    for ($self->list_bases ) {
        push @data,{ id => $_->id , name => $_->name };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
=head2 list_images

List all ISO images

=cut

sub list_images {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM iso_images ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
=head2 list_images_data

List information about the images

=cut

sub list_images_data {
    my $self = shift;
    my @data;
    for ($self->list_images ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

Francesc Guasch's avatar
Francesc Guasch committed
419

fv3rdugo's avatar
fv3rdugo committed
420
421
422
423
sub list_images_lxc {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
424
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

=head2 list_images_data

List information about the images

=cut

sub list_images_data_lxc {
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}



Francesc Guasch's avatar
Francesc Guasch committed
451
452
453
454
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
455

Francesc Guasch's avatar
Francesc Guasch committed
456
457
=cut

458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
sub remove_volume {
    my $self = shift;

    my $file = shift;
    my ($name) = $file =~ m{.*/(.*)};

    my $removed = 0;
    for my $vm (@{$self->vm}) {
        my $vol = $vm->search_volume($name);
        next if !$vol;

        $vol->delete();
        $removed++;
    }
    if (!$removed && -e $file ) {
        warn "volume $file not found. removing file $file.\n";
        unlink $file or die "$! $file";
    }

}
478

Francesc Guasch's avatar
Francesc Guasch committed
479
480
481
482
483
484
485
486
=head2 process_requests

This is run in the ravada backend. It processes the commands requested by the fronted

  $ravada->process_requests();

=cut

487
488
sub process_requests {
    my $self = shift;
489
    my $debug = shift;
490
    my $dont_fork = shift;
Francesc Guasch's avatar
Francesc Guasch committed
491
    $dont_fork = 1 if !$CAN_FORK;
492

493
    $self->_wait_pids_nohang();
494
    $self->check_vms();
495

496
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
497
        ." WHERE status='requested' OR status like 'retry %'");
498
499
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
500
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
501
        my $req = Ravada::Request->open($id);
502
503
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
504
505
506

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
507
        $req->status('working');
508
        eval { $self->_execute($req, $dont_fork) };
509
        my $err = $@;
510
        $req->error($err or '');
511
        if ($err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
512
            if ( $n_retry < 3) {
513
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
514
                $req->status("retry ".++$n_retry)   
515
516
517
            }
            $self->_refresh_vm_kvm();
        } else {
518
            $req->status('done');
519
        }
520
521
522
        warn "req ".$req->id." , command: ".$req->command." , status: ".$req->status()
            ." , error: '".($req->error or 'NONE')."'" 
                if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
523
524

        $self->_refresh_vm_kvm() if $req->command =~ /create|remove/i;
525
526
527
528
    }
    $sth->finish;
}

529
530
sub _process_requests_dont_fork {
    my $self = shift;
531
    my $debug = shift;
532
    return $self->process_requests($debug, 1);
533
}
Francesc Guasch's avatar
Francesc Guasch committed
534

535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
=head2 list_vm_types

Returnsa list ofthe types of Virtual Machines available on this system

=cut

sub list_vm_types {
    my $self = shift;
    
    my %type;
    for my $vm (@{$self->vm}) {
            my ($name) = ref($vm) =~ /.*::(.*)/;
            $type{$name}++;
    }
    return sort keys %type;
}

552
553
554
sub _execute {
    my $self = shift;
    my $request = shift;
555
    my $dont_fork = shift;
556

Francesc Guasch's avatar
Francesc Guasch committed
557
558
559
560
561
    my $sub = $self->_req_method($request->command);

    die "Unknown command ".$request->command
        if !$sub;

562
    return $sub->($self,$request, $dont_fork);
Francesc Guasch's avatar
Francesc Guasch committed
563
564
565

}

566
567
568
569
570
571
572
573
574
sub _cmd_domdisplay {
    my $self = shift;
    my $request = shift;

    $request->status('working');

    my $name = $request->args('name');
    confess "Unknown name for request ".Dumper($request)  if!$name;
    my $domain = $self->search_domain($request->args->{name});
575
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
576
    $request->error('');
577
    my $display = $domain->display($user);
578
579
580
581
    $request->result({display => $display});

    $request->status('done');

582
583
}

584
sub _do_cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
585
586
587
    my $self = shift;
    my $request = shift;

588
    $request->status('creating domain');
589
    warn "$$ creating domain"   if $DEBUG;
590
    my $domain;
591
    $domain = $self->create_domain(%{$request->args},request => $request);
592

Francesc Guasch's avatar
Francesc Guasch committed
593
594
595
596
    $request->status('done');

}

597
598
599
600
601
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

    my $kid = waitpid(-1 , WNOHANG);
Francesc Guasch's avatar
Francesc Guasch committed
602
    return if !$kid || $kid == -1;
603

604
    warn "Kid $kid finished"    if $DEBUG;
605
606
607
    delete $self->{pids}->{$kid};
}

Francesc Guasch's avatar
Francesc Guasch committed
608
609
610
611
sub _wait_pids {
    my $self = shift;
    my $request = shift;

Francesc Guasch's avatar
Francesc Guasch committed
612
613
    $request->status('waiting for other tasks')     if $request;

Francesc Guasch's avatar
Francesc Guasch committed
614
    for my $pid ( keys %{$self->{pids}}) {
615
616
617
        $request->status("waiting for pid $pid")    if $request;

#        warn "Checking for pid '$pid' created at ".localtime($self->{pids}->{$pid});
Francesc Guasch's avatar
Francesc Guasch committed
618
619
        my $kid = waitpid($pid,0);

620
#        warn "Found $kid";
Francesc Guasch's avatar
Francesc Guasch committed
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
        return if $kid  == $pid;
    }
}

sub _add_pid {
    my $self = shift;
    my $pid = shift;

    $self->{pids}->{$pid} = time;
}

sub _cmd_create {

    my $self = shift;
    my $request = shift;
636
637
638
639
    my $dont_fork = shift;

    return $self->_do_cmd_create($request)
        if $dont_fork;
Francesc Guasch's avatar
Francesc Guasch committed
640
641
642
643
644
645
646
647
648
649
650
651


    $self->_wait_pids($request);

    $request->status('forking');
    my $pid = fork();
    if (!defined $pid) {
        $request->status('done');
        $request->error("I can't fork");
        return;
    }
    if ($pid == 0 ) {
652
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
653
654
655
        exit;
    }
    $self->_add_pid($pid);
656

Francesc Guasch's avatar
Francesc Guasch committed
657
658
659
    return;
}

Francesc Guasch's avatar
Francesc Guasch committed
660
sub _do_cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
661
662
663
664
    my $self = shift;
    my $request = shift;

    $request->status('working');
665
666
667
668
    confess "Unknown user id ".$request->args->{uid}
        if !defined $request->args->{uid};

    $self->remove_domain(name => $request->args('name'), uid => $request->args('uid'));
Francesc Guasch's avatar
Francesc Guasch committed
669
670
    $request->status('done');
    $request->error($@);
Francesc Guasch's avatar
Francesc Guasch committed
671

672
}
Francesc Guasch's avatar
Francesc Guasch committed
673

Francesc Guasch's avatar
Francesc Guasch committed
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
sub _cmd_remove {
    my $self = shift;
    my $request = shift;
    my $dont_fork = shift;

    return $self->_do_cmd_remove($request)
        if $dont_fork;

    $self->_wait_pids($request);

    $request->status('forking');
    my $pid = fork();
    if (!defined $pid) {
        $request->status('done');
        $request->error("I can't fork");
        return;
    }
    if ($pid == 0 ) {
        $self->_do_cmd_remove($request);
        exit;
    }
    $self->_add_pid($pid);

    return;
}

Francesc Guasch's avatar
Francesc Guasch committed
700
701
702
703
704
705
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
706
707
708
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
    $domain->start();
709

Francesc Guasch's avatar
Francesc Guasch committed
710
711
712
713
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
714
715
716
717
718
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
719
720
721
722
723
724
725
726
727
728
    my $name = $request->args('name')   or confess "Missing argument name";
    my $uid = $request->args('uid')     or confess "Missing argument uid";

    my $user = Ravada::Auth::SQL->search_by_id( $uid);

    my $domain = $self->search_domain($name);

    die "Unknown domain '$name'\n" if !$domain;

    $domain->prepare_base($user);
Francesc Guasch's avatar
Francesc Guasch committed
729
730
731
732

}


Francesc Guasch's avatar
Francesc Guasch committed
733
734
735
736
737
738
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
739
    my $timeout = ($request->args('timeout') or 60);
740

741
    my $domain;
742
743
744
745
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

    $domain->shutdown(timeout => $timeout);
Francesc Guasch's avatar
Francesc Guasch committed
746
747
748

}

749
750
751
752
753
sub _cmd_list_vm_types {
    my $self = shift;
    my $request = shift;
    $request->status('working');
    my @list_types = $self->list_vm_types();
Francesc Guasch's avatar
Francesc Guasch committed
754
    $request->result(\@list_types);
755
756
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
757

758
759
760
761
762
763
764
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

    $request->status('done');
    return 1;
}
Francesc Guasch's avatar
Francesc Guasch committed
765

Francesc Guasch's avatar
Francesc Guasch committed
766
767
768
769
770
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

    my %methods = (
Francesc Guasch's avatar
Francesc Guasch committed
771

Francesc Guasch's avatar
Francesc Guasch committed
772
773
774
          start => \&_cmd_start
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
Francesc Guasch's avatar
Francesc Guasch committed
775
      ,shutdown => \&_cmd_shutdown
776
    ,domdisplay => \&_cmd_domdisplay
777
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
778
  ,prepare_base => \&_cmd_prepare_base
779
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
780
781
782
783
    );
    return $methods{$cmd};
}

784
785
786
787
788
789
790
791
792
793
794
795
=head2 search_vm

Searches for a VM of a given type

  my $vm = $ravada->search_vm('kvm');

=cut

sub search_vm {
    my $self = shift;
    my $type = shift;

796
797
    confess "Missing VM type"   if !$type;

798
    my $class = 'Ravada::VM::'.uc($type);
Francesc Guasch's avatar
Francesc Guasch committed
799

800
    if ($type =~ /Void/i) {
801
802
803
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
804
805
806
    my @vms;
    eval { @vms = @{$self->vm} };
    for my $vm (@vms) {
807
808
809
810
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
811

Francesc Guasch's avatar
Francesc Guasch committed
812
813
814
815
816
817
818
819
820
821
=head1 AUTHOR

Francesc Guasch-Ortiz	, frankie@telecos.upc.edu

=head1 SEE ALSO

Sys::Virt

=cut

822
1;