Ravada.pm 16.8 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
    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

    return if !scalar @vms;
139
140
141
142
143
144
145
146
147
148
    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;
    }
}

149
150
151
152
153
154
155
sub _create_vm {
    my $self = shift;

    my @vms = ();

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

156
157
158
159
160
161
162
163
    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
164
        confess "No VMs found: $err_lxc\n$err_kvm\n";
165
166
167
    }
    return \@vms;

168
169
}

170
171
172
sub check_vms {
    my $self = shift;

173
174
    my @vm;
    eval { @vm = @{$self->vm} };
175
176
177
178
179
180
181
182
183
184
    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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
=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


204
sub create_domain {
205
206
    my $self = shift;

207
208
    my %args = @_;

209
210
211
    croak "Argument id_owner required "
        if !$args{id_owner};

212
213
    my $vm_name = $args{vm};
    delete $args{vm};
214

Francesc Guasch's avatar
Francesc Guasch committed
215
216
217
    my $request = $args{request}            if $args{request};

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

219
    my $vm;
220
    $vm = $self->search_vm($vm_name)   if $vm_name;
221
    $vm = $self->vm->[0]               if !$vm;
222

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

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

228
    $request->status("creating domain in ".ref($vm))    if $request;
229
    return $vm->create_domain(@_);
230
231
}

Francesc Guasch's avatar
Francesc Guasch committed
232
233
234
235
236
237
238
239
=head2 remove_domain

Removes a domain

  $ravada->remove_domain($name);

=cut

240
241
sub remove_domain {
    my $self = shift;
242
243
    my %arg = @_;

244
    confess "Argument name required "
245
246
        if !$arg{name};

247
248
    confess "Argument uid required "
        if !$arg{uid};
249
250
251
252

    lock_hash(%arg);

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

255
256
    my $user = Ravada::Auth::SQL->search_by_id( $arg{uid});
    $domain->remove( $user);
257
258
}

Francesc Guasch's avatar
Francesc Guasch committed
259
260
261
262
263
264
=head2 search_domain

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

=cut

265
266
267
sub search_domain {
    my $self = shift;
    my $name = shift;
268
    my $import = shift;
269

270
271
272
273
274
275
276
277
278
279
280
281
    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;

    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

282
    for my $vm (@{$self->vm}) {
Francesc Guasch's avatar
Francesc Guasch committed
283
        my $domain = $vm->search_domain($name, $import);
284
        next if !$domain;
285
        next if !$domain->_select_domain_db && !$import;
286
287
288
        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
289
        warn $@ if $@   && $DEBUG;
290
        return $domain if $id || $import;
291
    }
292
293


294
    return;
295
}
296

Francesc Guasch's avatar
Francesc Guasch committed
297
298


299
300
=head2 list_domains

Francesc Guasch's avatar
Francesc Guasch committed
301
List all created domains
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

  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;
}

318
319
320
321
322
323
324
325
326
327
328
329
330
=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;
331
332
333
334
335
336
    my $sth = $CONNECTOR->dbh->prepare(
        "SELECT * FROM domains ORDER BY name"
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
337
    }
338
    $sth->finish;
339
    return \@domains;
340
341
}

342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
# 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;
# }

359

Francesc Guasch's avatar
Francesc Guasch committed
360
361
362
363
364
365
366
367
368
369
370
371
372
373
=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) {
374
375
376
            eval { $domain->id };
            warn $@ if $@;
            next    if $@;
Francesc Guasch's avatar
Francesc Guasch committed
377
378
379
380
381
382
            push @domains,($domain) if $domain->is_base;
        }
    }
    return @domains;
}

383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
=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
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
=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;
}

418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
=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
433

fv3rdugo's avatar
fv3rdugo committed
434
435
436
437
sub list_images_lxc {
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
438
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
    );
    $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
465
466
467
468
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
469

Francesc Guasch's avatar
Francesc Guasch committed
470
471
=cut

472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
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";
    }

}
492

Francesc Guasch's avatar
Francesc Guasch committed
493
494
495
496
497
498
499
500
=head2 process_requests

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

  $ravada->process_requests();

=cut

501
502
sub process_requests {
    my $self = shift;
503
    my $debug = shift;
504
    my $dont_fork = shift;
Francesc Guasch's avatar
Francesc Guasch committed
505
    $dont_fork = 1 if !$CAN_FORK;
506

507
    $self->_wait_pids_nohang();
508
    $self->check_vms();
509

510
    my $sth = $CONNECTOR->dbh->prepare("SELECT id FROM requests "
Francesc Guasch's avatar
Francesc Guasch committed
511
        ." WHERE status='requested' OR status like 'retry %'");
512
513
    $sth->execute;
    while (my ($id)= $sth->fetchrow) {
514
        $self->_wait_pids_nohang();
Francesc Guasch's avatar
Francesc Guasch committed
515
        my $req = Ravada::Request->open($id);
516
517
        warn "executing request ".$req->id." ".$req->status()." ".$req->command
            ." ".Dumper($req->args) if $DEBUG || $debug;
Francesc Guasch's avatar
Francesc Guasch committed
518
519
520

        my ($n_retry) = $req->status() =~ /retry (\d+)/;
        $n_retry = 0 if !$n_retry;
521
        $req->status('working');
522
        eval { $self->_execute($req, $dont_fork) };
523
        my $err = $@;
524
        $req->error($err or '');
525
        if ($err =~ /libvirt error code: 38/) {
Francesc Guasch's avatar
Francesc Guasch committed
526
            if ( $n_retry < 3) {
527
                warn $req->id." ".$req->command." to retry" if $DEBUG;
Francesc Guasch's avatar
Francesc Guasch committed
528
                $req->status("retry ".++$n_retry)   
529
530
531
            }
            $self->_refresh_vm_kvm();
        } else {
532
            $req->status('done');
533
        }
534
535
536
        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
537
538

        $self->_refresh_vm_kvm() if $req->command =~ /create|remove/i;
539
540
541
542
    }
    $sth->finish;
}

543
544
sub _process_requests_dont_fork {
    my $self = shift;
545
    my $debug = shift;
546
    return $self->process_requests($debug, 1);
547
}
Francesc Guasch's avatar
Francesc Guasch committed
548

549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
=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;
}

566
567
568
sub _execute {
    my $self = shift;
    my $request = shift;
569
    my $dont_fork = shift;
570

Francesc Guasch's avatar
Francesc Guasch committed
571
572
573
574
575
    my $sub = $self->_req_method($request->command);

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

576
    return $sub->($self,$request, $dont_fork);
Francesc Guasch's avatar
Francesc Guasch committed
577
578
579

}

580
581
582
583
584
585
586
587
588
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});
589
    my $user = Ravada::Auth::SQL->search_by_id( $request->args->{uid});
590
    $request->error('');
591
    my $display = $domain->display($user);
592
593
594
595
    $request->result({display => $display});

    $request->status('done');

596
597
}

598
sub _do_cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
599
600
601
    my $self = shift;
    my $request = shift;

602
    $request->status('creating domain');
603
    warn "$$ creating domain"   if $DEBUG;
604
    my $domain;
605
    $domain = $self->create_domain(%{$request->args},request => $request);
606

Francesc Guasch's avatar
Francesc Guasch committed
607
608
609
610
    $request->status('done');

}

611
612
613
614
615
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

618
    warn "Kid $kid finished"    if $DEBUG;
619
620
621
    delete $self->{pids}->{$kid};
}

Francesc Guasch's avatar
Francesc Guasch committed
622
623
624
625
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
628
    for my $pid ( keys %{$self->{pids}}) {
629
630
631
        $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
632
633
        my $kid = waitpid($pid,0);

634
#        warn "Found $kid";
Francesc Guasch's avatar
Francesc Guasch committed
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
        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;
650
651
652
653
    my $dont_fork = shift;

    return $self->_do_cmd_create($request)
        if $dont_fork;
Francesc Guasch's avatar
Francesc Guasch committed
654
655
656
657
658
659
660
661
662
663
664
665


    $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 ) {
666
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
667
668
669
        exit;
    }
    $self->_add_pid($pid);
670

Francesc Guasch's avatar
Francesc Guasch committed
671
672
673
    return;
}

Francesc Guasch's avatar
Francesc Guasch committed
674
sub _do_cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
675
676
677
678
    my $self = shift;
    my $request = shift;

    $request->status('working');
679
680
681
682
    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
683

684
}
Francesc Guasch's avatar
Francesc Guasch committed
685

Francesc Guasch's avatar
Francesc Guasch committed
686
687
688
689
690
691
sub _cmd_remove {
    my $self = shift;
    my $request = shift;
    my $dont_fork = shift;

    return $self->_do_cmd_remove($request)
692
        if $dont_fork || !$CAN_FORK;
Francesc Guasch's avatar
Francesc Guasch committed
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711

    $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
712
713
714
715
716
717
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
718
719
720
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
    $domain->start();
721

Francesc Guasch's avatar
Francesc Guasch committed
722
723
724
725
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
726
727
728
729
730
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
731
732
733
734
735
736
737
738
739
740
    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
741
742
743
744

}


Francesc Guasch's avatar
Francesc Guasch committed
745
746
747
748
749
750
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

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

753
    my $domain;
754
755
756
757
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

    $domain->shutdown(timeout => $timeout);
Francesc Guasch's avatar
Francesc Guasch committed
758
759
760

}

761
762
763
764
765
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
766
    $request->result(\@list_types);
767
768
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
769

770
771
772
773
774
775
776
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
778
779
780
781
782
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
784
785
786
          start => \&_cmd_start
        ,create => \&_cmd_create
        ,remove => \&_cmd_remove
Francesc Guasch's avatar
Francesc Guasch committed
787
      ,shutdown => \&_cmd_shutdown
788
    ,domdisplay => \&_cmd_domdisplay
789
  ,ping_backend => \&_cmd_ping_backend
Francesc Guasch's avatar
Francesc Guasch committed
790
  ,prepare_base => \&_cmd_prepare_base
791
 ,list_vm_types => \&_cmd_list_vm_types
Francesc Guasch's avatar
Francesc Guasch committed
792
793
794
795
    );
    return $methods{$cmd};
}

796
797
798
799
800
801
802
803
804
805
806
807
=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;

808
809
    confess "Missing VM type"   if !$type;

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

812
    if ($type =~ /Void/i) {
813
814
815
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
816
817
    my @vms;
    eval { @vms = @{$self->vm} };
818
819
820
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
821
    for my $vm (@vms) {
822
823
824
825
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
826

Francesc Guasch's avatar
Francesc Guasch committed
827
828
829
830
831
832
833
834
835
836
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

837
1;