VirtualBox

source: vbox/trunk/src/VBox/Main/webservice/samples/perl/clienttest.pl@ 101351

最後變更 在這個檔案從101351是 98103,由 vboxsync 提交於 23 月 前

Copyright year updates by scm.

  • 屬性 svn:eol-style 設為 native
  • 屬性 svn:keywords 設為 Id Revision
檔案大小: 7.2 KB
 
1#!/usr/bin/perl
2# $Id: clienttest.pl 98103 2023-01-17 14:15:46Z vboxsync $
3## @file
4# This little perl program attempts to connect to a running VirtualBox
5# webservice and calls various methods on it. Please refer to the SDK
6# programming reference (SDKRef.pdf) for how to use this sample.
7#
8# Note! The following license applies to this file only
9#
10
11#
12# Copyright (C) 2008-2023 Oracle and/or its affiliates.
13#
14# Permission is hereby granted, free of charge, to any person
15# obtaining a copy of this software and associated documentation
16# files (the "Software"), to deal in the Software without
17# restriction, including without limitation the rights to use,
18# copy, modify, merge, publish, distribute, sublicense, and/or sell
19# copies of the Software, and to permit persons to whom the
20# Software is furnished to do so, subject to the following
21# conditions:
22#
23# The above copyright notice and this permission notice shall be
24# included in all copies or substantial portions of the Software.
25#
26# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
27# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
28# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
29# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
30# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
31# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
32# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
33# OTHER DEALINGS IN THE SOFTWARE.
34#
35
36use strict;
37use SOAP::Lite;
38use vboxService; # generated by stubmaker, see SDKRef.pdf
39use Data::Dumper;
40
41my $cmd = 'clienttest';
42my $optMode;
43my $vmname;
44my $disk;
45
46while (my $this = shift(@ARGV))
47{
48 if (($this =~ /^-h/) || ($this =~ /^--help/))
49 {
50 print "$cmd: test the VirtualBox web service.\n".
51 "Usage:\n".
52 " $cmd <mode>\n".
53 "with <mode> being one of 'version', 'list', 'start'; default is 'list'.\n".
54 " $cmd version: print version of VirtualBox web service.\n".
55 " $cmd list: list installed virtual machines.\n".
56 " $cmd startvm <vm>: start the virtual machine named <vm>.\n".
57 " $cmd acpipowerbutton <vm>: shutdown of the irtual machine named <vm>.\n";
58 " $cmd openhd <disk>: open disk image <disk>.\n";
59 exit 0;
60 }
61 elsif ( ($this eq 'version')
62 || ($this eq 'list')
63 )
64 {
65 $optMode = $this;
66 }
67 elsif ( ($this eq 'startvm')
68 || ($this eq 'acpipowerbutton')
69 )
70 {
71 $optMode = $this;
72
73 if (!($vmname = shift(@ARGV)))
74 {
75 die "[$cmd] Missing parameter: You must specify the name of the VM to start.\nStopped";
76 }
77 }
78 elsif ($this eq 'openhd')
79 {
80 $optMode = $this;
81
82 if (!($disk = shift(@ARGV)))
83 {
84 die "[$cmd] Missing parameter: You must specify the name of the disk to open.\nStopped";
85 }
86 }
87 else
88 {
89 die "[$cmd] Unknown option \"$this\"; stopped";
90 }
91}
92
93$optMode = "list"
94 if (!$optMode);
95
96# SOAP::Lite hacking to make it serialize the enum types we use correctly.
97# In the long run, this needs to be done either by stubmaker.pl or something
98# else, because the WSDL clearly says they're restricted strings. Quite silly
99# that the default behavior is to ignore the parameter and just let the server
100# use the default value for the type.
101
102sub SOAP::Serializer::as_LockType
103{
104 my ($self, $value, $name, $type, $attr) = @_;
105 die "String value expected instead of @{[ref $value]} reference\n"
106 if ref $value;
107 return [
108 $name,
109 {'xsi:type' => 'vbox:LockType', %$attr},
110 SOAP::Utils::encode_data($value)
111 ];
112}
113
114sub SOAP::Serializer::as_DeviceType
115{
116 my ($self, $value, $name, $type, $attr) = @_;
117 die "String value expected instead of @{[ref $value]} reference\n"
118 if ref $value;
119 return [
120 $name,
121 {'xsi:type' => 'vbox:DeviceType', %$attr},
122 SOAP::Utils::encode_data($value)
123 ];
124}
125
126sub SOAP::Serializer::as_AccessMode
127{
128 my ($self, $value, $name, $type, $attr) = @_;
129 die "String value expected instead of @{[ref $value]} reference\n"
130 if ref $value;
131 return [
132 $name,
133 {'xsi:type' => 'vbox:AccessMode', %$attr},
134 SOAP::Utils::encode_data($value)
135 ];
136}
137
138## @todo needs much more error handling, e.g. openhd never complains
139
140my $vbox = vboxService->IWebsessionManager_logon("test", "test");
141
142if (!$vbox)
143{
144 die "[$cmd] Logon to session manager with user \"test\" and password \"test\" failed.\nStopped";
145}
146
147if ($optMode eq "version")
148{
149 my $v = vboxService->IVirtualBox_getVersion($vbox);
150 print "[$cmd] Version number of running VirtualBox web service: $v\n";
151}
152elsif ($optMode eq "list")
153{
154 print "[$cmd] Listing machines:\n";
155 my @result = vboxService->IVirtualBox_getMachines($vbox);
156 foreach my $idMachine (@result)
157 {
158 my $if = vboxService->IManagedObjectRef_getInterfaceName($idMachine);
159 my $name = vboxService->IMachine_getName($idMachine);
160
161 print "machine $if $idMachine: $name\n";
162 }
163}
164elsif ($optMode eq "startvm")
165{
166 my $machine = vboxService->IVirtualBox_findMachine($vbox, $vmname);
167
168 die "[$cmd] Cannot find VM \"$vmname\"; stopped"
169 if (!$machine);
170
171 my $session = vboxService->IWebsessionManager_getSessionObject($vbox);
172 die "[$cmd] Cannot get session object; stopped"
173 if (!$session);
174
175 my $uuid = vboxService->IMachine_getId($machine);
176 die "[$cmd] Cannot get uuid for machine; stopped"
177 if (!$uuid);
178
179 print "[$cmd] UUID: $uuid\n";
180
181 my @env = ();
182 my $progress = vboxService->IMachine_launchVMProcess($machine,
183 $session,
184 "headless",
185 @env);
186 die "[$cmd] Cannot launch VM; stopped"
187 if (!$progress);
188
189 print("[$cmd] Waiting for the VM to start...\n");
190 vboxService->IProgress_waitForCompletion($progress, -1);
191
192 my $fCompleted;
193 $fCompleted = vboxService->IProgress_getCompleted($progress);
194 print("[$cmd] Completed: $fCompleted\n");
195
196 my $resultCode;
197 $resultCode = vboxService->IProgress_getResultCode($progress);
198
199 print("[$cmd] Result: $resultCode\n");
200
201 vboxService->ISession_unlockMachine($session);
202
203 vboxService->IWebsessionManager_logoff($vbox);
204}
205elsif ($optMode eq "acpipowerbutton")
206{
207 my $machine = vboxService->IVirtualBox_findMachine($vbox, $vmname);
208
209 die "[$cmd] Cannot find VM \"$vmname\"; stopped"
210 if (!$machine);
211
212 my $session = vboxService->IWebsessionManager_getSessionObject($vbox);
213 die "[$cmd] Cannot get session object; stopped"
214 if (!$session);
215
216 vboxService->IMachine_lockMachine($machine, $session, 'Shared');
217
218 my $console = vboxService->ISession_getConsole($session);
219
220 vboxService->IConsole_powerButton($console);
221
222 vboxService->ISession_unlockMachine($session);
223
224 vboxService->IWebsessionManager_logoff($vbox);
225}
226elsif ($optMode eq "openhd")
227{
228 my $medium = vboxService->IVirtualBox_openMedium($vbox, $disk,
229 'HardDisk',
230 'ReadWrite',
231 0);
232}
注意: 瀏覽 TracBrowser 來幫助您使用儲存庫瀏覽器

© 2024 Oracle Support Privacy / Do Not Sell My Info Terms of Use Trademark Policy Automated Access Etiquette