Ravada.pm 16.6 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
510
        my $err = $@;
        if ($err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
511
            if ( $n_retry < 3) {
512
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
513
                $req->status("retry ".++$n_retry)   
514
515
516
            }
            $self->_refresh_vm_kvm();
        } else {
517
            $req->status('done');
518
        }
519
        $req->error($err or '');
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);
Francesc Guasch's avatar
Francesc Guasch committed
592
    warn $@ if $@;
593

Francesc Guasch's avatar
Francesc Guasch committed
594
595
596
597
598
    $request->status('done');
    $request->error($@);

}

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

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

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

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

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

Francesc Guasch's avatar
Francesc Guasch committed
616
    for my $pid ( keys %{$self->{pids}}) {
617
618
619
        $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
620
621
        my $kid = waitpid($pid,0);

622
#        warn "Found $kid";
Francesc Guasch's avatar
Francesc Guasch committed
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
        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;
638
639
640
641
    my $dont_fork = shift;

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


    $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 ) {
654
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
655
656
657
        exit;
    }
    $self->_add_pid($pid);
658

Francesc Guasch's avatar
Francesc Guasch committed
659
660
661
    return;
}

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

    $request->status('working');
667
668
669
670
    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
671
672
    $request->status('done');
    $request->error($@);
Francesc Guasch's avatar
Francesc Guasch committed
673

674
}
Francesc Guasch's avatar
Francesc Guasch committed
675

Francesc Guasch's avatar
Francesc Guasch committed
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
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
702
703
704
705
706
707
sub _cmd_start {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
712
    $request->status('done');
713
    $request->error($@ or '');
Francesc Guasch's avatar
Francesc Guasch committed
714
715
716

}

Francesc Guasch's avatar
Francesc Guasch committed
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
    eval { 
        my $domain = $self->search_domain($name);
        die "Unknown domain '$name'\n" if !$domain;
        $domain->prepare_base();
    };
    $request->status('done');
    $request->error($@);

}


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

    $request->status('working');
    my $name = $request->args('name');
740
741
    my $timeout = ($request->args('timeout') or 60);
    my $domain;
Francesc Guasch's avatar
Francesc Guasch committed
742
    eval { 
743
        $domain = $self->search_domain($name);
Francesc Guasch's avatar
Francesc Guasch committed
744
        die "Unknown domain '$name'\n" if !$domain;
745
        $domain->shutdown(timeout => $timeout);
Francesc Guasch's avatar
Francesc Guasch committed
746
747
748
749
750
751
    };
    $request->status('done');
    $request->error($@);

}

752
753
754
755
756
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
757
    $request->result(\@list_types);
758
759
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
760

761
762
763
764
765
766
767
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
769
770
771
772
773
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

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

787
788
789
790
791
792
793
794
795
796
797
798
=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;

799
800
    confess "Missing VM type"   if !$type;

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

803
    if ($type =~ /Void/i) {
804
805
806
        return Ravada::VM::Void->new();
    }

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

Francesc Guasch's avatar
Francesc Guasch committed
815
816
817
818
819
820
821
822
823
824
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

825
1;