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::Void;
18

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

Ravada - Remove Virtual Desktop Manager

=head1 SYNOPSIS

  use Ravada;

  my $ravada = Ravada->new()

=cut

31
32
33
34
35
36
37

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

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

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


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

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

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

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

Internal constructor

=cut


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

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

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
86
87
    my $db = ( $CONFIG->{db}->{db} or 'ravada' );
    return DBIx::Connector->new("DBI:$driver:$db"
88
89
90
91
92
93
94
                        ,$db_user,$db_pass,{RaiseError => 1
                        , PrintError=> 0 });

}

sub _init_config {
    my $file = shift;
95
96

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

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

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

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

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

    my $vm_kvm;
112

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

    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
125
126
    $err_kvm .= ($@ or '');
    return ($vm_kvm,$err_kvm);
127
128
}

129
130
sub _refresh_vm_kvm {
    my $self = shift;
Francesc Guasch's avatar
Francesc Guasch committed
131
    sleep 1;
132
133
134
135
136
137
    my @vms;
    eval { @vms = $self->vm };
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

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

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

    my @vms = ();

    my ($vm_kvm, $err_kvm) = $self->_create_vm_kvm();
Francesc Guasch's avatar
Francesc Guasch committed
154
    warn $err_kvm if $err_kvm;
155

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
sub _check_vms {
171
172
    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

434
435
436
=pod

sub _list_images_lxc {
fv3rdugo's avatar
fv3rdugo committed
437
438
439
    my $self = shift;
    my @domains;
    my $sth = $CONNECTOR->dbh->prepare(
440
        "SELECT * FROM lxc_templates ORDER BY name"
fv3rdugo's avatar
fv3rdugo committed
441
442
443
444
445
446
447
448
449
    );
    $sth->execute;
    while (my $row = $sth->fetchrow_hashref) {
        push @domains,($row);
    }
    $sth->finish;
    return @domains;
}

450
sub _list_images_data_lxc {
fv3rdugo's avatar
fv3rdugo committed
451
452
453
454
455
456
457
458
    my $self = shift;
    my @data;
    for ($self->list_images_lxc ) {
        push @data,{ id => $_->{id} , name => $_->{name} };
    }
    return \@data;
}

459
=cut
fv3rdugo's avatar
fv3rdugo committed
460

Francesc Guasch's avatar
Francesc Guasch committed
461
462
463
464
=head2 remove_volume

  $ravada->remove_volume($file);

Francesc Guasch's avatar
Francesc Guasch committed
465

Francesc Guasch's avatar
Francesc Guasch committed
466
467
=cut

468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
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";
    }

}
488

Francesc Guasch's avatar
Francesc Guasch committed
489
490
491
492
493
494
495
496
=head2 process_requests

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

  $ravada->process_requests();

=cut

497
498
sub process_requests {
    my $self = shift;
499
    my $debug = shift;
500
    my $dont_fork = shift;
Francesc Guasch's avatar
Francesc Guasch committed
501
    $dont_fork = 1 if !$CAN_FORK;
502

503
    $self->_wait_pids_nohang();
504
    $self->_check_vms();
505

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

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

        $self->_refresh_vm_kvm() if $req->command =~ /create|remove/i;
535
536
537
538
    }
    $sth->finish;
}

539
540
sub _process_requests_dont_fork {
    my $self = shift;
541
    my $debug = shift;
542
    return $self->process_requests($debug, 1);
543
}
Francesc Guasch's avatar
Francesc Guasch committed
544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
=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;
}

562
563
564
sub _execute {
    my $self = shift;
    my $request = shift;
565
    my $dont_fork = shift;
566

Francesc Guasch's avatar
Francesc Guasch committed
567
568
569
570
571
    my $sub = $self->_req_method($request->command);

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

572
    return $sub->($self,$request, $dont_fork);
Francesc Guasch's avatar
Francesc Guasch committed
573
574
575

}

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

    $request->status('done');

592
593
}

594
sub _do_cmd_create{
Francesc Guasch's avatar
Francesc Guasch committed
595
596
597
    my $self = shift;
    my $request = shift;

598
    $request->status('creating domain');
599
    warn "$$ creating domain"   if $DEBUG;
600
    my $domain;
601
    $domain = $self->create_domain(%{$request->args},request => $request);
602

Francesc Guasch's avatar
Francesc Guasch committed
603
604
605
606
    $request->status('done');

}

607
608
609
610
611
sub _wait_pids_nohang {
    my $self = shift;
    return if !keys %{$self->{pids}};

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

614
    warn "Kid $kid finished"    if $DEBUG;
615
616
617
    delete $self->{pids}->{$kid};
}

Francesc Guasch's avatar
Francesc Guasch committed
618
619
620
621
sub _wait_pids {
    my $self = shift;
    my $request = shift;

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

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

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

    return $self->_do_cmd_create($request)
        if $dont_fork;
Francesc Guasch's avatar
Francesc Guasch committed
650
651
652
653
654
655
656
657
658
659
660
661


    $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 ) {
662
        $self->_do_cmd_create($request);
Francesc Guasch's avatar
Francesc Guasch committed
663
664
665
        exit;
    }
    $self->_add_pid($pid);
666

Francesc Guasch's avatar
Francesc Guasch committed
667
668
669
    return;
}

Francesc Guasch's avatar
Francesc Guasch committed
670
sub _do_cmd_remove {
Francesc Guasch's avatar
Francesc Guasch committed
671
672
673
674
    my $self = shift;
    my $request = shift;

    $request->status('working');
675
676
677
678
    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
679

680
}
Francesc Guasch's avatar
Francesc Guasch committed
681

Francesc Guasch's avatar
Francesc Guasch committed
682
683
684
685
686
687
sub _cmd_remove {
    my $self = shift;
    my $request = shift;
    my $dont_fork = shift;

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

    $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
708
709
710
711
712
713
sub _cmd_start {
    my $self = shift;
    my $request = shift;

    $request->status('working');
    my $name = $request->args('name');
714
715
716
    my $domain = $self->search_domain($name);
    die "Unknown domain '$name'" if !$domain;
    $domain->start();
717

Francesc Guasch's avatar
Francesc Guasch committed
718
719
720
721
    $request->status('done');

}

Francesc Guasch's avatar
Francesc Guasch committed
722
723
724
725
726
sub _cmd_prepare_base {
    my $self = shift;
    my $request = shift;

    $request->status('working');
727
728
729
730
731
732
733
734
735
736
    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
737
738
739
740

}


Francesc Guasch's avatar
Francesc Guasch committed
741
742
743
744
745
746
sub _cmd_shutdown {
    my $self = shift;
    my $request = shift;

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

749
    my $domain;
750
751
752
753
    $domain = $self->search_domain($name);
    die "Unknown domain '$name'\n" if !$domain;

    $domain->shutdown(timeout => $timeout);
Francesc Guasch's avatar
Francesc Guasch committed
754
755
756

}

757
758
759
760
761
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
762
    $request->result(\@list_types);
763
764
    $request->status('done');
}
Francesc Guasch's avatar
Francesc Guasch committed
765

766
767
768
769
770
771
772
sub _cmd_ping_backend {
    my $self = shift;
    my $request = shift;

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

Francesc Guasch's avatar
Francesc Guasch committed
774
775
776
777
778
sub _req_method {
    my $self = shift;
    my  $cmd = shift;

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

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

792
793
794
795
796
797
798
799
800
801
802
803
=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;

804
805
    confess "Missing VM type"   if !$type;

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

808
    if ($type =~ /Void/i) {
809
810
811
        return Ravada::VM::Void->new();
    }

Francesc Guasch's avatar
Francesc Guasch committed
812
813
    my @vms;
    eval { @vms = @{$self->vm} };
814
815
816
    return if $@ && $@ =~ /No VMs found/i;
    die $@ if $@;

Francesc Guasch's avatar
Francesc Guasch committed
817
    for my $vm (@vms) {
818
819
820
821
        return $vm if ref($vm) eq $class;
    }
    return;
}
Francesc Guasch's avatar
Francesc Guasch committed
822

Francesc Guasch's avatar
Francesc Guasch committed
823
824
825
826
827
828
829
830
831
832
=head1 AUTHOR

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

=head1 SEE ALSO

Sys::Virt

=cut

833
1;