]>
git.proxmox.com Git - qemu-server.git/blob - PVE/QemuServer.pm
1 package PVE
:: QemuServer
;
20 use Storable
qw(dclone) ;
21 use PVE
:: Exception
qw(raise raise_param_exc) ;
23 use PVE
:: Tools
qw(run_command lock_file file_read_firstline) ;
24 use PVE
:: Cluster
qw(cfs_register_file cfs_read_file cfs_write_file cfs_lock_file) ;
27 use Time
:: HiRes qw
( gettimeofday
);
29 my $clock_ticks = POSIX
:: sysconf
(& POSIX
:: _SC_CLK_TCK
);
31 # Note about locking: we use flock on the config file protect
32 # against concurent actions.
33 # Aditionaly, we have a 'lock' setting in the config file. This
34 # can be set to 'migrate' or 'backup'. Most actions are not
35 # allowed when such lock is set. But you can ignore this kind of
36 # lock with the --skiplock flag.
38 cfs_register_file
( '/qemu-server/' , \
& parse_vm_config
);
40 #no warnings 'redefine';
42 unless ( defined (& _VZSYSCALLS_H_
)) {
43 eval 'sub _VZSYSCALLS_H_ () {1;}' unless defined (& _VZSYSCALLS_H_
);
44 require 'sys/syscall.ph' ;
45 if ( defined (& __x86_64__
)) {
46 eval 'sub __NR_fairsched_vcpus () {499;}' unless defined (& __NR_fairsched_vcpus
);
47 eval 'sub __NR_fairsched_mknod () {504;}' unless defined (& __NR_fairsched_mknod
);
48 eval 'sub __NR_fairsched_rmnod () {505;}' unless defined (& __NR_fairsched_rmnod
);
49 eval 'sub __NR_fairsched_chwt () {506;}' unless defined (& __NR_fairsched_chwt
);
50 eval 'sub __NR_fairsched_mvpr () {507;}' unless defined (& __NR_fairsched_mvpr
);
51 eval 'sub __NR_fairsched_rate () {508;}' unless defined (& __NR_fairsched_rate
);
52 eval 'sub __NR_setluid () {501;}' unless defined (& __NR_setluid
);
53 eval 'sub __NR_setublimit () {502;}' unless defined (& __NR_setublimit
);
55 elsif ( defined ( & __i386__
) ) {
56 eval 'sub __NR_fairsched_mknod () {500;}' unless defined (& __NR_fairsched_mknod
);
57 eval 'sub __NR_fairsched_rmnod () {501;}' unless defined (& __NR_fairsched_rmnod
);
58 eval 'sub __NR_fairsched_chwt () {502;}' unless defined (& __NR_fairsched_chwt
);
59 eval 'sub __NR_fairsched_mvpr () {503;}' unless defined (& __NR_fairsched_mvpr
);
60 eval 'sub __NR_fairsched_rate () {504;}' unless defined (& __NR_fairsched_rate
);
61 eval 'sub __NR_fairsched_vcpus () {505;}' unless defined (& __NR_fairsched_vcpus
);
62 eval 'sub __NR_setluid () {511;}' unless defined (& __NR_setluid
);
63 eval 'sub __NR_setublimit () {512;}' unless defined (& __NR_setublimit
);
65 die ( "no fairsched syscall for this arch" );
67 require 'asm/ioctl.ph' ;
68 eval 'sub KVM_GET_API_VERSION () { &_IO(0xAE, 0x);}' unless defined (& KVM_GET_API_VERSION
);
72 my ( $parent, $weight, $desired ) = @_ ;
74 return syscall (& __NR_fairsched_mknod
, int ( $parent ), int ( $weight ), int ( $desired ));
80 return syscall (& __NR_fairsched_rmnod
, int ( $id ));
84 my ( $pid, $newid ) = @_ ;
86 return syscall (& __NR_fairsched_mvpr
, int ( $pid ), int ( $newid ));
90 my ( $id, $vcpus ) = @_ ;
92 return syscall (& __NR_fairsched_vcpus
, int ( $id ), int ( $vcpus ));
96 my ( $id, $op, $rate ) = @_ ;
98 return syscall (& __NR_fairsched_rate
, int ( $id ), int ( $op ), int ( $rate ));
101 use constant FAIRSCHED_SET_RATE
=> 0 ;
102 use constant FAIRSCHED_DROP_RATE
=> 1 ;
103 use constant FAIRSCHED_GET_RATE
=> 2 ;
105 sub fairsched_cpulimit
{
106 my ( $id, $limit ) = @_ ;
108 my $cpulim1024 = int ( $limit * 1024 / 100 );
109 my $op = $cpulim1024 ? FAIRSCHED_SET_RATE
: FAIRSCHED_DROP_RATE
;
111 return fairsched_rate
( $id, $op, $cpulim1024 );
114 my $nodename = PVE
:: INotify
:: nodename
();
116 mkdir "/etc/pve/nodes/ $nodename " ;
117 my $confdir = "/etc/pve/nodes/ $nodename/qemu -server" ;
120 my $var_run_tmpdir = "/var/run/qemu-server" ;
121 mkdir $var_run_tmpdir ;
123 my $lock_dir = "/var/lock/qemu-server" ;
126 my $pcisysfs = "/sys/bus/pci" ;
128 my $keymaphash = PVE
:: Tools
:: kvmkeymaps
();
134 description
=> "Specifies whether a VM will be started during system bootup." ,
140 description
=> "Automatic restart after crash (currently ignored)." ,
146 description
=> "Allow reboot. If set to '0' the VM exit on reboot." ,
152 description
=> "Lock/unlock the VM." ,
153 enum
=> [ qw(migrate backup) ],
158 description
=> "Limit of CPU usage in per cent. Note if the computer has 2 CPUs, it has total of 200% CPU time. Value '0' indicates no CPU limit. \n\n NOTE: This option is currently ignored." ,
165 description
=> "CPU weight for a VM. Argument is used in the kernel fair scheduler. The larger the number is, the more CPU time this VM gets. Number is relative to weights of all the other running VMs. \n\n NOTE: You can disable fair-scheduler configuration by setting this to 0." ,
173 description
=> "Amount of RAM for the VM in MB." ,
180 description
=> "Keybord layout for vnc server. Default is read from the datacenter configuration file." ,
181 enum
=> [ keys %$keymaphash ],
187 description
=> "Set a name for the VM. Only used on the configuration web interface." ,
192 description
=> "Description for the VM. Only used on the configuration web interface." ,
197 enum
=> [ qw(other wxp w2k w2k3 w2k8 wvista win7 l24 l26) ],
198 description
=> <<EODESC,
199 Used to enable special optimization/features for specific
202 other => unspecified OS
203 wxp => Microsoft Windows XP
204 w2k => Microsoft Windows 2000
205 w2k3 => Microsoft Windows 2003
206 w2k8 => Microsoft Windows 2008
207 wvista => Microsoft Windows Vista
208 win7 => Microsoft Windows 7
209 l24 => Linux 2.4 Kernel
210 l26 => Linux 2.6/3.X Kernel
212 other|l24|l26 ... no special behaviour
213 wxp|w2k|w2k3|w2k8|wvista|win7 ... use --localtime switch
219 description
=> "Boot on floppy (a), hard disk (c), CD-ROM (d), or network (n)." ,
220 pattern
=> '[acdn]{1,4}' ,
225 type
=> 'string' , format
=> 'pve-qm-bootdisk' ,
226 description
=> "Enable booting from specified disk." ,
227 pattern
=> '(ide|scsi|virtio)\d+' ,
232 description
=> "The number of CPUs. Please use option -sockets instead." ,
239 description
=> "The number of CPU sockets." ,
246 description
=> "The number of cores per socket." ,
253 description
=> "Enable/disable ACPI." ,
259 description
=> "Enable/disable KVM hardware virtualization." ,
265 description
=> "Enable/disable time drift fix." ,
271 description
=> "Set the real time clock to local time. This is enabled by default if ostype indicates a Microsoft OS." ,
276 description
=> "Freeze CPU at startup (use 'c' monitor command to start execution)." ,
281 description
=> "Select VGA type. If you want to use high resolution modes (>= 1280x1024x16) then you should use option 'std' or 'vmware'. Default is 'std' for win7/w2k8, and 'cirrur' for other OS types" ,
282 enum
=> [ qw(std cirrus vmware) ],
286 type
=> 'string' , format
=> 'pve-qm-hostpci' ,
287 typetext
=> "HOSTPCIDEVICE { , HOSTPCIDEVICE }" ,
288 description
=> <<EODESCR,
289 Map host pci devices. HOSTPCIDEVICE syntax is:
291 'bus:dev.func' (hexadecimal numbers)
293 You can us the 'lspci' command to list existing pci devices.
295 Note: This option allows direct access to host hardware. So it is no longer possible to migrate such machines - use with special care.
297 Experimental: user reported problems with this option.
302 type
=> 'string' , format
=> 'pve-qm-serial' ,
303 typetext
=> "SERIALDEVICE { , SERIALDEVICE }" ,
304 description
=> <<EODESCR,
305 Map host serial devices. SERIALDEVICE syntax is /dev/ttyS*
307 Note: This option allows direct access to host hardware. So it is no longer possible to migrate such machines - use with special care.
309 Experimental: user reported problems with this option.
314 type
=> 'string' , format
=> 'pve-qm-parallel' ,
315 typetext
=> "PARALLELDEVICE { , PARALLELDEVICE }" ,
316 description
=> <<EODESCR,
317 Map host parallel devices. PARALLELDEVICE syntax is /dev/parport*
319 Note: This option allows direct access to host hardware. So it is no longer possible to migrate such machines - use with special care.
321 Experimental: user reported problems with this option.
327 typetext
=> "(now | YYYY-MM-DD | YYYY-MM-DDTHH:MM:SS)" ,
328 description
=> "Set the initial date of the real time clock. Valid format for date are: 'now' or '2006-06-17T16:01:21' or '2006-06-17'." ,
329 pattern
=> '(now|\d{4}-\d{1,2}-\d{1,2}(T\d{1,2}:\d{1,2}:\d{1,2})?)' ,
335 description
=> <<EODESCR,
336 Note: this option is for experts only. It allows you to pass arbitrary arguments to kvm, for example:
338 args: -no-reboot -no-hpet
345 description
=> "Enable/disable the usb tablet device. This device is usually needed to allow absolute mouse positioning. Else the mouse runs out of sync with normal vnc clients. If you're running lots of console-only guests on one host, you may consider disabling this to save some context switches." ,
350 description
=> "Set maximum speed (in MB/s) for migrations. Value 0 is no limit." ,
354 migrate_downtime
=> {
357 description
=> "Set maximum tolerated downtime (in seconds) for migrations." ,
363 type
=> 'string' , format
=> 'pve-qm-drive' ,
364 typetext
=> 'volume' ,
365 description
=> "This is an alias for option -ide2" ,
369 description
=> "Emulated CPU type." ,
371 enum
=> [ qw(486 athlon pentium pentium2 pentium3 coreduo core2duo kvm32 kvm64 qemu32 qemu64 phenom host) ],
376 # what about other qemu settings ?
378 #machine => 'string',
391 ##soundhw => 'string',
393 while ( my ( $k, $v ) = each %$confdesc ) {
394 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm- $k " , $v );
397 my $MAX_IDE_DISKS = 4 ;
398 my $MAX_SCSI_DISKS = 16 ;
399 my $MAX_VIRTIO_DISKS = 16 ;
400 my $MAX_USB_DEVICES = 5 ;
402 my $MAX_UNUSED_DISKS = 8 ;
404 my $nic_model_list = [ 'rtl8139' , 'ne2k_pci' , 'e1000' , 'pcnet' , 'virtio' ,
405 'ne2k_isa' , 'i82551' , 'i82557b' , 'i82559er' ];
406 my $nic_model_list_txt = join ( ' ' , sort @$nic_model_list );
411 type
=> 'string' , format
=> 'pve-qm-net' ,
412 typetext
=> "MODEL=XX:XX:XX:XX:XX:XX [,bridge=<dev>][,rate=<mbps>]" ,
413 description
=> <<EODESCR,
414 Specify network devices.
416 MODEL is one of: $nic_model_list_txt
418 XX:XX:XX:XX:XX:XX should be an unique MAC address. This is
419 automatically generated if not specified.
421 The bridge parameter can be used to automatically add the interface to a bridge device. The Proxmox VE standard bridge is called 'vmbr0'.
423 Option 'rate' is used to limit traffic bandwidth from and to this interface. It is specified as floating point number, unit is 'Megabytes per second'.
425 If you specify no bridge, we create a kvm 'user' (NATed) network device, which provides DHCP and DNS services. The following addresses are used:
431 The DHCP server assign addresses to the guest starting from 10.0.2.15.
435 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm-net" , $netdesc );
437 for ( my $i = 0 ; $i < $MAX_NETS ; $i++ ) {
438 $confdesc ->{ "net $i " } = $netdesc ;
445 type
=> 'string' , format
=> 'pve-qm-drive' ,
446 typetext
=> '[volume=]volume,] [,media=cdrom|disk] [,cyls=c,heads=h,secs=s[,trans=t]] [,snapshot=on|off] [,cache=none|writethrough|writeback] [,format=f] [,backup=yes|no] [,aio=native|threads]' ,
447 description
=> "Use volume as IDE hard disk or CD-ROM (n is 0 to 3)." ,
449 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm-ide" , $idedesc );
453 type
=> 'string' , format
=> 'pve-qm-drive' ,
454 typetext
=> '[volume=]volume,] [,media=cdrom|disk] [,cyls=c,heads=h,secs=s[,trans=t]] [,snapshot=on|off] [,cache=none|writethrough|writeback] [,format=f] [,backup=yes|no] [,aio=native|threads]' ,
455 description
=> "Use volume as SCSI hard disk or CD-ROM (n is 0 to 15)." ,
457 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm-scsi" , $scsidesc );
461 type
=> 'string' , format
=> 'pve-qm-drive' ,
462 typetext
=> '[volume=]volume,] [,media=cdrom|disk] [,cyls=c,heads=h,secs=s[,trans=t]] [,snapshot=on|off] [,cache=none|writethrough|writeback] [,format=f] [,backup=yes|no] [,aio=native|threads]' ,
463 description
=> "Use volume as VIRTIO hard disk (n is 0 to 15)." ,
465 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm-virtio" , $virtiodesc );
469 type
=> 'string' , format
=> 'pve-qm-usb-device' ,
470 typetext
=> 'host=HOSTUSBDEVICE' ,
471 description
=> <<EODESCR,
472 Configure an USB device (n is 0 to 5). This can be used to
473 pass-through usb devices to the guest. HOSTUSBDEVICE syntax is:
475 'bus-port(.port)*' (decimal numbers) or
476 'vendor_id:product_id' (hexadeciaml numbers)
478 You can use the 'lsusb -t' command to list existing usb devices.
480 Note: This option allows direct access to host hardware. So it is no longer possible to migrate such machines - use with special care.
484 PVE
:: JSONSchema
:: register_standard_option
( "pve-qm-usb" , $usbdesc );
487 for ( my $i = 0 ; $i < $MAX_IDE_DISKS ; $i++ ) {
488 $drivename_hash ->{ "ide $i " } = 1 ;
489 $confdesc ->{ "ide $i " } = $idedesc ;
492 for ( my $i = 0 ; $i < $MAX_SCSI_DISKS ; $i++ ) {
493 $drivename_hash ->{ "scsi $i " } = 1 ;
494 $confdesc ->{ "scsi $i " } = $scsidesc ;
497 for ( my $i = 0 ; $i < $MAX_VIRTIO_DISKS ; $i++ ) {
498 $drivename_hash ->{ "virtio $i " } = 1 ;
499 $confdesc ->{ "virtio $i " } = $virtiodesc ;
502 for ( my $i = 0 ; $i < $MAX_USB_DEVICES ; $i++ ) {
503 $confdesc ->{ "usb $i " } = $usbdesc ;
508 type
=> 'string' , format
=> 'pve-volume-id' ,
509 description
=> "Reference to unused volumes." ,
512 for ( my $i = 0 ; $i < $MAX_UNUSED_DISKS ; $i++ ) {
513 $confdesc ->{ "unused $i " } = $unuseddesc ;
516 my $kvm_api_version = 0 ;
520 return $kvm_api_version if $kvm_api_version ;
522 my $fh = IO
:: File-
> new ( "</dev/kvm" ) ||
525 if ( my $v = $fh -> ioctl ( KVM_GET_API_VERSION
(), 0 )) {
526 $kvm_api_version = $v ;
531 return $kvm_api_version ;
534 my $kvm_user_version ;
536 sub kvm_user_version
{
538 return $kvm_user_version if $kvm_user_version ;
540 $kvm_user_version = 'unknown' ;
542 my $tmp = `kvm -help 2>/dev/null` ;
544 if ( $tmp =~ m/^QEMU( PC)? emulator version (\d+\.\d+\.\d+) / ) {
545 $kvm_user_version = $2 ;
548 return $kvm_user_version ;
552 my $kernel_has_vhost_net = - c
'/dev/vhost-net' ;
555 # order is important - used to autoselect boot disk
556 return (( map { "ide $_ " } ( 0 .. ( $MAX_IDE_DISKS - 1 ))),
557 ( map { "scsi $_ " } ( 0 .. ( $MAX_SCSI_DISKS - 1 ))),
558 ( map { "virtio $_ " } ( 0 .. ( $MAX_VIRTIO_DISKS - 1 ))));
561 sub valid_drivename
{
564 return defined ( $drivename_hash ->{ $dev });
569 return defined ( $confdesc ->{ $key });
573 return $nic_model_list ;
576 sub os_list_description
{
581 w2k
=> 'Windows 2000' ,
582 w2k3
=>, 'Windows 2003' ,
583 w2k8
=> 'Windows 2008' ,
584 wvista
=> 'Windows Vista' ,
591 # a clumsy way to split an argument string into an array,
592 # we simply pass it to the cli (exec call)
593 # fixme: use Text::ParseWords::shellwords() ?
599 return $args if ! $str ;
601 my $cmd = 'perl -e \' foreach my $a ( @ARGV ) { print " $a\n "; } \' -- ' . $str ;
604 run_command
( $cmd, outfunc
=> sub {
612 die "unable to parse args: $str\n " if $err ;
617 sub disk_devive_info
{
620 die "unknown disk device format ' $dev '" if $dev !~ m/^(ide|scsi|virtio)(\d+)$/ ;
628 } elsif ( $bus eq 'scsi' ) {
632 my $controller = int ( $index / $maxdev );
633 my $unit = $index % $maxdev ;
636 return { bus
=> $bus, desc
=> uc ( $bus ) . " $controller : $unit " ,
637 controller
=> $controller, unit
=> $unit, index => $index };
641 sub qemu_drive_name
{
642 my ( $dev, $media ) = @_ ;
644 my $info = disk_devive_info
( $dev );
647 if (( $info ->{ bus
} eq 'ide' ) || ( $info ->{ bus
} eq 'scsi' )) {
648 $mediastr = ( $media eq 'cdrom' ) ?
"-cd" : "-hd" ;
649 return sprintf ( " %s%i%s%i " , $info ->{ bus
}, $info ->{ controller
},
650 $mediastr, $info ->{ unit
});
652 return sprintf ( " %s%i " , $info ->{ bus
}, $info ->{ index });
660 return $cdrom_path if $cdrom_path ;
662 return $cdrom_path = "/dev/cdrom" if - l
"/dev/cdrom" ;
663 return $cdrom_path = "/dev/cdrom1" if - l
"/dev/cdrom1" ;
664 return $cdrom_path = "/dev/cdrom2" if - l
"/dev/cdrom2" ;
668 my ( $storecfg, $vmid, $cdrom ) = @_ ;
670 if ( $cdrom eq 'cdrom' ) {
671 return get_cdrom_path
();
672 } elsif ( $cdrom eq 'none' ) {
674 } elsif ( $cdrom =~ m
|^/|) {
677 return PVE
:: Storage
:: path
( $storecfg, $cdrom );
681 # try to convert old style file names to volume IDs
682 sub filename_to_volume_id
{
683 my ( $vmid, $file, $media ) = @_ ;
685 if (!( $file eq 'none' || $file eq 'cdrom' ||
686 $file =~ m
|^ /dev/ .+| || $file =~ m/^([^:]+):(.+)$/ )) {
688 return undef if $file =~ m
|/|;
690 if ( $media && $media eq 'cdrom' ) {
691 $file = "local:iso/ $file " ;
693 $file = "local: $vmid/$file " ;
700 sub verify_media_type
{
701 my ( $opt, $vtype, $media ) = @_ ;
706 if ( $media eq 'disk' ) {
708 } elsif ( $media eq 'cdrom' ) {
711 die "internal error" ;
714 return if ( $vtype eq $etype );
716 raise_param_exc
({ $opt => "unexpected media type ( $vtype != $etype )" });
719 sub cleanup_drive_path
{
720 my ( $opt, $storecfg, $drive ) = @_ ;
722 # try to convert filesystem paths to volume IDs
724 if (( $drive ->{ file
} !~ m/^(cdrom|none)$/ ) &&
725 ( $drive ->{ file
} !~ m
|^ /dev/ .+|) &&
726 ( $drive ->{ file
} !~ m/^([^:]+):(.+)$/ ) &&
727 ( $drive ->{ file
} !~ m/^\d+$/ )) {
728 my ( $vtype, $volid ) = PVE
:: Storage
:: path_to_volume_id
( $storecfg, $drive ->{ file
});
729 raise_param_exc
({ $opt => "unable to associate path ' $drive ->{file}' to any storage" }) if ! $vtype ;
730 $drive ->{ media
} = 'cdrom' if ! $drive ->{ media
} && $vtype eq 'iso' ;
731 verify_media_type
( $opt, $vtype, $drive ->{ media
});
732 $drive ->{ file
} = $volid ;
735 $drive ->{ media
} = 'cdrom' if ! $drive ->{ media
} && $drive ->{ file
} =~ m/^(cdrom|none)$/ ;
738 sub create_conf_nolock
{
739 my ( $vmid, $settings ) = @_ ;
741 my $filename = config_file
( $vmid );
743 die "configuration file ' $filename ' already exists \n " if - f
$filename ;
745 my $defaults = load_defaults
();
747 $settings ->{ name
} = "vm $vmid " if ! $settings ->{ name
};
748 $settings ->{ memory
} = $defaults ->{ memory
} if ! $settings ->{ memory
};
751 foreach my $opt ( keys %$settings ) {
752 next if ! $confdesc ->{ $opt };
754 my $value = $settings ->{ $opt };
757 $data .= " $opt : $value\n " ;
760 PVE
:: Tools
:: file_set_contents
( $filename, $data );
763 # ideX = [volume=]volume-id[,media=d][,cyls=c,heads=h,secs=s[,trans=t]]
764 # [,snapshot=on|off][,cache=on|off][,format=f][,backup=yes|no]
765 # [,aio=native|threads]
768 my ( $key, $data ) = @_ ;
772 # $key may be undefined - used to verify JSON parameters
773 if (! defined ( $key )) {
774 $res ->{ interface
} = 'unknown' ; # should not harm when used to verify parameters
776 } elsif ( $key =~ m/^([^\d]+)(\d+)$/ ) {
777 $res ->{ interface
} = $1 ;
783 foreach my $p ( split ( /,/ , $data )) {
784 next if $p =~ m/^\s*$/ ;
786 if ( $p =~ m/^(file|volume|cyls|heads|secs|trans|media|snapshot|cache|format|rerror|werror|backup|aio)=(.+)$/ ) {
787 my ( $k, $v ) = ( $1, $2 );
789 $k = 'file' if $k eq 'volume' ;
791 return undef if defined $res ->{ $k };
795 if (! $res ->{ file
} && $p !~ m/=/ ) {
803 return undef if ! $res ->{ file
};
805 return undef if $res ->{ cache
} &&
806 $res ->{ cache
} !~ m/^(off|none|writethrough|writeback)$/ ;
807 return undef if $res ->{ snapshot
} && $res ->{ snapshot
} !~ m/^(on|off)$/ ;
808 return undef if $res ->{ cyls
} && $res ->{ cyls
} !~ m/^\d+$/ ;
809 return undef if $res ->{ heads
} && $res ->{ heads
} !~ m/^\d+$/ ;
810 return undef if $res ->{ secs
} && $res ->{ secs
} !~ m/^\d+$/ ;
811 return undef if $res ->{ media
} && $res ->{ media
} !~ m/^(disk|cdrom)$/ ;
812 return undef if $res ->{ trans
} && $res ->{ trans
} !~ m/^(none|lba|auto)$/ ;
813 return undef if $res ->{ format
} && $res ->{ format
} !~ m/^(raw|cow|qcow|qcow2|vmdk|cloop)$/ ;
814 return undef if $res ->{ rerror
} && $res ->{ rerror
} !~ m/^(ignore|report|stop)$/ ;
815 return undef if $res ->{ werror
} && $res ->{ werror
} !~ m/^(enospc|ignore|report|stop)$/ ;
816 return undef if $res ->{ backup
} && $res ->{ backup
} !~ m/^(yes|no)$/ ;
817 return undef if $res ->{ aio
} && $res ->{ aio
} !~ m/^(native|threads)$/ ;
819 if ( $res ->{ media
} && ( $res ->{ media
} eq 'cdrom' )) {
820 return undef if $res ->{ snapshot
} || $res ->{ trans
} || $res ->{ format
};
821 return undef if $res ->{ heads
} || $res ->{ secs
} || $res ->{ cyls
};
822 return undef if $res ->{ interface
} eq 'virtio' ;
825 # rerror does not work with scsi drives
826 if ( $res ->{ rerror
}) {
827 return undef if $res ->{ interface
} eq 'scsi' ;
833 my @qemu_drive_options = qw(heads secs cyls trans media format cache snapshot rerror werror aio) ;
836 my ( $vmid, $drive ) = @_ ;
839 foreach my $o ( @qemu_drive_options, 'backup' ) {
840 $opts .= ", $o = $drive ->{ $o }" if $drive ->{ $o };
843 return " $drive ->{file} $opts " ;
846 sub print_drive_full
{
847 my ( $storecfg, $vmid, $drive ) = @_ ;
850 foreach my $o ( @qemu_drive_options ) {
851 $opts .= ", $o = $drive ->{ $o }" if $drive ->{ $o };
854 # use linux-aio by default (qemu default is threads)
855 $opts .= ",aio=native" if ! $drive ->{ aio
};
858 my $volid = $drive ->{ file
};
859 if ( drive_is_cdrom
( $drive )) {
860 $path = get_iso_path
( $storecfg, $vmid, $volid );
862 if ( $volid =~ m
|^/|) {
865 $path = PVE
:: Storage
:: path
( $storecfg, $volid );
869 my $pathinfo = $path ?
"file= $path, " : '' ;
871 return "${pathinfo}if= $drive ->{interface},index= $drive ->{index} $opts " ;
878 return $drive && $drive ->{ media
} && ( $drive ->{ media
} eq 'cdrom' );
882 # netX: e1000=XX:XX:XX:XX:XX:XX,bridge=vmbr0,rate=<mbps>
888 foreach my $kvp ( split ( /,/ , $data )) {
890 if ( $kvp =~ m/^(ne2k_pci|e1000|rtl8139|pcnet|virtio|ne2k_isa|i82551|i82557b|i82559er)(=([0-9a-f]{2}(:[0-9a-f]{2}){5}))?$/i ) {
892 my $mac = uc ( $3 ) || random_ether_addr
();
893 $res ->{ model
} = $model ;
894 $res ->{ macaddr
} = $mac ;
895 } elsif ( $kvp =~ m/^bridge=(\S+)$/ ) {
897 } elsif ( $kvp =~ m/^rate=(\d+(\.\d+)?)$/ ) {
905 return undef if ! $res ->{ model
};
913 my $res = " $net ->{model}" ;
914 $res .= "= $net ->{macaddr}" if $net ->{ macaddr
};
915 $res .= ",bridge= $net ->{bridge}" if $net ->{ bridge
};
916 $res .= ",rate= $net ->{rate}" if $net ->{ rate
};
921 sub add_random_macs
{
924 foreach my $opt ( keys %$settings ) {
925 next if $opt !~ m/^net(\d+)$/ ;
926 my $net = parse_net
( $settings ->{ $opt });
928 $settings ->{ $opt } = print_net
( $net );
932 sub add_unused_volume
{
933 my ( $config, $res, $volid ) = @_ ;
936 for ( my $ind = $MAX_UNUSED_DISKS - 1 ; $ind >= 0 ; $ind --) {
937 my $test = "unused $ind " ;
938 if ( my $vid = $config ->{ $test }) {
939 return if $vid eq $volid ; # do not add duplicates
945 die "To many unused volume - please delete them first. \n " if ! $key ;
947 $res ->{ $key } = $volid ;
950 # fixme: remove all thos $noerr parameters?
952 PVE
:: JSONSchema
:: register_format
( 'pve-qm-bootdisk' , \
& verify_bootdisk
);
953 sub verify_bootdisk
{
954 my ( $value, $noerr ) = @_ ;
956 return $value if valid_drivename
( $value );
958 return undef if $noerr ;
960 die "invalid boot disk ' $value ' \n " ;
963 PVE
:: JSONSchema
:: register_format
( 'pve-qm-net' , \
& verify_net
);
965 my ( $value, $noerr ) = @_ ;
967 return $value if parse_net
( $value );
969 return undef if $noerr ;
971 die "unable to parse network options \n " ;
974 PVE
:: JSONSchema
:: register_format
( 'pve-qm-drive' , \
& verify_drive
);
976 my ( $value, $noerr ) = @_ ;
978 return $value if parse_drive
( undef , $value );
980 return undef if $noerr ;
982 die "unable to parse drive options \n " ;
985 PVE
:: JSONSchema
:: register_format
( 'pve-qm-hostpci' , \
& verify_hostpci
);
987 my ( $value, $noerr ) = @_ ;
989 my @dl = split ( /,/ , $value );
990 foreach my $v ( @dl ) {
991 if ( $v !~ m/^[a-f0-9]{2}:[a-f0-9]{2}\.[a-f0-9]$/i ) {
992 return undef if $noerr ;
993 die "unable to parse pci id \n " ;
999 sub parse_usb_device
{
1002 return undef if ! $value ;
1004 my @dl = split ( /,/ , $value );
1008 foreach my $v ( @dl ) {
1009 if ( $v =~ m/^host=([0-9A-Fa-f]{4}):([0-9A-Fa-f]{4})$/ ) {
1011 $res ->{ vendorid
} = $1 ;
1012 $res ->{ productid
} = $2 ;
1013 } elsif ( $v =~ m/^host=(\d+)\-(\d+(\.\d+)*)$/ ) {
1015 $res ->{ hostbus
} = $1 ;
1016 $res ->{ hostport
} = $2 ;
1021 return undef if ! $found ;
1026 PVE
:: JSONSchema
:: register_format
( 'pve-qm-usb-device' , \
& verify_usb_device
);
1027 sub verify_usb_device
{
1028 my ( $value, $noerr ) = @_ ;
1030 return $value if parse_usb_device
( $value );
1032 return undef if $noerr ;
1034 die "unable to parse usb device \n " ;
1037 PVE
:: JSONSchema
:: register_format
( 'pve-qm-parallel' , \
& verify_parallel
);
1038 sub verify_parallel
{
1039 my ( $value, $noerr ) = @_ ;
1041 my @dl = split ( /,/ , $value );
1042 foreach my $v ( @dl ) {
1043 if ( $v !~ m
|^ /dev/pa rport\d
+$|) {
1044 return undef if $noerr ;
1045 die "invalid device name \n " ;
1051 PVE
:: JSONSchema
:: register_format
( 'pve-qm-serial' , \
& verify_serial
);
1053 my ( $value, $noerr ) = @_ ;
1055 my @dl = split ( /,/ , $value );
1056 foreach my $v ( @dl ) {
1057 if ( $v !~ m
|^ /dev/ ttyS\d
+$|) {
1058 return undef if $noerr ;
1059 die "invalid device name \n " ;
1065 # add JSON properties for create and set function
1066 sub json_config_properties
{
1069 foreach my $opt ( keys %$confdesc ) {
1070 $prop ->{ $opt } = $confdesc ->{ $opt };
1077 my ( $key, $value ) = @_ ;
1079 die "unknown setting ' $key ' \n " if ! $confdesc ->{ $key };
1081 my $type = $confdesc ->{ $key }->{ type
};
1083 if (! defined ( $value )) {
1084 die "got undefined value \n " ;
1087 if ( $value =~ m/[\n\r]/ ) {
1088 die "property contains a line feed \n " ;
1091 if ( $type eq 'boolean' ) {
1092 return 1 if ( $value eq '1' ) || ( $value =~ m/^(on|yes|true)$/i );
1093 return 0 if ( $value eq '0' ) || ( $value =~ m/^(off|no|false)$/i );
1094 die "type check ('boolean') failed - got ' $value ' \n " ;
1095 } elsif ( $type eq 'integer' ) {
1096 return int ( $1 ) if $value =~ m/^(\d+)$/ ;
1097 die "type check ('integer') failed - got ' $value ' \n " ;
1098 } elsif ( $type eq 'string' ) {
1099 if ( my $fmt = $confdesc ->{ $key }->{ format
}) {
1100 if ( $fmt eq 'pve-qm-drive' ) {
1101 # special case - we need to pass $key to parse_drive()
1102 my $drive = parse_drive
( $key, $value );
1103 return $value if $drive ;
1104 die "unable to parse drive options \n " ;
1106 PVE
:: JSONSchema
:: check_format
( $fmt, $value );
1109 $value =~ s/^\"(.*)\"$/$1/ ;
1112 die "internal error"
1117 my ( $vmid, $code, @param ) = @_ ;
1119 my $filename = config_file_lock
( $vmid );
1121 lock_file
( $filename, 10 , $code, @param );
1126 sub cfs_config_path
{
1129 return "nodes/ $nodename/qemu -server/ $vmid .conf" ;
1135 my $cfspath = cfs_config_path
( $vmid );
1136 return "/etc/pve/ $cfspath " ;
1139 sub config_file_lock
{
1142 return " $lock_dir/lock - $vmid .conf" ;
1148 my $conf = config_file
( $vmid );
1149 utime undef , undef , $conf ;
1153 my ( $storecfg, $vmid, $settings ) = @_ ;
1158 foreach_drive
( $settings, sub {
1159 my ( $ds, $disk ) = @_ ;
1161 return if drive_is_cdrom
( $disk );
1163 my $file = $disk ->{ file
};
1165 if ( $file =~ m/^(([^:\s]+):)?(\d+(\.\d+)?)$/ ) {
1166 my $storeid = $2 || 'local' ;
1168 my $defformat = PVE
:: Storage
:: storage_default_format
( $storecfg, $storeid );
1169 my $fmt = $disk ->{ format
} || $defformat ;
1170 syslog
( 'info' , "VM $vmid creating new disk - size is $size GB" );
1172 my $volid = PVE
:: Storage
:: vdisk_alloc
( $storecfg, $storeid, $vmid,
1173 $fmt, undef , $size*1024*1024 );
1175 $disk ->{ file
} = $volid ;
1176 delete ( $disk ->{ format
}); # no longer needed
1177 push @$vollist, $volid ;
1178 $settings ->{ $ds } = PVE
:: QemuServer
:: print_drive
( $vmid, $disk );
1181 if ( $disk ->{ file
} =~ m
|^ /dev/ .+|) {
1182 $path = $disk ->{ file
};
1184 $path = PVE
:: Storage
:: path
( $storecfg, $disk ->{ file
});
1186 if (!(- f
$path || - b
$path )) {
1187 die "image ' $path ' does not exists \n " ;
1196 syslog
( 'err' , "VM $vmid creating disks failed" );
1197 foreach my $volid ( @$vollist ) {
1198 eval { PVE
:: Storage
:: vdisk_free
( $storecfg, $volid ); };
1208 my ( $storecfg, $vmid, $volid ) = @_ ;
1210 die "reject to unlink absolute path ' $volid '"
1213 my ( $path, $owner ) = PVE
:: Storage
:: path
( $storecfg, $volid );
1215 die "reject to unlink ' $volid ' - not owned by this VM"
1216 if ! $owner || ( $owner != $vmid );
1218 syslog
( 'info' , "VM $vmid deleting volume ' $volid '" );
1220 PVE
:: Storage
:: vdisk_free
( $storecfg, $volid );
1222 touch_config
( $vmid );
1226 my ( $storecfg, $vmid ) = @_ ;
1228 my $conffile = config_file
( $vmid );
1230 my $conf = load_config
( $vmid );
1234 # only remove disks owned by this VM
1235 foreach_drive
( $conf, sub {
1236 my ( $ds, $drive ) = @_ ;
1238 return if drive_is_cdrom
( $drive );
1240 my $volid = $drive ->{ file
};
1241 next if ! $volid || $volid =~ m
|^/|;
1243 my ( $path, $owner ) = PVE
:: Storage
:: path
( $storecfg, $volid );
1244 next if ! $path || ! $owner || ( $owner != $vmid );
1246 PVE
:: Storage
:: vdisk_free
( $storecfg, $volid );
1251 # also remove unused disk
1253 my $dl = PVE
:: Storage
:: vdisk_list
( $storecfg, undef , $vmid );
1256 PVE
:: Storage
:: foreach_volid
( $dl, sub {
1257 my ( $volid, $sid, $volname, $d ) = @_ ;
1258 PVE
:: Storage
:: vdisk_free
( $storecfg, $volid );
1268 sub load_diskinfo_old
{
1269 my ( $storecfg, $vmid, $conf ) = @_ ;
1275 foreach_drive
( $conf, sub {
1280 return if drive_is_cdrom
( $di );
1282 if ( $di ->{ file
} =~ m
|^ /dev/ .+|) {
1283 $info ->{ $di ->{ file
}}->{ size
} = PVE
:: Storage
:: file_size_info
( $di ->{ file
});
1285 push @$vollist, $di ->{ file
};
1290 my $dl = PVE
:: Storage
:: vdisk_list
( $storecfg, undef , $vmid, $vollist );
1292 PVE
:: Storage
:: foreach_volid
( $dl, sub {
1293 my ( $volid, $sid, $volname, $d ) = @_ ;
1294 $info ->{ $volid } = $d ;
1299 foreach my $ds ( keys %$res ) {
1300 my $di = $res ->{ $ds };
1302 $res ->{ $ds }->{ disksize
} = $info ->{ $di ->{ file
}} ?
1303 $info ->{ $di ->{ file
}}->{ size
} / ( 1024 * 1024 ) : 0 ;
1312 my $cfspath = cfs_config_path
( $vmid );
1314 my $conf = PVE
:: Cluster
:: cfs_read_file
( $cfspath );
1316 die "no such VM (' $vmid ') \n " if ! defined ( $conf );
1321 sub parse_vm_config
{
1322 my ( $filename, $raw ) = @_ ;
1324 return undef if ! defined ( $raw );
1327 digest
=> Digest
:: SHA1
:: sha1_hex
( $raw ),
1330 $filename =~ m
| /qemu-server/ ( \d
+) \
. conf
$|
1331 || die "got strange filename ' $filename '" ;
1335 while ( $raw && $raw =~ s/^(.*?)(\n|$)// ) {
1338 next if $line =~ m/^\#/ ;
1340 next if $line =~ m/^\s*$/ ;
1342 if ( $line =~ m/^(description):\s*(.*\S)\s*$/ ) {
1344 my $value = PVE
:: Tools
:: decode_text
( $2 );
1345 $res ->{ $key } = $value ;
1346 } elsif ( $line =~ m/^(args):\s*(.*\S)\s*$/ ) {
1349 $res ->{ $key } = $value ;
1350 } elsif ( $line =~ m/^([a-z][a-z_]*\d*):\s*(\S+)\s*$/ ) {
1353 eval { $value = check_type
( $key, $value ); };
1355 warn "vm $vmid - unable to parse value of ' $key ' - $@ " ;
1357 my $fmt = $confdesc ->{ $key }->{ format
};
1358 if ( $fmt && $fmt eq 'pve-qm-drive' ) {
1359 my $v = parse_drive
( $key, $value );
1360 if ( my $volid = filename_to_volume_id
( $vmid, $v ->{ file
}, $v ->{ media
})) {
1361 $v ->{ file
} = $volid ;
1362 $value = print_drive
( $vmid, $v );
1364 warn "vm $vmid - unable to parse value of ' $key ' \n " ;
1369 if ( $key eq 'cdrom' ) {
1370 $res ->{ ide2
} = $value ;
1372 $res ->{ $key } = $value ;
1378 # convert old smp to sockets
1379 if ( $res ->{ smp
} && ! $res ->{ sockets
}) {
1380 $res ->{ sockets
} = $res ->{ smp
};
1388 my ( $vmid, $settings, $unset, $skiplock ) = @_ ;
1390 lock_config
( $vmid, & change_config_nolock
, $settings, $unset, $skiplock );
1393 sub change_config_nolock
{
1394 my ( $vmid, $settings, $unset, $skiplock ) = @_ ;
1398 $unset ->{ ide2
} = $unset ->{ cdrom
} if $unset ->{ cdrom
};
1400 check_lock
( $settings ) if ! $skiplock ;
1402 # we do not use 'smp' any longer
1403 if ( $settings ->{ sockets
}) {
1405 } elsif ( $settings ->{ smp
}) {
1406 $settings ->{ sockets
} = $settings ->{ smp
};
1410 my $new_volids = {};
1412 foreach my $key ( keys %$settings ) {
1413 next if $key eq 'digest' ;
1414 my $value = $settings ->{ $key };
1415 if ( $key eq 'description' ) {
1416 $value = PVE
:: Tools
:: encode_text
( $value );
1418 eval { $value = check_type
( $key, $value ); };
1419 die "unable to parse value of ' $key ' - $@ " if $@ ;
1420 if ( $key eq 'cdrom' ) {
1421 $res ->{ ide2
} = $value ;
1423 $res ->{ $key } = $value ;
1425 if ( valid_drivename
( $key )) {
1426 my $drive = PVE
:: QemuServer
:: parse_drive
( $key, $value );
1427 $new_volids ->{ $drive ->{ file
}} = 1 if $drive && $drive ->{ file
};
1431 my $filename = config_file
( $vmid );
1432 my $tmpfn = " $filename . $$ .tmp" ;
1434 my $fh = new IO
:: File
( $filename, "r" ) ||
1435 die "unable to read config for VM $vmid\n " ;
1437 my $werror = "unable to write config for VM $vmid\n " ;
1439 my $out = new IO
:: File
( $tmpfn, "w" ) || die $werror ;
1445 while ( my $line = < $fh >) {
1447 if (( $line =~ m/^\#/ ) || ( $line =~ m/^\s*$/ )) {
1448 die $werror unless print $out $line ;
1452 if ( $line =~ m/^([a-z][a-z_]*\d*):\s*(.*\S)\s*$/ ) {
1456 # remove 'unusedX' settings if we re-add a volume
1457 next if $key =~ m/^unused/ && $new_volids ->{ $value };
1459 # convert 'smp' to 'sockets'
1460 $key = 'sockets' if $key eq 'smp' ;
1462 next if $done ->{ $key };
1465 if ( defined ( $res ->{ $key })) {
1466 $value = $res ->{ $key };
1467 delete $res ->{ $key };
1469 if (! defined ( $unset ->{ $key })) {
1470 die $werror unless print $out " $key : $value\n " ;
1476 die "unable to parse config file: $line\n " ;
1479 foreach my $key ( keys %$res ) {
1481 if (! defined ( $unset ->{ $key })) {
1482 die $werror unless print $out " $key : $res ->{ $key } \n " ;
1497 if (! $out -> close ()) {
1498 $err = "close failed - $!\n " ;
1503 if (! rename ( $tmpfn, $filename )) {
1504 $err = "rename failed - $!\n " ;
1514 # we use static defaults from our JSON schema configuration
1515 foreach my $key ( keys %$confdesc ) {
1516 if ( defined ( my $default = $confdesc ->{ $key }->{ default })) {
1517 $res ->{ $key } = $default ;
1521 my $conf = PVE
:: Cluster
:: cfs_read_file
( 'datacenter.cfg' );
1522 $res ->{ keyboard
} = $conf ->{ keyboard
} if $conf ->{ keyboard
};
1528 my $vmlist = PVE
:: Cluster
:: get_vmlist
();
1530 return $res if ! $vmlist || ! $vmlist ->{ ids
};
1531 my $ids = $vmlist ->{ ids
};
1533 my $nodename = PVE
:: INotify
:: nodename
();
1534 foreach my $vmid ( keys %$ids ) {
1535 my $d = $ids ->{ $vmid };
1536 next if ! $d ->{ node
} || $d ->{ node
} ne $nodename ;
1537 $res ->{ $vmid }->{ exists } = 1 ;
1545 die "VM is locked ( $conf ->{lock}) \n " if $conf ->{ lock };
1549 my ( $pidfile, $pid ) = @_ ;
1551 my $fh = IO
:: File-
> new ( "/proc/ $pid/cmdline " , "r" );
1552 if ( defined ( $fh )) {
1555 return undef if ! $line ;
1556 my @param = split ( /\0/ , $line );
1558 my $cmd = $param [ 0 ];
1559 return if ! $cmd || ( $cmd !~ m
| kvm
$|);
1561 for ( my $i = 0 ; $i < scalar ( @param ); $i++ ) {
1564 if (( $p eq '-pidfile' ) || ( $p eq '--pidfile' )) {
1565 my $p = $param [ $i+1 ];
1566 return 1 if $p && ( $p eq $pidfile );
1577 my $filename = config_file
( $vmid );
1579 die "unable to find configuration file for VM $vmid - no such machine \n "
1582 my $pidfile = pidfile_name
( $vmid );
1584 if ( my $fd = IO
:: File-
> new ( "< $pidfile " )) {
1585 my $st = stat ( $fd );
1589 my $mtime = $st -> mtime ;
1590 if ( $mtime > time ()) {
1591 warn "file ' $filename ' modified in future \n " ;
1594 if ( $line =~ m/^(\d+)$/ ) {
1597 return $pid if ((- d
"/proc/ $pid " ) && check_cmdline
( $pidfile, $pid ));
1606 my $vzlist = config_list
();
1608 my $fd = IO
:: Dir-
> new ( $var_run_tmpdir ) || return $vzlist ;
1610 while ( defined ( my $de = $fd -> read )) {
1611 next if $de !~ m/^(\d+)\.pid$/ ;
1613 next if ! defined ( $vzlist ->{ $vmid });
1614 if ( my $pid = check_running
( $vmid )) {
1615 $vzlist ->{ $vmid }->{ pid
} = $pid ;
1622 my $storage_timeout_hash = {};
1625 my ( $storecfg, $conf ) = @_ ;
1627 my $bootdisk = $conf ->{ bootdisk
};
1628 return undef if ! $bootdisk ;
1629 return undef if ! valid_drivename
( $bootdisk );
1631 return undef if ! $conf ->{ $bootdisk };
1633 my $drive = parse_drive
( $bootdisk, $conf ->{ $bootdisk });
1634 return undef if ! defined ( $drive );
1636 return undef if drive_is_cdrom
( $drive );
1638 my $volid = $drive ->{ file
};
1639 return undef if ! $volid ;
1645 if ( $volid =~ m
|^/|) {
1646 $path = $timeoutid = $volid ;
1648 $storeid = $timeoutid = PVE
:: Storage
:: parse_volume_id
( $volid );
1649 $path = PVE
:: Storage
:: path
( $storecfg, $volid );
1652 my $last_timeout = $storage_timeout_hash ->{ $timeoutid };
1653 if ( $last_timeout ) {
1654 if (( time () - $last_timeout ) < 30 ) {
1655 # skip storage with errors
1658 delete $storage_timeout_hash ->{ $timeoutid };
1661 my ( $size, $format, $used );
1663 ( $size, $format, $used ) = PVE
:: Storage
:: file_size_info
( $path, 1 );
1665 if (! defined ( $format )) {
1667 $storage_timeout_hash ->{ $timeoutid } = time ();
1671 return wantarray ?
( $size, $used ) : $size ;
1674 my $last_proc_pid_stat ;
1677 my ( $opt_vmid ) = @_ ;
1681 my $storecfg = PVE
:: Storage
:: config
();
1683 my $list = vzlist
();
1684 my ( $uptime ) = PVE
:: ProcFSTools
:: read_proc_uptime
();
1686 foreach my $vmid ( keys %$list ) {
1687 next if $opt_vmid && ( $vmid ne $opt_vmid );
1689 my $cfspath = cfs_config_path
( $vmid );
1690 my $conf = PVE
:: Cluster
:: cfs_read_file
( $cfspath ) || {};
1693 $d ->{ pid
} = $list ->{ $vmid }->{ pid
};
1695 # fixme: better status?
1696 $d ->{ status
} = $list ->{ $vmid }->{ pid
} ?
'running' : 'stopped' ;
1698 my ( $size, $used ) = disksize
( $storecfg, $conf );
1699 if ( defined ( $size ) && defined ( $used )) {
1701 $d ->{ maxdisk
} = $size ;
1707 $d ->{ cpus
} = ( $conf ->{ sockets
} || 1 ) * ( $conf ->{ cores
} || 1 );
1708 $d ->{ name
} = $conf ->{ name
} || "VM $vmid " ;
1709 $d ->{ maxmem
} = $conf ->{ memory
} ?
$conf ->{ memory
}*( 1024 * 1024 ) : 0 ;
1721 $d ->{ diskwrite
} = 0 ;
1726 my $netdev = PVE
:: ProcFSTools
:: read_proc_net_dev
();
1727 foreach my $dev ( keys %$netdev ) {
1728 next if $dev !~ m/^tap([1-9]\d*)i/ ;
1730 my $d = $res ->{ $vmid };
1733 $d ->{ netout
} += $netdev ->{ $dev }->{ receive
};
1734 $d ->{ netin
} += $netdev ->{ $dev }->{ transmit
};
1737 my $cpuinfo = PVE
:: ProcFSTools
:: read_cpuinfo
();
1738 my $cpucount = $cpuinfo ->{ cpus
} || 1 ;
1739 my $ctime = gettimeofday
;
1741 foreach my $vmid ( keys %$list ) {
1743 my $d = $res ->{ $vmid };
1744 my $pid = $d ->{ pid
};
1747 if ( my $fh = IO
:: File-
> new ( "/proc/ $pid/io " , "r" )) {
1749 while ( defined ( my $line = < $fh >)) {
1750 if ( $line =~ m/^([rw]char):\s+(\d+)$/ ) {
1755 $d ->{ diskread
} = $data ->{ rchar
} || 0 ;
1756 $d ->{ diskwrite
} = $data ->{ wchar
} || 0 ;
1759 my $statstr = file_read_firstline
( "/proc/ $pid/stat " );
1762 my ( $utime, $stime, $vsize, $rss, $starttime );
1763 if ( $statstr =~ m/^$pid \(.*\) \S (-?\d+) -?\d+ -?\d+ -?\d+ -?\d+ \d+ \d+ \d+ \d+ \d+ (\d+) (\d+) (-?\d+) (-?\d+) -?\d+ -?\d+ -?\d+ 0 (\d+) (\d+) (-?\d+) \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ -?\d+ -?\d+ \d+ \d+ \d+/ ) {
1764 ( $utime, $stime, $vsize, $rss, $starttime ) = ( $2, $3, $7, $8 * 4096 , $6 );
1769 my $used = $utime + $stime ;
1771 my $vcpus = $d ->{ cpus
} > $cpucount ?
$cpucount : $d ->{ cpus
};
1773 $d ->{ uptime
} = int ( $uptime - ( $starttime/100 ));
1776 $d ->{ mem
} = int (( $rss/$vsize )* $d ->{ maxmem
});
1779 my $old = $last_proc_pid_stat ->{ $pid };
1781 $last_proc_pid_stat ->{ $pid } = {
1790 my $dtime = ( $ctime - $old ->{ time }) * $cpucount * $clock_ticks ;
1792 if ( $dtime > 1000 ) {
1793 my $dutime = $used - $old ->{ used
};
1795 $d ->{ cpu
} = $dutime/$dtime ;
1796 $d ->{ relcpu
} = ( $d ->{ cpu
} * $cpucount ) / $vcpus ;
1797 $last_proc_pid_stat ->{ $pid } = {
1801 relcpu
=> $d ->{ relcpu
},
1804 $d ->{ cpu
} = $old ->{ cpu
};
1805 $d ->{ relcpu
} = $old ->{ relcpu
};
1813 my ( $conf, $func ) = @_ ;
1815 foreach my $ds ( keys %$conf ) {
1816 next if ! valid_drivename
( $ds );
1818 my $drive = parse_drive
( $ds, $conf ->{ $ds });
1821 & $func ( $ds, $drive );
1825 sub config_to_command
{
1826 my ( $storecfg, $vmid, $conf, $defaults, $migrate_uri ) = @_ ;
1830 my $kvmver = kvm_user_version
();
1831 my $vernum = 0 ; # unknown
1832 if ( $kvmver =~ m/^(\d+)\.(\d+)\.(\d+)$/ ) {
1833 $vernum = $1*1000000+$2*1000+$3 ;
1836 die "detected old qemu-kvm binary ( $kvmver ) \n " if $vernum < 14000 ;
1838 my $have_ovz = - f
'/proc/vz/vestat' ;
1840 push @$cmd, '/usr/bin/kvm' ;
1842 push @$cmd, '-id' , $vmid ;
1846 my $socket = monitor_socket
( $vmid );
1847 push @$cmd, '-monitor' , "unix: $socket,server,nowait " ;
1849 $socket = vnc_socket
( $vmid );
1850 push @$cmd, '-vnc' , "unix: $socket,x509,password " ;
1852 push @$cmd, '-pidfile' , pidfile_name
( $vmid );
1854 push @$cmd, '-daemonize' ;
1856 push @$cmd, '-incoming' , $migrate_uri if $migrate_uri ;
1858 # include usb device config
1859 push @$cmd, '-readconfig' , '/usr/share/qemu-server/pve-usb.cfg' ;
1861 # enable absolute mouse coordinates (needed by vnc)
1862 my $tablet = defined ( $conf ->{ tablet
}) ?
$conf ->{ tablet
} : $defaults ->{ tablet
};
1863 push @$cmd, '-device' , 'usb-tablet,bus=ehci.0,port=6' if $tablet ;
1866 if ( my $pcidl = $conf ->{ hostpci
}) {
1867 my @dl = split ( /,/ , $pcidl );
1868 foreach my $dev ( @dl ) {
1869 push @$cmd, '-device' , "pci-assign,host= $dev " if $dev ;
1874 for ( my $i = 0 ; $i < $MAX_USB_DEVICES ; $i++ ) {
1875 my $d = parse_usb_device
( $conf ->{ "usb $i " });
1877 if ( $d ->{ vendorid
} && $d ->{ productid
}) {
1878 push @$cmd, '-device' , "usb-host,vendorid= $d ->{vendorid},productid= $d ->{productid}" ;
1879 } elsif ( defined ( $d ->{ hostbus
}) && defined ( $d ->{ hostport
})) {
1880 push @$cmd, '-device' , "usb-host,hostbus= $d ->{hostbus},hostport= $d ->{hostport}" ;
1884 if ( my $usbdl = $conf ->{ hostusb
}) {
1885 my @dl = split ( /,/ , $usbdl );
1886 foreach my $dev ( @dl ) {
1887 push @$cmd, '-usbdevice' , "host: $dev " if $dev ;
1892 if ( my $serdl = $conf ->{ serial
}) {
1893 my @dl = split ( /,/ , $serdl );
1894 foreach my $dev ( @dl ) {
1897 push @$cmd, '-serial' , " $dev " ;
1903 if ( my $pardl = $conf ->{ parallel
}) {
1904 my @dl = split ( /,/ , $pardl );
1905 foreach my $dev ( @dl ) {
1908 push @$cmd, '-parallel' , " $dev " ;
1913 my $vmname = $conf ->{ name
} || "vm $vmid " ;
1915 push @$cmd, '-name' , $vmname ;
1918 $sockets = $conf ->{ smp
} if $conf ->{ smp
}; # old style - no longer iused
1919 $sockets = $conf ->{ sockets
} if $conf ->{ sockets
};
1921 my $cores = $conf ->{ cores
} || 1 ;
1925 push @$cmd, '-smp' , "sockets= $sockets,cores = $cores " ;
1927 push @$cmd, '-cpu' , $conf ->{ cpu
} if $conf ->{ cpu
};
1929 $boot_opt = "menu=on" ;
1930 if ( $conf ->{ boot
}) {
1931 $boot_opt .= ",order= $conf ->{boot}" ;
1934 push @$cmd, '-nodefaults' ;
1936 push @$cmd, '-boot' , $boot_opt if $boot_opt ;
1938 push @$cmd, '-no-acpi' if defined ( $conf ->{ acpi
}) && $conf ->{ acpi
} == 0 ;
1940 push @$cmd, '-no-reboot' if defined ( $conf ->{ reboot
}) && $conf ->{ reboot
} == 0 ;
1942 my $vga = $conf ->{ vga
};
1944 if ( $conf ->{ ostype
} && ( $conf ->{ ostype
} eq 'win7' || $conf ->{ ostype
} eq 'w2k8' )) {
1951 push @$cmd, '-vga' , $vga if $vga ; # for kvm 77 and later
1954 my $tdf = defined ( $conf ->{ tdf
}) ?
$conf ->{ tdf
} : $defaults ->{ tdf
};
1955 push @$cmd, '-tdf' if $tdf ;
1957 my $nokvm = defined ( $conf ->{ kvm
}) && $conf ->{ kvm
} == 0 ?
1 : 0 ;
1959 if ( my $ost = $conf ->{ ostype
}) {
1960 # other, wxp, w2k, w2k3, w2k8, wvista, win7, l24, l26
1962 if ( $ost =~ m/^w/ ) { # windows
1963 push @$cmd, '-localtime' if ! defined ( $conf ->{ localtime });
1965 # use rtc-td-hack when acpi is enabled
1966 if (!( defined ( $conf ->{ acpi
}) && $conf ->{ acpi
} == 0 )) {
1967 push @$cmd, '-rtc-td-hack' ;
1977 push @$cmd, '-no-kvm' if $nokvm ;
1979 push @$cmd, '-localtime' if $conf ->{ localtime };
1981 push @$cmd, '-startdate' , $conf ->{ startdate
} if $conf ->{ startdate
};
1983 push @$cmd, '-S' if $conf ->{ freeze
};
1985 # set keyboard layout
1986 my $kb = $conf ->{ keyboard
} || $defaults ->{ keyboard
};
1987 push @$cmd, '-k' , $kb if $kb ;
1990 #my $soundhw = $conf->{soundhw} || $defaults->{soundhw};
1991 #push @$cmd, '-soundhw', 'es1370';
1992 #push @$cmd, '-soundhw', $soundhw if $soundhw;
1996 foreach_drive
( $conf, sub {
1997 my ( $ds, $drive ) = @_ ;
2000 PVE
:: Storage
:: parse_volume_id
( $drive ->{ file
});
2001 push @$vollist, $drive ->{ file
};
2004 $use_virtio = 1 if $ds =~ m/^virtio/ ;
2005 my $tmp = print_drive_full
( $storecfg, $vmid, $drive );
2006 $tmp .= ",boot=on" if $conf ->{ bootdisk
} && ( $conf ->{ bootdisk
} eq $ds );
2007 push @$cmd, '-drive' , $tmp ;
2010 push @$cmd, '-m' , $conf ->{ memory
} || $defaults ->{ memory
};
2014 foreach my $k ( sort keys %$conf ) {
2015 next if $k !~ m/^net(\d+)$/ ;
2018 die "got strange net id ' $i ' \n " if $i >= ${ MAX_NETS
};
2020 if ( $conf ->{ "net $i " } && ( my $net = parse_net
( $conf ->{ "net $i " }))) {
2024 my $ifname = "tap${vmid}i $i " ;
2026 # kvm uses TUNSETIFF ioctl, and that limits ifname length
2027 die "interface name ' $ifname ' is too long (max 15 character) \n "
2028 if length ( $ifname ) >= 16 ;
2030 my $device = $net ->{ model
};
2031 my $vhostparam = '' ;
2032 if ( $net ->{ model
} eq 'virtio' ) {
2034 $device = 'virtio-net-pci' ;
2035 $vhostparam = ',vhost=on' if $kernel_has_vhost_net ;
2038 if ( $net ->{ bridge
}) {
2039 push @$cmd, '-netdev' , "type=tap,id=${k},ifname=${ifname},script=/var/lib/qemu-server/pve-bridge $vhostparam " ;
2041 push @$cmd, '-netdev' , "type=user,id=${k},hostname= $vmname " ;
2044 # qemu > 0.15 always try to boot from network - we disable that by
2045 # not loading the pxe rom file
2046 my $extra = (! $conf ->{ boot
} || ( $conf ->{ boot
} !~ m/n/ )) ?
2048 push @$cmd, '-device' , " $device,$ {extra}mac= $net ->{macaddr},netdev=${k}" ;
2052 push @$cmd, '-net' , 'none' if ! $foundnet ;
2054 # hack: virtio with fairsched is unreliable, so we do not use fairsched
2055 # when the VM uses virtio devices.
2056 if (! $use_virtio && $have_ovz ) {
2058 my $cpuunits = defined ( $conf ->{ cpuunits
}) ?
2059 $conf ->{ cpuunits
} : $defaults ->{ cpuunits
};
2061 push @$cmd, '-cpuunits' , $cpuunits if $cpuunits ;
2063 # fixme: cpulimit is currently ignored
2064 #push @$cmd, '-cpulimit', $conf->{cpulimit} if $conf->{cpulimit};
2068 if ( $conf ->{ args
}) {
2069 my $aa = split_args
( $conf ->{ args
});
2073 return wantarray ?
( $cmd, $vollist ) : $cmd ;
2078 return "${var_run_tmpdir}/ $vmid .vnc" ;
2081 sub monitor_socket
{
2083 return "${var_run_tmpdir}/ $vmid .mon" ;
2088 return "${var_run_tmpdir}/ $vmid .pid" ;
2091 sub random_ether_addr
{
2093 my $rand = Digest
:: SHA1
:: sha1_hex
( rand (), time ());
2096 for ( my $i = 0 ; $i < 6 ; $i++ ) {
2097 my $ss = hex ( substr ( $rand, $i*2, 2 ));
2099 $ss &= 0xfe ; # clear multicast
2100 $ss |= 2 ; # set local id
2102 $ss = sprintf ( " %02X " , $ss );
2114 sub next_migrate_port
{
2116 for ( my $p = 60000 ; $p < 60010 ; $p++ ) {
2118 my $sock = IO
:: Socket
:: INET-
> new ( Listen
=> 5 ,
2119 LocalAddr
=> 'localhost' ,
2130 die "unable to find free migration port" ;
2134 my ( $storecfg, $vmid, $statefile, $skiplock ) = @_ ;
2136 lock_config
( $vmid, sub {
2137 my $conf = load_config
( $vmid );
2139 check_lock
( $conf ) if ! $skiplock ;
2141 if ( check_running
( $vmid )) {
2142 my $msg = "VM $vmid already running - start failed \n " ;
2143 syslog
( 'err' , $msg );
2146 syslog
( 'info' , "VM $vmid start" );
2150 my $migrate_port = 0 ;
2153 if ( $statefile eq 'tcp' ) {
2154 $migrate_port = next_migrate_port
();
2155 $migrate_uri = "tcp:localhost:${migrate_port}" ;
2157 if (- f
$statefile ) {
2158 $migrate_uri = "exec:cat $statefile " ;
2160 warn "state file ' $statefile ' does not exist - doing normal startup \n " ;
2165 my $defaults = load_defaults
();
2167 my ( $cmd, $vollist ) = config_to_command
( $storecfg, $vmid, $conf, $defaults, $migrate_uri );
2169 if ( my $pcidl = $conf ->{ hostpci
}) {
2170 my @dl = split ( /,/ , $pcidl );
2171 foreach my $dev ( @dl ) {
2173 my $info = pci_device_info
( "0000: $dev " );
2174 die "no pci device info for device ' $dev ' \n " if ! $info ;
2175 die "can't unbind pci device ' $dev ' \n " if ! pci_dev_bind_to_stub
( $info );
2176 die "can't reset pci device ' $dev ' \n " if ! pci_dev_reset
( $info );
2180 PVE
:: Storage
:: activate_volumes
( $storecfg, $vollist );
2182 eval { run_command
( $cmd, timeout
=> $migrate_uri ?
undef : 30 ); };
2187 my $msg = "start failed: $err " ;
2188 syslog
( 'err' , "VM $vmid $msg " );
2194 if ( $statefile eq 'tcp' ) {
2195 print "migration listens on port $migrate_port\n " ;
2198 # fixme: send resume - is that necessary ?
2199 eval { vm_monitor_command
( $vmid, "cont" , 1 ) };
2203 if ( my $migrate_speed =
2204 $conf ->{ migrate_speed
} || $defaults ->{ migrate_speed
}) {
2205 my $cmd = "migrate_set_speed ${migrate_speed}m" ;
2206 eval { vm_monitor_command
( $vmid, $cmd, 1 ); };
2209 if ( my $migrate_downtime =
2210 $conf ->{ migrate_downtime
} || $defaults ->{ migrate_downtime
}) {
2211 my $cmd = "migrate_set_downtime ${migrate_downtime}" ;
2212 eval { vm_monitor_command
( $vmid, $cmd, 1 ); };
2218 my ( $fh, $timeout ) = @_ ;
2220 my $sel = new IO
:: Select
;
2227 while ( scalar ( @ready = $sel -> can_read ( $timeout ))) {
2229 if ( $count = $fh -> sysread ( $buf, 8192 )) {
2230 if ( $buf =~ /^(.*)\(qemu\) $/s ) {
2237 if (! defined ( $count )) {
2244 die "monitor read timeout \n " if ! scalar ( @ready );
2249 sub vm_monitor_command
{
2250 my ( $vmid, $cmdstr, $nolog ) = @_ ;
2254 syslog
( "info" , "VM $vmid monitor command ' $cmdstr '" ) if ! $nolog ;
2257 die "VM not running \n " if ! check_running
( $vmid );
2259 my $sname = monitor_socket
( $vmid );
2261 my $sock = IO
:: Socket
:: UNIX-
> new ( Peer
=> $sname ) ||
2262 die "unable to connect to VM $vmid socket - $!\n " ;
2266 # hack: migrate sometime blocks the monitor (when migrate_downtime
2268 if ( $cmdstr =~ m/^(info\s+migrate|migrate\s)/ ) {
2269 $timeout = 60 * 60 ; # 1 hour
2273 my $data = __read_avail
( $sock, $timeout );
2275 if ( $data !~ m/^QEMU\s+(\S+)\s+monitor\s/ ) {
2276 die "got unexpected qemu monitor banner \n " ;
2279 my $sel = new IO
:: Select
;
2282 if (! scalar ( my @ready = $sel -> can_write ( $timeout ))) {
2283 die "monitor write error - timeout" ;
2286 my $fullcmd = " $cmdstr\r " ;
2289 if (!( $b = $sock -> syswrite ( $fullcmd )) || ( $b != length ( $fullcmd ))) {
2290 die "monitor write error - $! " ;
2293 return if ( $cmdstr eq 'q' ) || ( $cmdstr eq 'quit' );
2297 if ( $cmdstr =~ m/^(info\s+migrate|migrate\s)/ ) {
2298 $timeout = 60 * 60 ; # 1 hour
2299 } elsif ( $cmdstr =~ m/^(eject|change)/ ) {
2300 $timeout = 60 ; # note: cdrom mount command is slow
2302 if ( $res = __read_avail
( $sock, $timeout )) {
2304 my @lines = split ( " \r ? \n " , $res );
2306 shift @lines if $lines [ 0 ] !~ m/^unknown command/ ; # skip echo
2308 $res = join ( " \n " , @lines );
2316 syslog
( "err" , "VM $vmid monitor command failed - $err " );
2323 sub vm_commandline
{
2324 my ( $storecfg, $vmid ) = @_ ;
2326 my $conf = load_config
( $vmid );
2328 my $defaults = load_defaults
();
2330 my $cmd = config_to_command
( $storecfg, $vmid, $conf, $defaults );
2332 return join ( ' ' , @$cmd );
2336 my ( $vmid, $skiplock ) = @_ ;
2338 lock_config
( $vmid, sub {
2340 my $conf = load_config
( $vmid );
2342 check_lock
( $conf ) if ! $skiplock ;
2344 syslog
( "info" , "VM $vmid sending 'reset'" );
2346 vm_monitor_command
( $vmid, "system_reset" , 1 );
2351 my ( $vmid, $skiplock ) = @_ ;
2353 lock_config
( $vmid, sub {
2355 my $conf = load_config
( $vmid );
2357 check_lock
( $conf ) if ! $skiplock ;
2359 syslog
( "info" , "VM $vmid sending 'shutdown'" );
2361 vm_monitor_command
( $vmid, "system_powerdown" , 1 );
2366 my ( $vmid, $skiplock ) = @_ ;
2368 lock_config
( $vmid, sub {
2370 my $pid = check_running
( $vmid );
2373 syslog
( 'info' , "VM $vmid already stopped" );
2377 my $conf = load_config
( $vmid );
2379 check_lock
( $conf ) if ! $skiplock ;
2381 syslog
( "info" , "VM $vmid stopping" );
2383 eval { vm_monitor_command
( $vmid, "quit" , 1 ); };
2389 my $timeout = 50 ; # fixme: how long?
2392 while (( $count < $timeout ) && check_running
( $vmid )) {
2397 if ( $count >= $timeout ) {
2398 syslog
( 'info' , "VM $vmid still running - terminating now with SIGTERM" );
2402 syslog
( 'info' , "VM $vmid quit failed - terminating now with SIGTERM" );
2410 while (( $count < $timeout ) && check_running
( $vmid )) {
2415 if ( $count >= $timeout ) {
2416 syslog
( 'info' , "VM $vmid still running - terminating now with SIGKILL \n " );
2420 fairsched_rmnod
( $vmid ); # try to destroy group
2425 my ( $vmid, $skiplock ) = @_ ;
2427 lock_config
( $vmid, sub {
2429 my $conf = load_config
( $vmid );
2431 check_lock
( $conf ) if ! $skiplock ;
2433 syslog
( "info" , "VM $vmid suspend" );
2435 vm_monitor_command
( $vmid, "stop" , 1 );
2440 my ( $vmid, $skiplock ) = @_ ;
2442 lock_config
( $vmid, sub {
2444 my $conf = load_config
( $vmid );
2446 check_lock
( $conf ) if ! $skiplock ;
2448 syslog
( "info" , "VM $vmid resume" );
2450 vm_monitor_command
( $vmid, "cont" , 1 );
2455 my ( $vmid, $skiplock ) = @_ ;
2457 lock_config
( $vmid, sub {
2459 my $conf = load_config
( $vmid );
2461 check_lock
( $conf ) if ! $skiplock ;
2463 syslog
( "info" , "VM $vmid sending cntl-alt-delete" );
2465 vm_monitor_command
( $vmid, "sendkey ctrl-alt-delete" , 1 );
2470 my ( $storecfg, $vmid, $skiplock ) = @_ ;
2472 lock_config
( $vmid, sub {
2474 my $conf = load_config
( $vmid );
2476 check_lock
( $conf ) if ! $skiplock ;
2478 syslog
( "info" , "VM $vmid destroy called (removing all data)" );
2481 if (! check_running
( $vmid )) {
2482 fairsched_rmnod
( $vmid ); # try to destroy group
2483 destroy_vm
( $storecfg, $vmid );
2485 die "VM is running \n " ;
2492 syslog
( "err" , "VM $vmid destroy failed - $err " );
2501 $timeout = 3 * 60 if ! $timeout ;
2503 my $vzlist = vzlist
();
2505 foreach my $vmid ( keys %$vzlist ) {
2506 next if ! $vzlist ->{ $vmid }->{ pid
};
2512 my $msg = "Stopping Qemu Server - sending shutdown requests to all VMs \n " ;
2513 syslog
( 'info' , $msg );
2516 foreach my $vmid ( keys %$vzlist ) {
2517 next if ! $vzlist ->{ $vmid }->{ pid
};
2518 eval { vm_shutdown
( $vmid, 1 ); };
2519 print STDERR
$@ if $@ ;
2523 my $maxtries = int (( $timeout + $wt - 1 )/ $wt );
2525 while (( $try < $maxtries ) && $count ) {
2531 foreach my $vmid ( keys %$vzlist ) {
2532 next if ! $vzlist ->{ $vmid }->{ pid
};
2540 foreach my $vmid ( keys %$vzlist ) {
2541 next if ! $vzlist ->{ $vmid }->{ pid
};
2543 $msg = "VM $vmid still running - sending stop now \n " ;
2544 syslog
( 'info' , $msg );
2547 eval { vm_monitor_command
( $vmid, "quit" , 1 ); };
2548 print STDERR
$@ if $@ ;
2553 $maxtries = int (( $timeout + $wt - 1 )/ $wt );
2555 while (( $try < $maxtries ) && $count ) {
2561 foreach my $vmid ( keys %$vzlist ) {
2562 next if ! $vzlist ->{ $vmid }->{ pid
};
2570 foreach my $vmid ( keys %$vzlist ) {
2571 next if ! $vzlist ->{ $vmid }->{ pid
};
2573 $msg = "VM $vmid still running - terminating now with SIGTERM \n " ;
2574 syslog
( 'info' , $msg );
2576 kill 15 , $vzlist ->{ $vmid }->{ pid
};
2579 # this is called by system shotdown scripts, so remaining
2580 # processes gets killed anyways (no need to send kill -9 here)
2582 $msg = "Qemu Server stopped \n " ;
2583 syslog
( 'info' , $msg );
2591 my ( $filename, $buf ) = @_ ;
2593 my $fh = IO
:: File-
> new ( $filename, "w" );
2594 return undef if ! $fh ;
2596 my $res = print $fh $buf ;
2603 sub pci_device_info
{
2608 return undef if $name !~ m/^([a-f0-9]{4}):([a-f0-9]{2}):([a-f0-9]{2})\.([a-f0-9])$/ ;
2609 my ( $domain, $bus, $slot, $func ) = ( $1, $2, $3, $4 );
2611 my $irq = file_read_firstline
( " $pcisysfs/devices/$name/irq " );
2612 return undef if ! defined ( $irq ) || $irq !~ m/^\d+$/ ;
2614 my $vendor = file_read_firstline
( " $pcisysfs/devices/$name/vendor " );
2615 return undef if ! defined ( $vendor ) || $vendor !~ s/^0x// ;
2617 my $product = file_read_firstline
( " $pcisysfs/devices/$name/device " );
2618 return undef if ! defined ( $product ) || $product !~ s/^0x// ;
2623 product
=> $product,
2629 has_fl_reset
=> - f
" $pcisysfs/devices/$name/reset " || 0 ,
2638 my $name = $dev ->{ name
};
2640 my $fn = " $pcisysfs/devices/$name/reset " ;
2642 return file_write
( $fn, "1" );
2645 sub pci_dev_bind_to_stub
{
2648 my $name = $dev ->{ name
};
2650 my $testdir = " $pcisysfs/drivers/pci -stub/ $name " ;
2651 return 1 if - d
$testdir ;
2653 my $data = " $dev ->{vendor} $dev ->{product}" ;
2654 return undef if ! file_write
( " $pcisysfs/drivers/pci -stub/new_id" , $data );
2656 my $fn = " $pcisysfs/devices/$name/driver/unbind " ;
2657 if (! file_write
( $fn, $name )) {
2658 return undef if - f
$fn ;
2661 $fn = " $pcisysfs/drivers/pci -stub/bind" ;
2662 if (! - d
$testdir ) {
2663 return undef if ! file_write
( $fn, $name );