DESTDIR=
+PERL5_DIR=${DESTDIR}/usr/share/perl5
LIB_DIR=${DESTDIR}/usr/share/${PACKAGE}
DOCDIR=${DESTDIR}/usr/share/doc/${PACKAGE}
BASHCOMPLDIR=${DESTDIR}/usr/share/bash-completion/completions/
+PVE_COMMON_FILES= \
+ CLIHandler.pm \
+ JSONSchema.pm \
+ PTY.pm \
+ RESTHandler.pm \
+ SafeSyslog.pm \
+ SectionConfig.pm \
+
all: ${DEB}
.PHONY: deb
lintian ${DEB}
install: pve-api-definition.dat
- install -d -m 0755 ${LIB_DIR}/PVE
+ install -d -m 0755 ${PERL5_DIR}/PVE/APIClient
# install library tools from pve-common
- install -m 0644 PVE/Tools.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/SafeSyslog.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/Exception.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/JSONSchema.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/RESTHandler.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/CLIHandler.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/PTY.pm ${LIB_DIR}/PVE
- install -m 0644 PVE/SectionConfig.pm ${LIB_DIR}/PVE
+ for i in ${PVE_COMMON_FILES}; do install -m 0644 PVE/APIClient/$$i ${PERL5_DIR}/PVE/APIClient; done
# install pveclient
- install -D -m 0644 PVE/APIClient/Helpers.pm ${LIB_DIR}/PVE/APIClient/Helpers.pm
- install -D -m 0644 PVE/APIClient/Config.pm ${LIB_DIR}/PVE/APIClient/Config.pm
- install -D -m 0644 PVE/APIClient/Commands/remote.pm ${LIB_DIR}/PVE/APIClient/Commands/remote.pm
- install -D -m 0644 PVE/APIClient/Commands/lxc.pm ${LIB_DIR}/PVE/APIClient/Commands/lxc.pm
- install -D -m 0644 PVE/APIClient/Commands/config.pm ${LIB_DIR}/PVE/APIClient/Commands/config.pm
- install -D -m 0644 PVE/APIClient/Commands/list.pm ${LIB_DIR}/PVE/APIClient/Commands/list.pm
- install -D -m 0644 PVE/APIClient/Commands/GuestStatus.pm ${LIB_DIR}/PVE/APIClient/Commands/GuestStatus.pm
+ install -D -m 0644 PVE/APIClient/Tools.pm ${PERL5_DIR}/PVE/APIClient/Tools.pm
+ install -D -m 0644 PVE/APIClient/Helpers.pm ${PERL5_DIR}/PVE/APIClient/Helpers.pm
+ install -D -m 0644 PVE/APIClient/Config.pm ${PERL5_DIR}/PVE/APIClient/Config.pm
+ install -D -m 0644 PVE/APIClient/Commands/remote.pm ${PERL5_DIR}/PVE/APIClient/Commands/remote.pm
+ install -D -m 0644 PVE/APIClient/Commands/lxc.pm ${PERL5_DIR}/PVE/APIClient/Commands/lxc.pm
+ install -D -m 0644 PVE/APIClient/Commands/config.pm ${PERL5_DIR}/PVE/APIClient/Commands/config.pm
+ install -D -m 0644 PVE/APIClient/Commands/list.pm ${PERL5_DIR}/PVE/APIClient/Commands/list.pm
+ install -D -m 0644 PVE/APIClient/Commands/GuestStatus.pm ${PERL5_DIR}/PVE/APIClient/Commands/GuestStatus.pm
install -D -m 0644 pve-api-definition.dat ${LIB_DIR}/pve-api-definition.dat
install -D -m 0755 pveclient ${DESTDIR}/usr/bin/pveclient
install -D -m 0644 pveclient.bash-completion ${BASHCOMPLDIR}/pveclient
+update-pve-common:
+ for i in ${PVE_COMMON_FILES}; do cp ../pve-common/src/PVE/$$i PVE/APIClient/; done
+ for i in ${PVE_COMMON_FILES}; do sed -i 's/PVE::/PVE::APIClient::/g' PVE/APIClient/$$i; done
+ # Remove INotify from CLIHandler.pm
+ sed -i 's/use PVE::APIClient::INotify;//' PVE/APIClient/CLIHandler.pm
+
+
pve-api-definition.dat:
./extractapi.pl > pve-api-definition.dat.tmp
mv pve-api-definition.dat.tmp pve-api-definition.dat
--- /dev/null
+package PVE::APIClient::CLIHandler;
+
+use strict;
+use warnings;
+
+use PVE::APIClient::SafeSyslog;
+use PVE::APIClient::Exception qw(raise raise_param_exc);
+use PVE::APIClient::RESTHandler;
+
+
+use base qw(PVE::APIClient::RESTHandler);
+
+# $cmddef defines which (sub)commands are available in a specific CLI class.
+# A real command is always an array consisting of its class, name, array of
+# position fixed (required) parameters and hash of predefined parameters when
+# mapping a CLI command t o an API call. Optionally an output method can be
+# passed at the end, e.g., for formatting or transformation purpose.
+#
+# [class, name, fixed_params, API_pre-set params, output_sub ]
+#
+# In case of so called 'simple commands', the $cmddef can be also just an
+# array.
+#
+# Examples:
+# $cmddef = {
+# command => [ 'PVE::APIClient::API2::Class', 'command', [ 'arg1', 'arg2' ], { node => $nodename } ],
+# do => {
+# this => [ 'PVE::APIClient::API2::OtherClass', 'method', [ 'arg1' ], undef, sub {
+# my ($res) = @_;
+# print "$res\n";
+# }],
+# that => [ 'PVE::APIClient::API2::OtherClass', 'subroutine' [] ],
+# },
+# dothat => { alias => 'do that' },
+# }
+my $cmddef;
+my $exename;
+my $cli_handler_class;
+
+my $assert_initialized = sub {
+ my @caller = caller;
+ die "$caller[0]:$caller[2] - not initialized\n"
+ if !($cmddef && $exename && $cli_handler_class);
+};
+
+my $abort = sub {
+ my ($reason, $cmd) = @_;
+ print_usage_short (\*STDERR, $reason, $cmd);
+ exit (-1);
+};
+
+my $expand_command_name = sub {
+ my ($def, $cmd) = @_;
+
+ return $cmd if exists $def->{$cmd}; # command is already complete
+
+ my @expanded = grep { /^\Q$cmd\E/ } keys %$def;
+ return $expanded[0] if scalar(@expanded) == 1; # enforce exact match
+
+ return undef;
+};
+
+my $get_commands = sub {
+ my $def = shift // die "no command definition passed!";
+ return [ grep { !(ref($def->{$_}) eq 'HASH' && defined($def->{$_}->{alias})) } sort keys %$def ];
+};
+
+my $complete_command_names = sub { $get_commands->($cmddef) };
+
+# traverses the command definition using the $argv array, resolving one level
+# of aliases.
+# Returns the matching (sub) command and its definition, and argument array for
+# this (sub) command and a hash where we marked which (sub) commands got
+# expanded (e.g. st => status) while traversing
+sub resolve_cmd {
+ my ($argv, $is_alias) = @_;
+
+ my ($def, $cmd) = ($cmddef, $argv);
+ my $cmdstr = $exename;
+
+ if (ref($argv) eq 'ARRAY') {
+ my $expanded_last_arg;
+ my $last_arg_id = scalar(@$argv) - 1;
+
+ for my $i (0..$last_arg_id) {
+ $cmd = $expand_command_name->($def, $argv->[$i]);
+ if (defined($cmd)) {
+ # If the argument was expanded (or was already complete) and it
+ # is the final argument, tell our caller about it:
+ $expanded_last_arg = $cmd if $i == $last_arg_id;
+ } else {
+ # Otherwise continue with the unexpanded version of it.
+ $cmd = $argv->[$i];
+ }
+ $cmdstr .= " $cmd";
+ $def = $def->{$cmd};
+ last if !defined($def);
+
+ if (ref($def) eq 'ARRAY') {
+ # could expand to a real command, rest of $argv are its arguments
+ my $cmd_args = [ @$argv[$i+1..$last_arg_id] ];
+ return ($cmd, $def, $cmd_args, $expanded_last_arg, $cmdstr);
+ }
+
+ if (defined($def->{alias})) {
+ die "alias loop detected for '$cmd'" if $is_alias; # avoids cycles
+ # replace aliased (sub)command with the expanded aliased command
+ splice @$argv, $i, 1, split(/ +/, $def->{alias});
+ return resolve_cmd($argv, 1);
+ }
+ }
+ # got either a special command (bashcomplete, verifyapi) or an unknown
+ # cmd, just return first entry as cmd and the rest of $argv as cmd_arg
+ my $cmd_args = [ @$argv[1..$last_arg_id] ];
+ return ($argv->[0], $def, $cmd_args, $expanded_last_arg, $cmdstr);
+ }
+ return ($cmd, $def, undef, undef, $cmdstr);
+}
+
+sub generate_usage_str {
+ my ($format, $cmd, $indent, $separator, $sortfunc) = @_;
+
+ $assert_initialized->();
+ die 'format required' if !$format;
+
+ $sortfunc //= sub { sort keys %{$_[0]} };
+ $separator //= '';
+ $indent //= '';
+
+ my $read_password_func = $cli_handler_class->can('read_password');
+ my $param_mapping_func = $cli_handler_class->can('param_mapping') ||
+ $cli_handler_class->can('string_param_file_mapping');
+
+ my ($subcmd, $def, undef, undef, $cmdstr) = resolve_cmd($cmd);
+ die "no such command '$cmd->[0]'\n" if !defined($def) && ref($cmd) eq 'ARRAY';
+
+ my $generate;
+ $generate = sub {
+ my ($indent, $separator, $def, $prefix) = @_;
+
+ my $str = '';
+ if (ref($def) eq 'HASH') {
+ my $oldclass = undef;
+ foreach my $cmd (&$sortfunc($def)) {
+
+ if (ref($def->{$cmd}) eq 'ARRAY') {
+ my ($class, $name, $arg_param, $fixed_param) = @{$def->{$cmd}};
+
+ $str .= $separator if $oldclass && $oldclass ne $class;
+ $str .= $indent;
+ $str .= $class->usage_str($name, "$prefix $cmd", $arg_param,
+ $fixed_param, $format,
+ $read_password_func, $param_mapping_func);
+ $oldclass = $class;
+
+ } elsif (defined($def->{$cmd}->{alias}) && ($format eq 'asciidoc')) {
+
+ $str .= "*$prefix $cmd*\n\nAn alias for '$exename $def->{$cmd}->{alias}'.\n\n";
+
+ } else {
+ next if $def->{$cmd}->{alias};
+
+ my $substr = $generate->($indent, $separator, $def->{$cmd}, "$prefix $cmd");
+ if ($substr) {
+ $substr .= $separator if $substr !~ /\Q$separator\E{2}/;
+ $str .= $substr;
+ }
+ }
+
+ }
+ } else {
+ my ($class, $name, $arg_param, $fixed_param) = @$def;
+ $abort->("unknown command '$cmd'") if !$class;
+
+ $str .= $indent;
+ $str .= $class->usage_str($name, $prefix, $arg_param, $fixed_param, $format,
+ $read_password_func, $param_mapping_func);
+ }
+ return $str;
+ };
+
+ return $generate->($indent, $separator, $def, $cmdstr);
+}
+
+__PACKAGE__->register_method ({
+ name => 'help',
+ path => 'help',
+ method => 'GET',
+ description => "Get help about specified command.",
+ parameters => {
+ additionalProperties => 0,
+ properties => {
+ 'extra-args' => PVE::APIClient::JSONSchema::get_standard_option('extra-args', {
+ description => 'Shows help for a specific command',
+ completion => $complete_command_names,
+ }),
+ verbose => {
+ description => "Verbose output format.",
+ type => 'boolean',
+ optional => 1,
+ },
+ },
+ },
+ returns => { type => 'null' },
+
+ code => sub {
+ my ($param) = @_;
+
+ $assert_initialized->();
+
+ my $cmd = $param->{'extra-args'};
+
+ my $verbose = defined($cmd) && $cmd;
+ $verbose = $param->{verbose} if defined($param->{verbose});
+
+ if (!$cmd) {
+ if ($verbose) {
+ print_usage_verbose();
+ } else {
+ print_usage_short(\*STDOUT);
+ }
+ return undef;
+ }
+
+ my $str;
+ if ($verbose) {
+ $str = generate_usage_str('full', $cmd, '');
+ } else {
+ $str = generate_usage_str('short', $cmd, ' ' x 7);
+ }
+ $str =~ s/^\s+//;
+
+ if ($verbose) {
+ print "$str\n";
+ } else {
+ print "USAGE: $str\n";
+ }
+
+ return undef;
+
+ }});
+
+sub print_simple_asciidoc_synopsis {
+ $assert_initialized->();
+
+ my $synopsis = "*${exename}* `help`\n\n";
+ $synopsis .= generate_usage_str('asciidoc');
+
+ return $synopsis;
+}
+
+sub print_asciidoc_synopsis {
+ $assert_initialized->();
+
+ my $synopsis = "";
+
+ $synopsis .= "*${exename}* `<COMMAND> [ARGS] [OPTIONS]`\n\n";
+
+ $synopsis .= generate_usage_str('asciidoc');
+
+ $synopsis .= "\n";
+
+ return $synopsis;
+}
+
+sub print_usage_verbose {
+ $assert_initialized->();
+
+ print "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n\n";
+
+ my $str = generate_usage_str('full');
+
+ print "$str\n";
+}
+
+sub print_usage_short {
+ my ($fd, $msg, $cmd) = @_;
+
+ $assert_initialized->();
+
+ print $fd "ERROR: $msg\n" if $msg;
+ print $fd "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n";
+
+ print {$fd} generate_usage_str('short', $cmd, ' ' x 7, "\n", sub {
+ my ($h) = @_;
+ return sort {
+ if (ref($h->{$a}) eq 'ARRAY' && ref($h->{$b}) eq 'ARRAY') {
+ # $a and $b are both real commands order them by their class
+ return $h->{$a}->[0] cmp $h->{$b}->[0] || $a cmp $b;
+ } elsif (ref($h->{$a}) eq 'ARRAY' xor ref($h->{$b}) eq 'ARRAY') {
+ # real command and subcommand mixed, put sub commands first
+ return ref($h->{$b}) eq 'ARRAY' ? -1 : 1;
+ } else {
+ # both are either from the same class or subcommands
+ return $a cmp $b;
+ }
+ } keys %$h;
+ });
+}
+
+my $print_bash_completion = sub {
+ my ($simple_cmd, $bash_command, $cur, $prev) = @_;
+
+ my $debug = 0;
+
+ return if !(defined($cur) && defined($prev) && defined($bash_command));
+ return if !defined($ENV{COMP_LINE});
+ return if !defined($ENV{COMP_POINT});
+
+ my $cmdline = substr($ENV{COMP_LINE}, 0, $ENV{COMP_POINT});
+ print STDERR "\nCMDLINE: $ENV{COMP_LINE}\n" if $debug;
+
+ my $args = PVE::APIClient::Tools::split_args($cmdline);
+ shift @$args; # no need for program name
+ my $print_result = sub {
+ foreach my $p (@_) {
+ print "$p\n" if $p =~ m/^$cur/;
+ }
+ };
+
+ my ($cmd, $def) = ($simple_cmd, $cmddef);
+ if (!$simple_cmd) {
+ ($cmd, $def, $args, my $expanded) = resolve_cmd($args);
+
+ if (defined($expanded) && $prev ne $expanded) {
+ print "$expanded\n";
+ return;
+ }
+
+ if (ref($def) eq 'HASH') {
+ &$print_result(@{$get_commands->($def)});
+ return;
+ }
+ }
+ return if !$def;
+
+ my $pos = scalar(@$args) - 1;
+ $pos += 1 if $cmdline =~ m/\s+$/;
+ print STDERR "pos: $pos\n" if $debug;
+ return if $pos < 0;
+
+ my $skip_param = {};
+
+ my ($class, $name, $arg_param, $uri_param) = @$def;
+ $arg_param //= [];
+ $uri_param //= {};
+
+ $arg_param = [ $arg_param ] if !ref($arg_param);
+
+ map { $skip_param->{$_} = 1; } @$arg_param;
+ map { $skip_param->{$_} = 1; } keys %$uri_param;
+
+ my $info = $class->map_method_by_name($name);
+
+ my $prop = $info->{parameters}->{properties};
+
+ my $print_parameter_completion = sub {
+ my ($pname) = @_;
+ my $d = $prop->{$pname};
+ if ($d->{completion}) {
+ my $vt = ref($d->{completion});
+ if ($vt eq 'CODE') {
+ my $res = $d->{completion}->($cmd, $pname, $cur, $args);
+ &$print_result(@$res);
+ }
+ } elsif ($d->{type} eq 'boolean') {
+ &$print_result('0', '1');
+ } elsif ($d->{enum}) {
+ &$print_result(@{$d->{enum}});
+ }
+ };
+
+ # positional arguments
+ if ($pos < scalar(@$arg_param)) {
+ my $pname = $arg_param->[$pos];
+ &$print_parameter_completion($pname);
+ return;
+ }
+
+ my @option_list = ();
+ foreach my $key (keys %$prop) {
+ next if $skip_param->{$key};
+ push @option_list, "--$key";
+ }
+
+ if ($cur =~ m/^-/) {
+ &$print_result(@option_list);
+ return;
+ }
+
+ if ($prev =~ m/^--?(.+)$/ && $prop->{$1}) {
+ my $pname = $1;
+ &$print_parameter_completion($pname);
+ return;
+ }
+
+ &$print_result(@option_list);
+};
+
+sub verify_api {
+ my ($class) = @_;
+
+ # simply verify all registered methods
+ PVE::APIClient::RESTHandler::validate_method_schemas();
+}
+
+my $get_exe_name = sub {
+ my ($class) = @_;
+
+ my $name = $class;
+ $name =~ s/^.*:://;
+ $name =~ s/_/-/g;
+
+ return $name;
+};
+
+sub generate_bash_completions {
+ my ($class) = @_;
+
+ # generate bash completion config
+
+ $exename = &$get_exe_name($class);
+
+ print <<__EOD__;
+# $exename bash completion
+
+# see http://tiswww.case.edu/php/chet/bash/FAQ
+# and __ltrim_colon_completions() in /usr/share/bash-completion/bash_completion
+# this modifies global var, but I found no better way
+COMP_WORDBREAKS=\${COMP_WORDBREAKS//:}
+
+complete -o default -C '$exename bashcomplete' $exename
+__EOD__
+}
+
+sub generate_asciidoc_synopsys {
+ my ($class) = @_;
+ $class->generate_asciidoc_synopsis();
+};
+
+sub generate_asciidoc_synopsis {
+ my ($class) = @_;
+
+ $cli_handler_class = $class;
+
+ $exename = &$get_exe_name($class);
+
+ no strict 'refs';
+ my $def = ${"${class}::cmddef"};
+ $cmddef = $def;
+
+ if (ref($def) eq 'ARRAY') {
+ print_simple_asciidoc_synopsis();
+ } else {
+ $cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ];
+
+ print_asciidoc_synopsis();
+ }
+}
+
+# overwrite this if you want to run/setup things early
+sub setup_environment {
+ my ($class) = @_;
+
+ # do nothing by default
+}
+
+my $handle_cmd = sub {
+ my ($args, $read_password_func, $preparefunc, $param_mapping_func) = @_;
+
+ $cmddef->{help} = [ __PACKAGE__, 'help', ['extra-args'] ];
+
+ my ($cmd, $def, $cmd_args, undef, $cmd_str) = resolve_cmd($args);
+
+ $abort->("no command specified") if !$cmd;
+
+ # call verifyapi before setup_environment(), don't execute any real code in
+ # this case
+ if ($cmd eq 'verifyapi') {
+ PVE::APIClient::RESTHandler::validate_method_schemas();
+ return;
+ }
+
+ $cli_handler_class->setup_environment();
+
+ if ($cmd eq 'bashcomplete') {
+ &$print_bash_completion(undef, @$cmd_args);
+ return;
+ }
+
+ # checked special commands, if def is still a hash we got an incomplete sub command
+ $abort->("incomplete command '$cmd_str'") if ref($def) eq 'HASH';
+
+ &$preparefunc() if $preparefunc;
+
+ my ($class, $name, $arg_param, $uri_param, $outsub) = @{$def || []};
+ $abort->("unknown command '$cmd_str'") if !$class;
+
+ my $res = $class->cli_handler($cmd_str, $name, $cmd_args, $arg_param, $uri_param, $read_password_func, $param_mapping_func);
+
+ &$outsub($res) if $outsub;
+};
+
+my $handle_simple_cmd = sub {
+ my ($args, $read_password_func, $preparefunc, $param_mapping_func) = @_;
+
+ my ($class, $name, $arg_param, $uri_param, $outsub) = @{$cmddef};
+ die "no class specified" if !$class;
+
+ if (scalar(@$args) >= 1) {
+ if ($args->[0] eq 'help') {
+ my $str = "USAGE: $name help\n";
+ $str .= generate_usage_str('long');
+ print STDERR "$str\n\n";
+ return;
+ } elsif ($args->[0] eq 'verifyapi') {
+ PVE::APIClient::RESTHandler::validate_method_schemas();
+ return;
+ }
+ }
+
+ $cli_handler_class->setup_environment();
+
+ if (scalar(@$args) >= 1) {
+ if ($args->[0] eq 'bashcomplete') {
+ shift @$args;
+ &$print_bash_completion($name, @$args);
+ return;
+ }
+ }
+
+ &$preparefunc() if $preparefunc;
+
+ my $res = $class->cli_handler($name, $name, \@ARGV, $arg_param, $uri_param, $read_password_func, $param_mapping_func);
+
+ &$outsub($res) if $outsub;
+};
+
+sub run_cli_handler {
+ my ($class, %params) = @_;
+
+ $cli_handler_class = $class;
+
+ $ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin';
+
+ foreach my $key (keys %params) {
+ next if $key eq 'prepare';
+ next if $key eq 'no_init'; # not used anymore
+ next if $key eq 'no_rpcenv'; # not used anymore
+ die "unknown parameter '$key'";
+ }
+
+ my $preparefunc = $params{prepare};
+
+ my $read_password_func = $class->can('read_password');
+ my $param_mapping_func = $cli_handler_class->can('param_mapping') ||
+ $class->can('string_param_file_mapping');
+
+ $exename = &$get_exe_name($class);
+
+ initlog($exename);
+
+ no strict 'refs';
+ $cmddef = ${"${class}::cmddef"};
+
+ if (ref($cmddef) eq 'ARRAY') {
+ &$handle_simple_cmd(\@ARGV, $read_password_func, $preparefunc, $param_mapping_func);
+ } else {
+ &$handle_cmd(\@ARGV, $read_password_func, $preparefunc, $param_mapping_func);
+ }
+
+ exit 0;
+}
+
+1;
code => sub {
my ($param) = @_;
- my $remote = PVE::Tools::extract_param($param, 'remote');
- my $vmid = PVE::Tools::extract_param($param, 'vmid');
+ my $remote = PVE::APIClient::Tools::extract_param($param, 'remote');
+ my $vmid = PVE::APIClient::Tools::extract_param($param, 'vmid');
$guest_status_command->($remote, $vmid, 'start', $param);
code => sub {
my ($param) = @_;
- my $remote = PVE::Tools::extract_param($param, 'remote');
- my $vmid = PVE::Tools::extract_param($param, 'vmid');
+ my $remote = PVE::APIClient::Tools::extract_param($param, 'remote');
+ my $vmid = PVE::APIClient::Tools::extract_param($param, 'vmid');
$guest_status_command->($remote, $vmid, 'stop', $param);
use Data::Dumper;
use PVE::JSONSchema qw(get_standard_option);
-use PVE::Tools qw(extract_param);
+use PVE::APIClient::Tools qw(extract_param);
use PVE::APIClient::Config;
use PVE::CLIHandler;
if ($delete) {
my $options = $plugin->private()->{options}->{'defaults'};
- foreach my $k (PVE::Tools::split_list($delete)) {
+ foreach my $k (PVE::APIClient::Tools::split_list($delete)) {
my $d = $options->{$k} ||
die "no such option '$k'\n";
die "unable to delete required option '$k'\n"
use Digest::SHA;
use HTTP::Response;
-use PVE::Tools;
use PVE::JSONSchema qw(get_standard_option);
use PVE::CLIHandler;
use PVE::PTY;
use warnings;
use PVE::JSONSchema qw(get_standard_option);
-use PVE::Tools qw(extract_param);
+use PVE::APIClient::Tools qw(extract_param);
use PVE::APIClient::Config;
use PVE::CLIHandler;
if ($delete) {
my $options = $plugin->private()->{options}->{'remote'};
- foreach my $k (PVE::Tools::split_list($delete)) {
+ foreach my $k (PVE::APIClient::Tools::APIClient::split_list($delete)) {
my $d = $options->{$k} ||
die "no such option '$k'\n";
die "unable to delete required option '$k'\n"
use PVE::JSONSchema;
use PVE::SectionConfig;
-use PVE::Tools qw(file_get_contents file_set_contents);
+use PVE::APIClient::Tools qw(file_get_contents file_set_contents);
use base qw(PVE::SectionConfig);
$test_path_properties->([$0, @ARGV]);
} elsif ($cmd eq 'bashcomplete') {
my $cmdline = substr($ENV{COMP_LINE}, 0, $ENV{COMP_POINT});
- my $args = PVE::Tools::split_args($cmdline);
+ my $args = PVE::APIClient::Tools::split_args($cmdline);
$test_path_properties->($args);
}
}
--- /dev/null
+package PVE::APIClient::JSONSchema;
+
+use strict;
+use warnings;
+use Storable; # for dclone
+use Getopt::Long;
+use Encode::Locale;
+use Encode;
+use Devel::Cycle -quiet; # todo: remove?
+use PVE::APIClient::Tools qw(split_list $IPV6RE $IPV4RE);
+use PVE::APIClient::Exception qw(raise);
+use HTTP::Status qw(:constants);
+use Net::IP qw(:PROC);
+use Data::Dumper;
+
+use base 'Exporter';
+
+our @EXPORT_OK = qw(
+register_standard_option
+get_standard_option
+);
+
+# Note: This class implements something similar to JSON schema, but it is not 100% complete.
+# see: http://tools.ietf.org/html/draft-zyp-json-schema-02
+# see: http://json-schema.org/
+
+# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
+
+my $standard_options = {};
+sub register_standard_option {
+ my ($name, $schema) = @_;
+
+ die "standard option '$name' already registered\n"
+ if $standard_options->{$name};
+
+ $standard_options->{$name} = $schema;
+}
+
+sub get_standard_option {
+ my ($name, $base) = @_;
+
+ my $std = $standard_options->{$name};
+ die "no such standard option '$name'\n" if !$std;
+
+ my $res = $base || {};
+
+ foreach my $opt (keys %$std) {
+ next if defined($res->{$opt});
+ $res->{$opt} = $std->{$opt};
+ }
+
+ return $res;
+};
+
+register_standard_option('pve-vmid', {
+ description => "The (unique) ID of the VM.",
+ type => 'integer', format => 'pve-vmid',
+ minimum => 1
+});
+
+register_standard_option('pve-node', {
+ description => "The cluster node name.",
+ type => 'string', format => 'pve-node',
+});
+
+register_standard_option('pve-node-list', {
+ description => "List of cluster node names.",
+ type => 'string', format => 'pve-node-list',
+});
+
+register_standard_option('pve-iface', {
+ description => "Network interface name.",
+ type => 'string', format => 'pve-iface',
+ minLength => 2, maxLength => 20,
+});
+
+register_standard_option('pve-storage-id', {
+ description => "The storage identifier.",
+ type => 'string', format => 'pve-storage-id',
+});
+
+register_standard_option('pve-config-digest', {
+ description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
+ type => 'string',
+ optional => 1,
+ maxLength => 40, # sha1 hex digest lenght is 40
+});
+
+register_standard_option('skiplock', {
+ description => "Ignore locks - only root is allowed to use this option.",
+ type => 'boolean',
+ optional => 1,
+});
+
+register_standard_option('extra-args', {
+ description => "Extra arguments as array",
+ type => 'array',
+ items => { type => 'string' },
+ optional => 1
+});
+
+register_standard_option('fingerprint-sha256', {
+ description => "Certificate SHA 256 fingerprint.",
+ type => 'string',
+ pattern => '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
+});
+
+my $format_list = {};
+
+sub register_format {
+ my ($format, $code) = @_;
+
+ die "JSON schema format '$format' already registered\n"
+ if $format_list->{$format};
+
+ $format_list->{$format} = $code;
+}
+
+sub get_format {
+ my ($format) = @_;
+ return $format_list->{$format};
+}
+
+# register some common type for pve
+
+register_format('string', sub {}); # allow format => 'string-list'
+
+register_format('urlencoded', \&pve_verify_urlencoded);
+sub pve_verify_urlencoded {
+ my ($text, $noerr) = @_;
+ if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
+ return undef if $noerr;
+ die "invalid urlencoded string: $text\n";
+ }
+ return $text;
+}
+
+register_format('pve-configid', \&pve_verify_configid);
+sub pve_verify_configid {
+ my ($id, $noerr) = @_;
+
+ if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
+ return undef if $noerr;
+ die "invalid configuration ID '$id'\n";
+ }
+ return $id;
+}
+
+PVE::APIClient::JSONSchema::register_format('pve-storage-id', \&parse_storage_id);
+sub parse_storage_id {
+ my ($storeid, $noerr) = @_;
+
+ if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
+ return undef if $noerr;
+ die "storage ID '$storeid' contains illegal characters\n";
+ }
+ return $storeid;
+}
+
+
+register_format('pve-vmid', \&pve_verify_vmid);
+sub pve_verify_vmid {
+ my ($vmid, $noerr) = @_;
+
+ if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
+ return undef if $noerr;
+ die "value does not look like a valid VM ID\n";
+ }
+ return $vmid;
+}
+
+register_format('pve-node', \&pve_verify_node_name);
+sub pve_verify_node_name {
+ my ($node, $noerr) = @_;
+
+ if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
+ return undef if $noerr;
+ die "value does not look like a valid node name\n";
+ }
+ return $node;
+}
+
+register_format('ipv4', \&pve_verify_ipv4);
+sub pve_verify_ipv4 {
+ my ($ipv4, $noerr) = @_;
+
+ if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
+ return undef if $noerr;
+ die "value does not look like a valid IPv4 address\n";
+ }
+ return $ipv4;
+}
+
+register_format('ipv6', \&pve_verify_ipv6);
+sub pve_verify_ipv6 {
+ my ($ipv6, $noerr) = @_;
+
+ if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
+ return undef if $noerr;
+ die "value does not look like a valid IPv6 address\n";
+ }
+ return $ipv6;
+}
+
+register_format('ip', \&pve_verify_ip);
+sub pve_verify_ip {
+ my ($ip, $noerr) = @_;
+
+ if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
+ return undef if $noerr;
+ die "value does not look like a valid IP address\n";
+ }
+ return $ip;
+}
+
+my $ipv4_mask_hash = {
+ '128.0.0.0' => 1,
+ '192.0.0.0' => 2,
+ '224.0.0.0' => 3,
+ '240.0.0.0' => 4,
+ '248.0.0.0' => 5,
+ '252.0.0.0' => 6,
+ '254.0.0.0' => 7,
+ '255.0.0.0' => 8,
+ '255.128.0.0' => 9,
+ '255.192.0.0' => 10,
+ '255.224.0.0' => 11,
+ '255.240.0.0' => 12,
+ '255.248.0.0' => 13,
+ '255.252.0.0' => 14,
+ '255.254.0.0' => 15,
+ '255.255.0.0' => 16,
+ '255.255.128.0' => 17,
+ '255.255.192.0' => 18,
+ '255.255.224.0' => 19,
+ '255.255.240.0' => 20,
+ '255.255.248.0' => 21,
+ '255.255.252.0' => 22,
+ '255.255.254.0' => 23,
+ '255.255.255.0' => 24,
+ '255.255.255.128' => 25,
+ '255.255.255.192' => 26,
+ '255.255.255.224' => 27,
+ '255.255.255.240' => 28,
+ '255.255.255.248' => 29,
+ '255.255.255.252' => 30,
+ '255.255.255.254' => 31,
+ '255.255.255.255' => 32,
+};
+
+register_format('ipv4mask', \&pve_verify_ipv4mask);
+sub pve_verify_ipv4mask {
+ my ($mask, $noerr) = @_;
+
+ if (!defined($ipv4_mask_hash->{$mask})) {
+ return undef if $noerr;
+ die "value does not look like a valid IP netmask\n";
+ }
+ return $mask;
+}
+
+register_format('CIDRv6', \&pve_verify_cidrv6);
+sub pve_verify_cidrv6 {
+ my ($cidr, $noerr) = @_;
+
+ if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
+ return $cidr;
+ }
+
+ return undef if $noerr;
+ die "value does not look like a valid IPv6 CIDR network\n";
+}
+
+register_format('CIDRv4', \&pve_verify_cidrv4);
+sub pve_verify_cidrv4 {
+ my ($cidr, $noerr) = @_;
+
+ if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
+ return $cidr;
+ }
+
+ return undef if $noerr;
+ die "value does not look like a valid IPv4 CIDR network\n";
+}
+
+register_format('CIDR', \&pve_verify_cidr);
+sub pve_verify_cidr {
+ my ($cidr, $noerr) = @_;
+
+ if (!(pve_verify_cidrv4($cidr, 1) ||
+ pve_verify_cidrv6($cidr, 1)))
+ {
+ return undef if $noerr;
+ die "value does not look like a valid CIDR network\n";
+ }
+
+ return $cidr;
+}
+
+register_format('pve-ipv4-config', \&pve_verify_ipv4_config);
+sub pve_verify_ipv4_config {
+ my ($config, $noerr) = @_;
+
+ return $config if $config =~ /^(?:dhcp|manual)$/ ||
+ pve_verify_cidrv4($config, 1);
+ return undef if $noerr;
+ die "value does not look like a valid ipv4 network configuration\n";
+}
+
+register_format('pve-ipv6-config', \&pve_verify_ipv6_config);
+sub pve_verify_ipv6_config {
+ my ($config, $noerr) = @_;
+
+ return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
+ pve_verify_cidrv6($config, 1);
+ return undef if $noerr;
+ die "value does not look like a valid ipv6 network configuration\n";
+}
+
+register_format('email', \&pve_verify_email);
+sub pve_verify_email {
+ my ($email, $noerr) = @_;
+
+ # we use same regex as in Utils.js
+ if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,63}$/) {
+ return undef if $noerr;
+ die "value does not look like a valid email address\n";
+ }
+ return $email;
+}
+
+register_format('dns-name', \&pve_verify_dns_name);
+sub pve_verify_dns_name {
+ my ($name, $noerr) = @_;
+
+ my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
+
+ if ($name !~ /^(${namere}\.)*${namere}$/) {
+ return undef if $noerr;
+ die "value does not look like a valid DNS name\n";
+ }
+ return $name;
+}
+
+# network interface name
+register_format('pve-iface', \&pve_verify_iface);
+sub pve_verify_iface {
+ my ($id, $noerr) = @_;
+
+ if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
+ return undef if $noerr;
+ die "invalid network interface name '$id'\n";
+ }
+ return $id;
+}
+
+# general addresses by name or IP
+register_format('address', \&pve_verify_address);
+sub pve_verify_address {
+ my ($addr, $noerr) = @_;
+
+ if (!(pve_verify_ip($addr, 1) ||
+ pve_verify_dns_name($addr, 1)))
+ {
+ return undef if $noerr;
+ die "value does not look like a valid address: $addr\n";
+ }
+ return $addr;
+}
+
+register_format('disk-size', \&pve_verify_disk_size);
+sub pve_verify_disk_size {
+ my ($size, $noerr) = @_;
+ if (!defined(parse_size($size))) {
+ return undef if $noerr;
+ die "value does not look like a valid disk size: $size\n";
+ }
+ return $size;
+}
+
+register_standard_option('spice-proxy', {
+ description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
+ type => 'string', format => 'address',
+});
+
+register_standard_option('remote-viewer-config', {
+ description => "Returned values can be directly passed to the 'remote-viewer' application.",
+ additionalProperties => 1,
+ properties => {
+ type => { type => 'string' },
+ password => { type => 'string' },
+ proxy => { type => 'string' },
+ host => { type => 'string' },
+ 'tls-port' => { type => 'integer' },
+ },
+});
+
+register_format('pve-startup-order', \&pve_verify_startup_order);
+sub pve_verify_startup_order {
+ my ($value, $noerr) = @_;
+
+ return $value if pve_parse_startup_order($value);
+
+ return undef if $noerr;
+
+ die "unable to parse startup options\n";
+}
+
+my %bwlimit_opt = (
+ optional => 1,
+ type => 'number', minimum => '0',
+ format_description => 'LIMIT',
+);
+
+my $bwlimit_format = {
+ default => {
+ %bwlimit_opt,
+ description => 'default bandwidth limit in MiB/s',
+ },
+ restore => {
+ %bwlimit_opt,
+ description => 'bandwidth limit in MiB/s for restoring guests from backups',
+ },
+ migration => {
+ %bwlimit_opt,
+ description => 'bandwidth limit in MiB/s for migrating guests',
+ },
+ clone => {
+ %bwlimit_opt,
+ description => 'bandwidth limit in MiB/s for cloning disks',
+ },
+ move => {
+ %bwlimit_opt,
+ description => 'bandwidth limit in MiB/s for moving disks',
+ },
+};
+register_format('bwlimit', $bwlimit_format);
+register_standard_option('bwlimit', {
+ description => "Set bandwidth/io limits various operations.",
+ optional => 1,
+ type => 'string',
+ format => $bwlimit_format,
+});
+
+sub pve_parse_startup_order {
+ my ($value) = @_;
+
+ return undef if !$value;
+
+ my $res = {};
+
+ foreach my $p (split(/,/, $value)) {
+ next if $p =~ m/^\s*$/;
+
+ if ($p =~ m/^(order=)?(\d+)$/) {
+ $res->{order} = $2;
+ } elsif ($p =~ m/^up=(\d+)$/) {
+ $res->{up} = $1;
+ } elsif ($p =~ m/^down=(\d+)$/) {
+ $res->{down} = $1;
+ } else {
+ return undef;
+ }
+ }
+
+ return $res;
+}
+
+PVE::APIClient::JSONSchema::register_standard_option('pve-startup-order', {
+ description => "Startup and shutdown behavior. Order is a non-negative number defining the general startup order. Shutdown in done with reverse ordering. Additionally you can set the 'up' or 'down' delay in seconds, which specifies a delay to wait before the next VM is started or stopped.",
+ optional => 1,
+ type => 'string', format => 'pve-startup-order',
+ typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
+});
+
+sub check_format {
+ my ($format, $value, $path) = @_;
+
+ return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
+ return if $format eq 'regex';
+
+ if ($format =~ m/^(.*)-a?list$/) {
+
+ my $code = $format_list->{$1};
+
+ die "undefined format '$format'\n" if !$code;
+
+ # Note: we allow empty lists
+ foreach my $v (split_list($value)) {
+ &$code($v);
+ }
+
+ } elsif ($format =~ m/^(.*)-opt$/) {
+
+ my $code = $format_list->{$1};
+
+ die "undefined format '$format'\n" if !$code;
+
+ return if !$value; # allow empty string
+
+ &$code($value);
+
+ } else {
+
+ my $code = $format_list->{$format};
+
+ die "undefined format '$format'\n" if !$code;
+
+ return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
+ &$code($value);
+ }
+}
+
+sub parse_size {
+ my ($value) = @_;
+
+ return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
+ my ($size, $unit) = ($1, $3);
+ if ($unit) {
+ if ($unit eq 'K') {
+ $size = $size * 1024;
+ } elsif ($unit eq 'M') {
+ $size = $size * 1024 * 1024;
+ } elsif ($unit eq 'G') {
+ $size = $size * 1024 * 1024 * 1024;
+ } elsif ($unit eq 'T') {
+ $size = $size * 1024 * 1024 * 1024 * 1024;
+ }
+ }
+ return int($size);
+};
+
+sub format_size {
+ my ($size) = @_;
+
+ $size = int($size);
+
+ my $kb = int($size/1024);
+ return $size if $kb*1024 != $size;
+
+ my $mb = int($kb/1024);
+ return "${kb}K" if $mb*1024 != $kb;
+
+ my $gb = int($mb/1024);
+ return "${mb}M" if $gb*1024 != $mb;
+
+ my $tb = int($gb/1024);
+ return "${gb}G" if $tb*1024 != $gb;
+
+ return "${tb}T";
+};
+
+sub parse_boolean {
+ my ($bool) = @_;
+ return 1 if $bool =~ m/^(1|on|yes|true)$/i;
+ return 0 if $bool =~ m/^(0|off|no|false)$/i;
+ return undef;
+}
+
+sub parse_property_string {
+ my ($format, $data, $path, $additional_properties) = @_;
+
+ # In property strings we default to not allowing additional properties
+ $additional_properties = 0 if !defined($additional_properties);
+
+ # Support named formats here, too:
+ if (!ref($format)) {
+ if (my $desc = $format_list->{$format}) {
+ $format = $desc;
+ } else {
+ die "unknown format: $format\n";
+ }
+ } elsif (ref($format) ne 'HASH') {
+ die "unexpected format value of type ".ref($format)."\n";
+ }
+
+ my $default_key;
+
+ my $res = {};
+ foreach my $part (split(/,/, $data)) {
+ next if $part =~ /^\s*$/;
+
+ if ($part =~ /^([^=]+)=(.+)$/) {
+ my ($k, $v) = ($1, $2);
+ die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
+ my $schema = $format->{$k};
+ if (my $alias = $schema->{alias}) {
+ if (my $key_alias = $schema->{keyAlias}) {
+ die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
+ $res->{$key_alias} = $k;
+ }
+ $k = $alias;
+ $schema = $format->{$k};
+ }
+
+ die "invalid key in comma-separated list property: $k\n" if !$schema;
+ if ($schema->{type} && $schema->{type} eq 'boolean') {
+ $v = parse_boolean($v) // $v;
+ }
+ $res->{$k} = $v;
+ } elsif ($part !~ /=/) {
+ die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
+ foreach my $key (keys %$format) {
+ if ($format->{$key}->{default_key}) {
+ $default_key = $key;
+ if (!$res->{$default_key}) {
+ $res->{$default_key} = $part;
+ last;
+ }
+ die "duplicate key in comma-separated list property: $default_key\n";
+ }
+ }
+ die "value without key, but schema does not define a default key\n" if !$default_key;
+ } else {
+ die "missing key in comma-separated list property\n";
+ }
+ }
+
+ my $errors = {};
+ check_object($path, $format, $res, $additional_properties, $errors);
+ if (scalar(%$errors)) {
+ raise "format error\n", errors => $errors;
+ }
+
+ return $res;
+}
+
+sub add_error {
+ my ($errors, $path, $msg) = @_;
+
+ $path = '_root' if !$path;
+
+ if ($errors->{$path}) {
+ $errors->{$path} = join ('\n', $errors->{$path}, $msg);
+ } else {
+ $errors->{$path} = $msg;
+ }
+}
+
+sub is_number {
+ my $value = shift;
+
+ # see 'man perlretut'
+ return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
+}
+
+sub is_integer {
+ my $value = shift;
+
+ return $value =~ m/^[+-]?\d+$/;
+}
+
+sub check_type {
+ my ($path, $type, $value, $errors) = @_;
+
+ return 1 if !$type;
+
+ if (!defined($value)) {
+ return 1 if $type eq 'null';
+ die "internal error"
+ }
+
+ if (my $tt = ref($type)) {
+ if ($tt eq 'ARRAY') {
+ foreach my $t (@$type) {
+ my $tmperr = {};
+ check_type($path, $t, $value, $tmperr);
+ return 1 if !scalar(%$tmperr);
+ }
+ my $ttext = join ('|', @$type);
+ add_error($errors, $path, "type check ('$ttext') failed");
+ return undef;
+ } elsif ($tt eq 'HASH') {
+ my $tmperr = {};
+ check_prop($value, $type, $path, $tmperr);
+ return 1 if !scalar(%$tmperr);
+ add_error($errors, $path, "type check failed");
+ return undef;
+ } else {
+ die "internal error - got reference type '$tt'";
+ }
+
+ } else {
+
+ return 1 if $type eq 'any';
+
+ if ($type eq 'null') {
+ if (defined($value)) {
+ add_error($errors, $path, "type check ('$type') failed - value is not null");
+ return undef;
+ }
+ return 1;
+ }
+
+ my $vt = ref($value);
+
+ if ($type eq 'array') {
+ if (!$vt || $vt ne 'ARRAY') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'object') {
+ if (!$vt || $vt ne 'HASH') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'coderef') {
+ if (!$vt || $vt ne 'CODE') {
+ add_error($errors, $path, "type check ('$type') failed");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'string' && $vt eq 'Regexp') {
+ # qr// regexes can be used as strings and make sense for format=regex
+ return 1;
+ } else {
+ if ($vt) {
+ add_error($errors, $path, "type check ('$type') failed - got $vt");
+ return undef;
+ } else {
+ if ($type eq 'string') {
+ return 1; # nothing to check ?
+ } elsif ($type eq 'boolean') {
+ #if ($value =~ m/^(1|true|yes|on)$/i) {
+ if ($value eq '1') {
+ return 1;
+ #} elsif ($value =~ m/^(0|false|no|off)$/i) {
+ } elsif ($value eq '0') {
+ return 1; # return success (not value)
+ } else {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ } elsif ($type eq 'integer') {
+ if (!is_integer($value)) {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ return 1;
+ } elsif ($type eq 'number') {
+ if (!is_number($value)) {
+ add_error($errors, $path, "type check ('$type') failed - got '$value'");
+ return undef;
+ }
+ return 1;
+ } else {
+ return 1; # no need to verify unknown types
+ }
+ }
+ }
+ }
+
+ return undef;
+}
+
+sub check_object {
+ my ($path, $schema, $value, $additional_properties, $errors) = @_;
+
+ # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
+
+ my $st = ref($schema);
+ if (!$st || $st ne 'HASH') {
+ add_error($errors, $path, "Invalid schema definition.");
+ return;
+ }
+
+ my $vt = ref($value);
+ if (!$vt || $vt ne 'HASH') {
+ add_error($errors, $path, "an object is required");
+ return;
+ }
+
+ foreach my $k (keys %$schema) {
+ check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
+ }
+
+ foreach my $k (keys %$value) {
+
+ my $newpath = $path ? "$path.$k" : $k;
+
+ if (my $subschema = $schema->{$k}) {
+ if (my $requires = $subschema->{requires}) {
+ if (ref($requires)) {
+ #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
+ check_prop($value, $requires, $path, $errors);
+ } elsif (!defined($value->{$requires})) {
+ add_error($errors, $path ? "$path.$requires" : $requires,
+ "missing property - '$newpath' requires this property");
+ }
+ }
+
+ next; # value is already checked above
+ }
+
+ if (defined ($additional_properties) && !$additional_properties) {
+ add_error($errors, $newpath, "property is not defined in schema " .
+ "and the schema does not allow additional properties");
+ next;
+ }
+ check_prop($value->{$k}, $additional_properties, $newpath, $errors)
+ if ref($additional_properties);
+ }
+}
+
+sub check_object_warn {
+ my ($path, $schema, $value, $additional_properties) = @_;
+ my $errors = {};
+ check_object($path, $schema, $value, $additional_properties, $errors);
+ if (scalar(%$errors)) {
+ foreach my $k (keys %$errors) {
+ warn "parse error: $k: $errors->{$k}\n";
+ }
+ return 0;
+ }
+ return 1;
+}
+
+sub check_prop {
+ my ($value, $schema, $path, $errors) = @_;
+
+ die "internal error - no schema" if !$schema;
+ die "internal error" if !$errors;
+
+ #print "check_prop $path\n" if $value;
+
+ my $st = ref($schema);
+ if (!$st || $st ne 'HASH') {
+ add_error($errors, $path, "Invalid schema definition.");
+ return;
+ }
+
+ # if it extends another schema, it must pass that schema as well
+ if($schema->{extends}) {
+ check_prop($value, $schema->{extends}, $path, $errors);
+ }
+
+ if (!defined ($value)) {
+ return if $schema->{type} && $schema->{type} eq 'null';
+ if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
+ add_error($errors, $path, "property is missing and it is not optional");
+ }
+ return;
+ }
+
+ return if !check_type($path, $schema->{type}, $value, $errors);
+
+ if ($schema->{disallow}) {
+ my $tmperr = {};
+ if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
+ add_error($errors, $path, "disallowed value was matched");
+ return;
+ }
+ }
+
+ if (my $vt = ref($value)) {
+
+ if ($vt eq 'ARRAY') {
+ if ($schema->{items}) {
+ my $it = ref($schema->{items});
+ if ($it && $it eq 'ARRAY') {
+ #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
+ die "not implemented";
+ } else {
+ my $ind = 0;
+ foreach my $el (@$value) {
+ check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
+ $ind++;
+ }
+ }
+ }
+ return;
+ } elsif ($schema->{properties} || $schema->{additionalProperties}) {
+ check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
+ $value, $schema->{additionalProperties}, $errors);
+ return;
+ }
+
+ } else {
+
+ if (my $format = $schema->{format}) {
+ eval { check_format($format, $value, $path); };
+ if ($@) {
+ add_error($errors, $path, "invalid format - $@");
+ return;
+ }
+ }
+
+ if (my $pattern = $schema->{pattern}) {
+ if ($value !~ m/^$pattern$/) {
+ add_error($errors, $path, "value does not match the regex pattern");
+ return;
+ }
+ }
+
+ if (defined (my $max = $schema->{maxLength})) {
+ if (length($value) > $max) {
+ add_error($errors, $path, "value may only be $max characters long");
+ return;
+ }
+ }
+
+ if (defined (my $min = $schema->{minLength})) {
+ if (length($value) < $min) {
+ add_error($errors, $path, "value must be at least $min characters long");
+ return;
+ }
+ }
+
+ if (is_number($value)) {
+ if (defined (my $max = $schema->{maximum})) {
+ if ($value > $max) {
+ add_error($errors, $path, "value must have a maximum value of $max");
+ return;
+ }
+ }
+
+ if (defined (my $min = $schema->{minimum})) {
+ if ($value < $min) {
+ add_error($errors, $path, "value must have a minimum value of $min");
+ return;
+ }
+ }
+ }
+
+ if (my $ea = $schema->{enum}) {
+
+ my $found;
+ foreach my $ev (@$ea) {
+ if ($ev eq $value) {
+ $found = 1;
+ last;
+ }
+ }
+ if (!$found) {
+ add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
+ join(", ", @$ea) . "'");
+ }
+ }
+ }
+}
+
+sub validate {
+ my ($instance, $schema, $errmsg) = @_;
+
+ my $errors = {};
+ $errmsg = "Parameter verification failed.\n" if !$errmsg;
+
+ # todo: cycle detection is only needed for debugging, I guess
+ # we can disable that in the final release
+ # todo: is there a better/faster way to detect cycles?
+ my $cycles = 0;
+ find_cycle($instance, sub { $cycles = 1 });
+ if ($cycles) {
+ add_error($errors, undef, "data structure contains recursive cycles");
+ } elsif ($schema) {
+ check_prop($instance, $schema, '', $errors);
+ }
+
+ if (scalar(%$errors)) {
+ raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
+ }
+
+ return 1;
+}
+
+my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
+my $default_schema_noref = {
+ description => "This is the JSON Schema for JSON Schemas.",
+ type => [ "object" ],
+ additionalProperties => 0,
+ properties => {
+ type => {
+ type => ["string", "array"],
+ description => "This is a type definition value. This can be a simple type, or a union type",
+ optional => 1,
+ default => "any",
+ items => {
+ type => "string",
+ enum => $schema_valid_types,
+ },
+ enum => $schema_valid_types,
+ },
+ optional => {
+ type => "boolean",
+ description => "This indicates that the instance property in the instance object is not required.",
+ optional => 1,
+ default => 0
+ },
+ properties => {
+ type => "object",
+ description => "This is a definition for the properties of an object value",
+ optional => 1,
+ default => {},
+ },
+ items => {
+ type => "object",
+ description => "When the value is an array, this indicates the schema to use to validate each item in an array",
+ optional => 1,
+ default => {},
+ },
+ additionalProperties => {
+ type => [ "boolean", "object"],
+ description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
+ optional => 1,
+ default => {},
+ },
+ minimum => {
+ type => "number",
+ optional => 1,
+ description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
+ },
+ maximum => {
+ type => "number",
+ optional => 1,
+ description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
+ },
+ minLength => {
+ type => "integer",
+ description => "When the instance value is a string, this indicates minimum length of the string",
+ optional => 1,
+ minimum => 0,
+ default => 0,
+ },
+ maxLength => {
+ type => "integer",
+ description => "When the instance value is a string, this indicates maximum length of the string.",
+ optional => 1,
+ },
+ typetext => {
+ type => "string",
+ optional => 1,
+ description => "A text representation of the type (used to generate documentation).",
+ },
+ pattern => {
+ type => "string",
+ format => "regex",
+ description => "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.",
+ optional => 1,
+ default => ".*",
+ },
+ enum => {
+ type => "array",
+ optional => 1,
+ description => "This provides an enumeration of possible values that are valid for the instance property.",
+ },
+ description => {
+ type => "string",
+ optional => 1,
+ description => "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).",
+ },
+ verbose_description => {
+ type => "string",
+ optional => 1,
+ description => "This provides a more verbose description.",
+ },
+ format_description => {
+ type => "string",
+ optional => 1,
+ description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
+ },
+ title => {
+ type => "string",
+ optional => 1,
+ description => "This provides the title of the property",
+ },
+ requires => {
+ type => [ "string", "object" ],
+ optional => 1,
+ description => "indicates a required property or a schema that must be validated if this property is present",
+ },
+ format => {
+ type => [ "string", "object" ],
+ optional => 1,
+ description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML",
+ },
+ default_key => {
+ type => "boolean",
+ optional => 1,
+ description => "Whether this is the default key in a comma separated list property string.",
+ },
+ alias => {
+ type => 'string',
+ optional => 1,
+ description => "When a key represents the same property as another it can be an alias to it, causing the parsed datastructure to use the other key to store the current value under.",
+ },
+ keyAlias => {
+ type => 'string',
+ optional => 1,
+ description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
+ requires => 'alias',
+ },
+ default => {
+ type => "any",
+ optional => 1,
+ description => "This indicates the default for the instance property."
+ },
+ completion => {
+ type => 'coderef',
+ description => "Bash completion function. This function should return a list of possible values.",
+ optional => 1,
+ },
+ disallow => {
+ type => "object",
+ optional => 1,
+ description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, then this instance is not valid.",
+ },
+ extends => {
+ type => "object",
+ optional => 1,
+ description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
+ default => {},
+ },
+ # this is from hyper schema
+ links => {
+ type => "array",
+ description => "This defines the link relations of the instance objects",
+ optional => 1,
+ items => {
+ type => "object",
+ properties => {
+ href => {
+ type => "string",
+ description => "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document",
+ },
+ rel => {
+ type => "string",
+ description => "This is the name of the link relation",
+ optional => 1,
+ default => "full",
+ },
+ method => {
+ type => "string",
+ description => "For submission links, this defines the method that should be used to access the target resource",
+ optional => 1,
+ default => "GET",
+ },
+ },
+ },
+ },
+ }
+};
+
+my $default_schema = Storable::dclone($default_schema_noref);
+
+$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
+$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
+
+$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{items}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{disallow}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{requires}->{additionalProperties} = 0;
+
+$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
+$default_schema->{properties}->{extends}->{additionalProperties} = 0;
+
+my $method_schema = {
+ type => "object",
+ additionalProperties => 0,
+ properties => {
+ description => {
+ description => "This a description of the method",
+ optional => 1,
+ },
+ name => {
+ type => 'string',
+ description => "This indicates the name of the function to call.",
+ optional => 1,
+ requires => {
+ additionalProperties => 1,
+ properties => {
+ name => {},
+ description => {},
+ code => {},
+ method => {},
+ parameters => {},
+ path => {},
+ parameters => {},
+ returns => {},
+ }
+ },
+ },
+ method => {
+ type => 'string',
+ description => "The HTTP method name.",
+ enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
+ optional => 1,
+ },
+ protected => {
+ type => 'boolean',
+ description => "Method needs special privileges - only pvedaemon can execute it",
+ optional => 1,
+ },
+ download => {
+ type => 'boolean',
+ description => "Method downloads the file content (filename is the return value of the method).",
+ optional => 1,
+ },
+ proxyto => {
+ type => 'string',
+ description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
+ optional => 1,
+ },
+ proxyto_callback => {
+ type => 'coderef',
+ description => "A function which is called to resolve the proxyto attribute. The default implementaion returns the value of the 'proxyto' parameter.",
+ optional => 1,
+ },
+ permissions => {
+ type => 'object',
+ description => "Required access permissions. By default only 'root' is allowed to access this method.",
+ optional => 1,
+ additionalProperties => 0,
+ properties => {
+ description => {
+ description => "Describe access permissions.",
+ optional => 1,
+ },
+ user => {
+ description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
+ type => 'string',
+ enum => ['all', 'world'],
+ optional => 1,
+ },
+ check => {
+ description => "Array of permission checks (prefix notation).",
+ type => 'array',
+ optional => 1
+ },
+ },
+ },
+ match_name => {
+ description => "Used internally",
+ optional => 1,
+ },
+ match_re => {
+ description => "Used internally",
+ optional => 1,
+ },
+ path => {
+ type => 'string',
+ description => "path for URL matching (uri template)",
+ },
+ fragmentDelimiter => {
+ type => 'string',
+ description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",
+ optional => 1,
+ },
+ parameters => {
+ type => 'object',
+ description => "JSON Schema for parameters.",
+ optional => 1,
+ },
+ returns => {
+ type => 'object',
+ description => "JSON Schema for return value.",
+ optional => 1,
+ },
+ code => {
+ type => 'coderef',
+ description => "method implementaion (code reference)",
+ optional => 1,
+ },
+ subclass => {
+ type => 'string',
+ description => "Delegate call to this class (perl class string).",
+ optional => 1,
+ requires => {
+ additionalProperties => 0,
+ properties => {
+ subclass => {},
+ path => {},
+ match_name => {},
+ match_re => {},
+ fragmentDelimiter => { optional => 1 }
+ }
+ },
+ },
+ },
+
+};
+
+sub validate_schema {
+ my ($schema) = @_;
+
+ my $errmsg = "internal error - unable to verify schema\n";
+ validate($schema, $default_schema, $errmsg);
+}
+
+sub validate_method_info {
+ my $info = shift;
+
+ my $errmsg = "internal error - unable to verify method info\n";
+ validate($info, $method_schema, $errmsg);
+
+ validate_schema($info->{parameters}) if $info->{parameters};
+ validate_schema($info->{returns}) if $info->{returns};
+}
+
+# run a self test on load
+# make sure we can verify the default schema
+validate_schema($default_schema_noref);
+validate_schema($method_schema);
+
+# and now some utility methods (used by pve api)
+sub method_get_child_link {
+ my ($info) = @_;
+
+ return undef if !$info;
+
+ my $schema = $info->{returns};
+ return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
+
+ my $links = $schema->{links};
+ return undef if !$links;
+
+ my $found;
+ foreach my $lnk (@$links) {
+ if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
+ $found = $lnk;
+ last;
+ }
+ }
+
+ return $found;
+}
+
+# a way to parse command line parameters, using a
+# schema to configure Getopt::Long
+sub get_options {
+ my ($schema, $args, $arg_param, $fixed_param, $pwcallback, $param_mapping_hash) = @_;
+
+ if (!$schema || !$schema->{properties}) {
+ raise("too many arguments\n", code => HTTP_BAD_REQUEST)
+ if scalar(@$args) != 0;
+ return {};
+ }
+
+ my $list_param;
+ if ($arg_param && !ref($arg_param)) {
+ my $pd = $schema->{properties}->{$arg_param};
+ die "expected list format $pd->{format}"
+ if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
+ $list_param = $arg_param;
+ }
+
+ my @interactive = ();
+ my @getopt = ();
+ foreach my $prop (keys %{$schema->{properties}}) {
+ my $pd = $schema->{properties}->{$prop};
+ next if $list_param && $prop eq $list_param;
+ next if defined($fixed_param->{$prop});
+
+ my $mapping = $param_mapping_hash->{$prop};
+ if ($mapping && $mapping->{interactive}) {
+ # interactive parameters such as passwords: make the argument
+ # optional and call the mapping function afterwards.
+ push @getopt, "$prop:s";
+ push @interactive, [$prop, $mapping->{func}];
+ } elsif ($prop eq 'password' && $pwcallback) {
+ # we do not accept plain password on input line, instead
+ # we turn this into a boolean option and ask for password below
+ # using $pwcallback() (for security reasons).
+ push @getopt, "$prop";
+ } elsif ($pd->{type} eq 'boolean') {
+ push @getopt, "$prop:s";
+ } else {
+ if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
+ push @getopt, "$prop=s@";
+ } else {
+ push @getopt, "$prop=s";
+ }
+ }
+ }
+
+ Getopt::Long::Configure('prefix_pattern=(--|-)');
+
+ my $opts = {};
+ raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
+ if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
+
+ if (@$args) {
+ if ($list_param) {
+ $opts->{$list_param} = $args;
+ $args = [];
+ } elsif (ref($arg_param)) {
+ foreach my $arg_name (@$arg_param) {
+ if ($opts->{'extra-args'}) {
+ raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
+ }
+ if ($arg_name eq 'extra-args') {
+ $opts->{'extra-args'} = $args;
+ $args = [];
+ next;
+ }
+ raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
+ $opts->{$arg_name} = shift @$args;
+ }
+ raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
+ } else {
+ raise("too many arguments\n", code => HTTP_BAD_REQUEST)
+ if scalar(@$args) != 0;
+ }
+ } else {
+ if (ref($arg_param)) {
+ foreach my $arg_name (@$arg_param) {
+ if ($arg_name eq 'extra-args') {
+ $opts->{'extra-args'} = [];
+ } else {
+ raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
+ }
+ }
+ }
+ }
+
+ if (my $pd = $schema->{properties}->{password}) {
+ if ($pd->{type} ne 'boolean' && $pwcallback) {
+ if ($opts->{password} || !$pd->{optional}) {
+ $opts->{password} = &$pwcallback();
+ }
+ }
+ }
+
+ foreach my $entry (@interactive) {
+ my ($opt, $func) = @$entry;
+ my $pd = $schema->{properties}->{$opt};
+ my $value = $opts->{$opt};
+ if (defined($value) || !$pd->{optional}) {
+ $opts->{$opt} = $func->($value);
+ }
+ }
+
+ # decode after Getopt as we are not sure how well it handles unicode
+ foreach my $p (keys %$opts) {
+ if (!ref($opts->{$p})) {
+ $opts->{$p} = decode('locale', $opts->{$p});
+ } elsif (ref($opts->{$p}) eq 'ARRAY') {
+ my $tmp = [];
+ foreach my $v (@{$opts->{$p}}) {
+ push @$tmp, decode('locale', $v);
+ }
+ $opts->{$p} = $tmp;
+ } elsif (ref($opts->{$p}) eq 'SCALAR') {
+ $opts->{$p} = decode('locale', $$opts->{$p});
+ } else {
+ raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
+ }
+ }
+
+ foreach my $p (keys %$opts) {
+ if (my $pd = $schema->{properties}->{$p}) {
+ if ($pd->{type} eq 'boolean') {
+ if ($opts->{$p} eq '') {
+ $opts->{$p} = 1;
+ } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
+ $opts->{$p} = $bool;
+ } else {
+ raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
+ }
+ } elsif ($pd->{format}) {
+
+ if ($pd->{format} =~ m/-list/) {
+ # allow --vmid 100 --vmid 101 and --vmid 100,101
+ # allow --dow mon --dow fri and --dow mon,fri
+ $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
+ } elsif ($pd->{format} =~ m/-alist/) {
+ # we encode array as \0 separated strings
+ # Note: CGI.pm also use this encoding
+ if (scalar(@{$opts->{$p}}) != 1) {
+ $opts->{$p} = join("\0", @{$opts->{$p}});
+ } else {
+ # st that split_list knows it is \0 terminated
+ my $v = $opts->{$p}->[0];
+ $opts->{$p} = "$v\0";
+ }
+ }
+ }
+ }
+ }
+
+ foreach my $p (keys %$fixed_param) {
+ $opts->{$p} = $fixed_param->{$p};
+ }
+
+ return $opts;
+}
+
+# A way to parse configuration data by giving a json schema
+sub parse_config {
+ my ($schema, $filename, $raw) = @_;
+
+ # do fast check (avoid validate_schema($schema))
+ die "got strange schema" if !$schema->{type} ||
+ !$schema->{properties} || $schema->{type} ne 'object';
+
+ my $cfg = {};
+
+ while ($raw =~ /^\s*(.+?)\s*$/gm) {
+ my $line = $1;
+
+ next if $line =~ /^#/;
+
+ if ($line =~ m/^(\S+?):\s*(.*)$/) {
+ my $key = $1;
+ my $value = $2;
+ if ($schema->{properties}->{$key} &&
+ $schema->{properties}->{$key}->{type} eq 'boolean') {
+
+ $value = parse_boolean($value) // $value;
+ }
+ $cfg->{$key} = $value;
+ } else {
+ warn "ignore config line: $line\n"
+ }
+ }
+
+ my $errors = {};
+ check_prop($cfg, $schema, '', $errors);
+
+ foreach my $k (keys %$errors) {
+ warn "parse error in '$filename' - '$k': $errors->{$k}\n";
+ delete $cfg->{$k};
+ }
+
+ return $cfg;
+}
+
+# generate simple key/value file
+sub dump_config {
+ my ($schema, $filename, $cfg) = @_;
+
+ # do fast check (avoid validate_schema($schema))
+ die "got strange schema" if !$schema->{type} ||
+ !$schema->{properties} || $schema->{type} ne 'object';
+
+ validate($cfg, $schema, "validation error in '$filename'\n");
+
+ my $data = '';
+
+ foreach my $k (keys %$cfg) {
+ $data .= "$k: $cfg->{$k}\n";
+ }
+
+ return $data;
+}
+
+# helpers used to generate our manual pages
+
+my $find_schema_default_key = sub {
+ my ($format) = @_;
+
+ my $default_key;
+ my $keyAliasProps = {};
+
+ foreach my $key (keys %$format) {
+ my $phash = $format->{$key};
+ if ($phash->{default_key}) {
+ die "multiple default keys in schema ($default_key, $key)\n"
+ if defined($default_key);
+ die "default key '$key' is an alias - this is not allowed\n"
+ if defined($phash->{alias});
+ die "default key '$key' with keyAlias attribute is not allowed\n"
+ if $phash->{keyAlias};
+ $default_key = $key;
+ }
+ my $key_alias = $phash->{keyAlias};
+ die "found keyAlias without 'alias definition for '$key'\n"
+ if $key_alias && !$phash->{alias};
+
+ if ($phash->{alias} && $key_alias) {
+ die "inconsistent keyAlias '$key_alias' definition"
+ if defined($keyAliasProps->{$key_alias}) &&
+ $keyAliasProps->{$key_alias} ne $phash->{alias};
+ $keyAliasProps->{$key_alias} = $phash->{alias};
+ }
+ }
+
+ return wantarray ? ($default_key, $keyAliasProps) : $default_key;
+};
+
+sub generate_typetext {
+ my ($format, $list_enums) = @_;
+
+ my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
+
+ my $res = '';
+ my $add_sep = 0;
+
+ my $add_option_string = sub {
+ my ($text, $optional) = @_;
+
+ if ($add_sep) {
+ $text = ",$text";
+ $res .= ' ';
+ }
+ $text = "[$text]" if $optional;
+ $res .= $text;
+ $add_sep = 1;
+ };
+
+ my $format_key_value = sub {
+ my ($key, $phash) = @_;
+
+ die "internal error" if defined($phash->{alias});
+
+ my $keytext = $key;
+
+ my $typetext = '';
+
+ if (my $desc = $phash->{format_description}) {
+ $typetext .= "<$desc>";
+ } elsif (my $text = $phash->{typetext}) {
+ $typetext .= $text;
+ } elsif (my $enum = $phash->{enum}) {
+ if ($list_enums || (scalar(@$enum) <= 3)) {
+ $typetext .= '<' . join('|', @$enum) . '>';
+ } else {
+ $typetext .= '<enum>';
+ }
+ } elsif ($phash->{type} eq 'boolean') {
+ $typetext .= '<1|0>';
+ } elsif ($phash->{type} eq 'integer') {
+ $typetext .= '<integer>';
+ } elsif ($phash->{type} eq 'number') {
+ $typetext .= '<number>';
+ } else {
+ die "internal error: neither format_description nor typetext found for option '$key'";
+ }
+
+ if (defined($default_key) && ($default_key eq $key)) {
+ &$add_option_string("[$keytext=]$typetext", $phash->{optional});
+ } else {
+ &$add_option_string("$keytext=$typetext", $phash->{optional});
+ }
+ };
+
+ my $done = {};
+
+ my $cond_add_key = sub {
+ my ($key) = @_;
+
+ return if $done->{$key}; # avoid duplicates
+
+ $done->{$key} = 1;
+
+ my $phash = $format->{$key};
+
+ return if !$phash; # should not happen
+
+ return if $phash->{alias};
+
+ &$format_key_value($key, $phash);
+
+ };
+
+ &$cond_add_key($default_key) if defined($default_key);
+
+ # add required keys first
+ foreach my $key (sort keys %$format) {
+ my $phash = $format->{$key};
+ &$cond_add_key($key) if $phash && !$phash->{optional};
+ }
+
+ # add the rest
+ foreach my $key (sort keys %$format) {
+ &$cond_add_key($key);
+ }
+
+ foreach my $keyAlias (sort keys %$keyAliasProps) {
+ &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
+ }
+
+ return $res;
+}
+
+sub print_property_string {
+ my ($data, $format, $skip, $path) = @_;
+
+ if (ref($format) ne 'HASH') {
+ my $schema = get_format($format);
+ die "not a valid format: $format\n" if !$schema;
+ $format = $schema;
+ }
+
+ my $errors = {};
+ check_object($path, $format, $data, undef, $errors);
+ if (scalar(%$errors)) {
+ raise "format error", errors => $errors;
+ }
+
+ my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
+
+ my $res = '';
+ my $add_sep = 0;
+
+ my $add_option_string = sub {
+ my ($text) = @_;
+
+ $res .= ',' if $add_sep;
+ $res .= $text;
+ $add_sep = 1;
+ };
+
+ my $format_value = sub {
+ my ($key, $value, $format) = @_;
+
+ if (defined($format) && ($format eq 'disk-size')) {
+ return format_size($value);
+ } else {
+ die "illegal value with commas for $key\n" if $value =~ /,/;
+ return $value;
+ }
+ };
+
+ my $done = { map { $_ => 1 } @$skip };
+
+ my $cond_add_key = sub {
+ my ($key, $isdefault) = @_;
+
+ return if $done->{$key}; # avoid duplicates
+
+ $done->{$key} = 1;
+
+ my $value = $data->{$key};
+
+ return if !defined($value);
+
+ my $phash = $format->{$key};
+
+ # try to combine values if we have key aliases
+ if (my $combine = $keyAliasProps->{$key}) {
+ if (defined(my $combine_value = $data->{$combine})) {
+ my $combine_format = $format->{$combine}->{format};
+ my $value_str = &$format_value($key, $value, $phash->{format});
+ my $combine_str = &$format_value($combine, $combine_value, $combine_format);
+ &$add_option_string("${value_str}=${combine_str}");
+ $done->{$combine} = 1;
+ return;
+ }
+ }
+
+ if ($phash && $phash->{alias}) {
+ $phash = $format->{$phash->{alias}};
+ }
+
+ die "invalid key '$key'\n" if !$phash;
+ die "internal error" if defined($phash->{alias});
+
+ my $value_str = &$format_value($key, $value, $phash->{format});
+ if ($isdefault) {
+ &$add_option_string($value_str);
+ } else {
+ &$add_option_string("$key=${value_str}");
+ }
+ };
+
+ # add default key first
+ &$cond_add_key($default_key, 1) if defined($default_key);
+
+ # add required keys first
+ foreach my $key (sort keys %$data) {
+ my $phash = $format->{$key};
+ &$cond_add_key($key) if $phash && !$phash->{optional};
+ }
+
+ # add the rest
+ foreach my $key (sort keys %$data) {
+ &$cond_add_key($key);
+ }
+
+ return $res;
+}
+
+sub schema_get_type_text {
+ my ($phash, $style) = @_;
+
+ my $type = $phash->{type} || 'string';
+
+ if ($phash->{typetext}) {
+ return $phash->{typetext};
+ } elsif ($phash->{format_description}) {
+ return "<$phash->{format_description}>";
+ } elsif ($phash->{enum}) {
+ return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
+ } elsif ($phash->{pattern}) {
+ return $phash->{pattern};
+ } elsif ($type eq 'integer' || $type eq 'number') {
+ # NOTE: always access values as number (avoid converion to string)
+ if (defined($phash->{minimum}) && defined($phash->{maximum})) {
+ return "<$type> (" . ($phash->{minimum} + 0) . " - " .
+ ($phash->{maximum} + 0) . ")";
+ } elsif (defined($phash->{minimum})) {
+ return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
+ } elsif (defined($phash->{maximum})) {
+ return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
+ }
+ } elsif ($type eq 'string') {
+ if (my $format = $phash->{format}) {
+ $format = get_format($format) if ref($format) ne 'HASH';
+ if (ref($format) eq 'HASH') {
+ my $list_enums = 0;
+ $list_enums = 1 if $style && $style eq 'config-sub';
+ return generate_typetext($format, $list_enums);
+ }
+ }
+ }
+
+ return "<$type>";
+}
+
+1;
--- /dev/null
+package PVE::APIClient::PTY;
+
+use strict;
+use warnings;
+
+use Fcntl;
+use POSIX qw(O_RDWR O_NOCTTY);
+
+# Constants
+
+use constant {
+ TCGETS => 0x5401, # fixed, from asm-generic/ioctls.h
+ TCSETS => 0x5402, # fixed, from asm-generic/ioctls.h
+ TIOCGWINSZ => 0x5413, # fixed, from asm-generic/ioctls.h
+ TIOCSWINSZ => 0x5414, # fixed, from asm-generic/ioctls.h
+ TIOCSCTTY => 0x540E, # fixed, from asm-generic/ioctls.h
+ TIOCNOTTY => 0x5422, # fixed, from asm-generic/ioctls.h
+ TIOCGPGRP => 0x540F, # fixed, from asm-generic/ioctls.h
+ TIOCSPGRP => 0x5410, # fixed, from asm-generic/ioctls.h
+
+ # IOC: dir:2 size:14 type:8 nr:8
+ # Get pty number: dir=2 size=4 type='T' nr=0x30
+ TIOCGPTN => 0x80045430,
+
+ # Set pty lock: dir=1 size=4 type='T' nr=0x31
+ TIOCSPTLCK => 0x40045431,
+
+ # Send signal: dir=1 size=4 type='T' nr=0x36
+ TIOCSIG => 0x40045436,
+
+ # c_cc indices:
+ VINTR => 0,
+ VQUIT => 1,
+ VERASE => 2,
+ VKILL => 3,
+ VEOF => 4,
+ VTIME => 5,
+ VMIN => 6,
+ VSWTC => 7,
+ VSTART => 8,
+ VSTOP => 9,
+ VSUSP => 10,
+ VEOL => 11,
+ VREPRINT => 12,
+ VDISCARD => 13,
+ VWERASE => 14,
+ VLNEXT => 15,
+ VEOL2 => 16,
+};
+
+# Utility functions
+
+sub createpty() {
+ # Open the master file descriptor:
+ sysopen(my $master, '/dev/ptmx', O_RDWR | O_NOCTTY)
+ or die "failed to create pty: $!\n";
+
+ # Find the tty number
+ my $ttynum = pack('L', 0);
+ ioctl($master, TIOCGPTN, $ttynum)
+ or die "failed to query pty number: $!\n";
+ $ttynum = unpack('L', $ttynum);
+
+ # Get the slave name/path
+ my $ttyname = "/dev/pts/$ttynum";
+
+ # Unlock
+ my $false = pack('L', 0);
+ ioctl($master, TIOCSPTLCK, $false)
+ or die "failed to unlock pty: $!\n";
+
+ return ($master, $ttyname);
+}
+
+my $openslave = sub {
+ my ($ttyname) = @_;
+
+ # Create a slave file descriptor:
+ sysopen(my $slave, $ttyname, O_RDWR | O_NOCTTY)
+ or die "failed to open slave pty handle: $!\n";
+ return $slave;
+};
+
+sub lose_controlling_terminal() {
+ # Can we open our current terminal?
+ if (sysopen(my $ttyfd, '/dev/tty', O_RDWR)) {
+ # Disconnect:
+ ioctl($ttyfd, TIOCNOTTY, 0)
+ or die "failed to disconnect controlling tty: $!\n";
+ close($ttyfd);
+ }
+}
+
+sub termios(%) {
+ my (%termios) = @_;
+ my $cc = $termios{cc} // [];
+ if (@$cc < 19) {
+ push @$cc, (0) x (19-@$cc);
+ } elsif (@$cc > 19) {
+ @$cc = $$cc[0..18];
+ }
+
+ return pack('LLLLCC[19]',
+ $termios{iflag} || 0,
+ $termios{oflag} || 0,
+ $termios{cflag} || 0,
+ $termios{lflag} || 0,
+ $termios{line} || 0,
+ @$cc);
+}
+
+my $parse_termios = sub {
+ my ($blob) = @_;
+ my ($iflag, $oflag, $cflag, $lflag, $line, @cc) =
+ unpack('LLLLCC[19]', $blob);
+ return {
+ iflag => $iflag,
+ oflag => $oflag,
+ cflag => $cflag,
+ lflag => $lflag,
+ line => $line,
+ cc => \@cc
+ };
+};
+
+sub cfmakeraw($) {
+ my ($termios) = @_;
+ $termios->{iflag} &=
+ ~(POSIX::IGNBRK | POSIX::BRKINT | POSIX::PARMRK | POSIX::ISTRIP |
+ POSIX::INLCR | POSIX::IGNCR | POSIX::ICRNL | POSIX::IXON);
+ $termios->{oflag} &= ~POSIX::OPOST;
+ $termios->{lflag} &=
+ ~(POSIX::ECHO | POSIX::ECHONL | POSIX::ICANON | POSIX::ISIG |
+ POSIX::IEXTEN);
+ $termios->{cflag} &= ~(POSIX::CSIZE | POSIX::PARENB);
+ $termios->{cflag} |= POSIX::CS8;
+}
+
+sub tcgetattr($) {
+ my ($fd) = @_;
+ my $blob = termios();
+ ioctl($fd, TCGETS, $blob) or die "failed to get terminal attributes\n";
+ return $parse_termios->($blob);
+}
+
+sub tcsetattr($$) {
+ my ($fd, $termios) = @_;
+ my $blob = termios(%$termios);
+ ioctl($fd, TCSETS, $blob) or die "failed to set terminal attributes\n";
+}
+
+# tcgetsize -> (columns, rows)
+sub tcgetsize($) {
+ my ($fd) = @_;
+ my $struct_winsz = pack('SSSS', 0, 0, 0, 0);
+ ioctl($fd, TIOCGWINSZ, $struct_winsz)
+ or die "failed to get window size: $!\n";
+ return reverse unpack('SS', $struct_winsz);
+}
+
+sub tcsetsize($$$) {
+ my ($fd, $columns, $rows) = @_;
+ my $struct_winsz = pack('SSSS', $rows, $columns, 0, 0);
+ ioctl($fd, TIOCSWINSZ, $struct_winsz)
+ or die "failed to set window size: $!\n";
+}
+
+sub read_password($;$$) {
+ my ($query, $infd, $outfd) = @_;
+
+ my $password = '';
+
+ $infd //= \*STDIN;
+
+ if (!-t $infd) { # Not a terminal? Then just get a line...
+ local $/ = "\n";
+ $password = <$infd>;
+ die "EOF while reading password\n" if !defined $password;
+ chomp $password; # Chop off the newline
+ return $password;
+ }
+
+ $outfd //= \*STDOUT;
+
+ # Raw read loop:
+ my $old_termios;
+ $old_termios = tcgetattr($infd);
+ my $raw_termios = {%$old_termios};
+ cfmakeraw($raw_termios);
+ tcsetattr($infd, $raw_termios);
+ eval {
+ my $echo = undef;
+ my ($ch, $got);
+ syswrite($outfd, $query, length($query));
+ while (($got = sysread($infd, $ch, 1))) {
+ my ($ord) = unpack('C', $ch);
+ last if $ord == 4; # ^D / EOF
+ if ($ord == 0xA || $ord == 0xD) {
+ # newline, we're done
+ syswrite($outfd, "\r\n", 2);
+ last;
+ } elsif ($ord == 3) { # ^C
+ die "password input aborted\n";
+ } elsif ($ord == 0x7f) {
+ # backspace - if it's the first key disable
+ # asterisks
+ $echo //= 0;
+ if (length($password)) {
+ chop $password;
+ syswrite($outfd, "\b \b", 3);
+ }
+ } elsif ($ord == 0x09) {
+ # TAB disables the asterisk-echo
+ $echo = 0;
+ } else {
+ # other character, append to password, if it's
+ # the first character enable asterisks echo
+ $echo //= 1;
+ $password .= $ch;
+ syswrite($outfd, '*', 1) if $echo;
+ }
+ }
+ die "read error: $!\n" if !defined($got);
+ };
+ my $err = $@;
+ tcsetattr($infd, $old_termios);
+ die $err if $err;
+ return $password;
+}
+
+# Class functions
+
+sub new {
+ my ($class) = @_;
+
+ my ($master, $ttyname) = createpty();
+
+ my $self = {
+ master => $master,
+ ttyname => $ttyname,
+ };
+
+ return bless $self, $class;
+}
+
+# Properties
+
+sub master { return $_[0]->{master} }
+sub ttyname { return $_[0]->{ttyname} }
+
+# Methods
+
+sub close {
+ my ($self) = @_;
+ close($self->{master});
+}
+
+sub open_slave {
+ my ($self) = @_;
+ return $openslave->($self->{ttyname});
+}
+
+sub set_size {
+ my ($self, $columns, $rows) = @_;
+ tcsetsize($self->{master}, $columns, $rows);
+}
+
+# get_size -> (columns, rows)
+sub get_size {
+ my ($self) = @_;
+ return tcgetsize($self->{master});
+}
+
+sub kill {
+ my ($self, $signal) = @_;
+ if (!ioctl($self->{master}, TIOCSIG, $signal)) {
+ # kill fallback if the ioctl does not work
+ kill $signal, $self->get_foreground_pid()
+ or die "failed to send signal: $!\n";
+ }
+}
+
+sub get_foreground_pid {
+ my ($self) = @_;
+ my $pid = pack('L', 0);
+ ioctl($self->{master}, TIOCGPGRP, $pid)
+ or die "failed to get foreground pid: $!\n";
+ return unpack('L', $pid);
+}
+
+sub has_process {
+ my ($self) = @_;
+ return 0 != $self->get_foreground_pid();
+}
+
+sub make_controlling_terminal {
+ my ($self) = @_;
+
+ #lose_controlling_terminal();
+ POSIX::setsid();
+ my $slave = $self->open_slave();
+ ioctl($slave, TIOCSCTTY, 0)
+ or die "failed to change controlling tty: $!\n";
+ POSIX::dup2(fileno($slave), 0) or die "failed to dup stdin\n";
+ POSIX::dup2(fileno($slave), 1) or die "failed to dup stdout\n";
+ POSIX::dup2(fileno($slave), 2) or die "failed to dup stderr\n";
+ CORE::close($slave) if fileno($slave) > 2;
+ CORE::close($self->{master});
+}
+
+sub getattr {
+ my ($self) = @_;
+ return tcgetattr($self->{master});
+}
+
+sub setattr {
+ my ($self, $termios) = @_;
+ return tcsetattr($self->{master}, $termios);
+}
+
+sub send_cc {
+ my ($self, $ccidx) = @_;
+ my $attrs = $self->getattr();
+ my $data = pack('C', $attrs->{cc}->[$ccidx]);
+ syswrite($self->{master}, $data)
+ == 1 || die "write failed: $!\n";
+}
+
+sub send_eof {
+ my ($self) = @_;
+ $self->send_cc(VEOF);
+}
+
+sub send_interrupt {
+ my ($self) = @_;
+ $self->send_cc(VINTR);
+}
+
+1;
--- /dev/null
+package PVE::APIClient::RESTHandler;
+
+use strict;
+no strict 'refs'; # our autoload requires this
+use warnings;
+use PVE::APIClient::SafeSyslog;
+use PVE::APIClient::Exception qw(raise raise_param_exc);
+use PVE::APIClient::JSONSchema;
+use PVE::APIClient::Tools;
+use HTTP::Status qw(:constants :is status_message);
+use Text::Wrap;
+use Clone qw(clone);
+
+my $method_registry = {};
+my $method_by_name = {};
+my $method_path_lookup = {};
+
+our $AUTOLOAD; # it's a package global
+
+sub api_clone_schema {
+ my ($schema) = @_;
+
+ my $res = {};
+ my $ref = ref($schema);
+ die "not a HASH reference" if !($ref && $ref eq 'HASH');
+
+ foreach my $k (keys %$schema) {
+ my $d = $schema->{$k};
+ if ($k ne 'properties') {
+ $res->{$k} = ref($d) ? clone($d) : $d;
+ next;
+ }
+ # convert indexed parameters like -net\d+ to -net[n]
+ foreach my $p (keys %$d) {
+ my $pd = $d->{$p};
+ if ($p =~ m/^([a-z]+)(\d+)$/) {
+ my ($name, $idx) = ($1, $2);
+ if ($idx == 0 && defined($d->{"${name}1"})) {
+ $p = "${name}[n]";
+ } elsif (defined($d->{"${name}0"})) {
+ next; # only handle once for -xx0, but only if -xx0 exists
+ }
+ }
+ my $tmp = ref($pd) ? clone($pd) : $pd;
+ # NOTE: add typetext property for more complex types, to
+ # make the web api viewer code simpler
+ if (!(defined($tmp->{enum}) || defined($tmp->{pattern}))) {
+ my $typetext = PVE::APIClient::JSONSchema::schema_get_type_text($tmp);
+ if ($tmp->{type} && ($tmp->{type} ne $typetext)) {
+ $tmp->{typetext} = $typetext;
+ }
+ }
+ $res->{$k}->{$p} = $tmp;
+ }
+ }
+
+ return $res;
+}
+
+sub api_dump_full {
+ my ($tree, $index, $class, $prefix, $raw_dump) = @_;
+
+ $prefix = '' if !$prefix;
+
+ my $ma = $method_registry->{$class};
+
+ foreach my $info (@$ma) {
+
+ my $path = "$prefix/$info->{path}";
+ $path =~ s/\/+$//;
+
+ if ($info->{subclass}) {
+ api_dump_full($tree, $index, $info->{subclass}, $path, $raw_dump);
+ } else {
+ next if !$path;
+
+ # check if method is unique
+ my $realpath = $path;
+ $realpath =~ s/\{[^\}]+\}/\{\}/g;
+ my $fullpath = "$info->{method} $realpath";
+ die "duplicate path '$realpath'" if $index->{$fullpath};
+ $index->{$fullpath} = $info;
+
+ # insert into tree
+ my $treedir = $tree;
+ my $res;
+ my $sp = '';
+ foreach my $dir (split('/', $path)) {
+ next if !$dir;
+ $sp .= "/$dir";
+ $res = (grep { $_->{text} eq $dir } @$treedir)[0];
+ if ($res) {
+ $res->{children} = [] if !$res->{children};
+ $treedir = $res->{children};
+ } else {
+ $res = {
+ path => $sp,
+ text => $dir,
+ children => [],
+ };
+ push @$treedir, $res;
+ $treedir = $res->{children};
+ }
+ }
+
+ if ($res) {
+ my $data = {};
+ foreach my $k (keys %$info) {
+ next if $k eq 'code' || $k eq "match_name" || $k eq "match_re" ||
+ $k eq "path";
+
+ my $d = $info->{$k};
+
+ if ($raw_dump) {
+ $data->{$k} = $d;
+ } else {
+ if ($k eq 'parameters') {
+ $data->{$k} = api_clone_schema($d);
+ } else {
+ $data->{$k} = ref($d) ? clone($d) : $d;
+ }
+ }
+ }
+ $res->{info}->{$info->{method}} = $data;
+ };
+ }
+ }
+};
+
+sub api_dump_cleanup_tree {
+ my ($tree) = @_;
+
+ foreach my $rec (@$tree) {
+ delete $rec->{children} if $rec->{children} && !scalar(@{$rec->{children}});
+ if ($rec->{children}) {
+ $rec->{leaf} = 0;
+ api_dump_cleanup_tree($rec->{children});
+ } else {
+ $rec->{leaf} = 1;
+ }
+ }
+
+}
+
+# api_dump_remove_refs: prepare API tree for use with to_json($tree)
+sub api_dump_remove_refs {
+ my ($tree) = @_;
+
+ my $class = ref($tree);
+ return $tree if !$class;
+
+ if ($class eq 'ARRAY') {
+ my $res = [];
+ foreach my $el (@$tree) {
+ push @$res, api_dump_remove_refs($el);
+ }
+ return $res;
+ } elsif ($class eq 'HASH') {
+ my $res = {};
+ foreach my $k (keys %$tree) {
+ if (my $itemclass = ref($tree->{$k})) {
+ if ($itemclass eq 'CODE') {
+ next if $k eq 'completion';
+ }
+ $res->{$k} = api_dump_remove_refs($tree->{$k});
+ } else {
+ $res->{$k} = $tree->{$k};
+ }
+ }
+ return $res;
+ } elsif ($class eq 'Regexp') {
+ return "$tree"; # return string representation
+ } else {
+ die "unknown class '$class'\n";
+ }
+}
+
+sub api_dump {
+ my ($class, $prefix, $raw_dump) = @_;
+
+ my $tree = [];
+
+ my $index = {};
+ api_dump_full($tree, $index, $class, $prefix, $raw_dump);
+ api_dump_cleanup_tree($tree);
+ return $tree;
+};
+
+sub validate_method_schemas {
+
+ foreach my $class (keys %$method_registry) {
+ my $ma = $method_registry->{$class};
+
+ foreach my $info (@$ma) {
+ PVE::APIClient::JSONSchema::validate_method_info($info);
+ }
+ }
+}
+
+sub register_method {
+ my ($self, $info) = @_;
+
+ my $match_re = [];
+ my $match_name = [];
+
+ my $errprefix;
+
+ my $method;
+ if ($info->{subclass}) {
+ $errprefix = "register subclass $info->{subclass} at ${self}/$info->{path} -";
+ $method = 'SUBCLASS';
+ } else {
+ $errprefix = "register method ${self}/$info->{path} -";
+ $info->{method} = 'GET' if !$info->{method};
+ $method = $info->{method};
+ }
+
+ $method_path_lookup->{$self} = {} if !defined($method_path_lookup->{$self});
+ my $path_lookup = $method_path_lookup->{$self};
+
+ die "$errprefix no path" if !defined($info->{path});
+
+ foreach my $comp (split(/\/+/, $info->{path})) {
+ die "$errprefix path compoment has zero length\n" if $comp eq '';
+ my ($name, $regex);
+ if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) {
+ $name = $1;
+ $regex = $3 ? $3 : '\S+';
+ push @$match_re, $regex;
+ push @$match_name, $name;
+ } else {
+ $name = $comp;
+ push @$match_re, $name;
+ push @$match_name, undef;
+ }
+
+ if ($regex) {
+ $path_lookup->{regex} = {} if !defined($path_lookup->{regex});
+
+ my $old_name = $path_lookup->{regex}->{match_name};
+ die "$errprefix found changed regex match name\n"
+ if defined($old_name) && ($old_name ne $name);
+ my $old_re = $path_lookup->{regex}->{match_re};
+ die "$errprefix found changed regex\n"
+ if defined($old_re) && ($old_re ne $regex);
+ $path_lookup->{regex}->{match_name} = $name;
+ $path_lookup->{regex}->{match_re} = $regex;
+
+ die "$errprefix path match error - regex and fixed items\n"
+ if defined($path_lookup->{folders});
+
+ $path_lookup = $path_lookup->{regex};
+
+ } else {
+ $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name});
+
+ die "$errprefix path match error - regex and fixed items\n"
+ if defined($path_lookup->{regex});
+
+ $path_lookup = $path_lookup->{folders}->{$name};
+ }
+ }
+
+ die "$errprefix duplicate method definition\n"
+ if defined($path_lookup->{$method});
+
+ if ($method eq 'SUBCLASS') {
+ foreach my $m (qw(GET PUT POST DELETE)) {
+ die "$errprefix duplicate method definition SUBCLASS and $m\n" if $path_lookup->{$m};
+ }
+ }
+ $path_lookup->{$method} = $info;
+
+ $info->{match_re} = $match_re;
+ $info->{match_name} = $match_name;
+
+ $method_by_name->{$self} = {} if !defined($method_by_name->{$self});
+
+ if ($info->{name}) {
+ die "$errprefix method name already defined\n"
+ if defined($method_by_name->{$self}->{$info->{name}});
+
+ $method_by_name->{$self}->{$info->{name}} = $info;
+ }
+
+ push @{$method_registry->{$self}}, $info;
+}
+
+sub DESTROY {}; # avoid problems with autoload
+
+sub AUTOLOAD {
+ my ($this) = @_;
+
+ # also see "man perldiag"
+
+ my $sub = $AUTOLOAD;
+ (my $method = $sub) =~ s/.*:://;
+
+ my $info = $this->map_method_by_name($method);
+
+ *{$sub} = sub {
+ my $self = shift;
+ return $self->handle($info, @_);
+ };
+ goto &$AUTOLOAD;
+}
+
+sub method_attributes {
+ my ($self) = @_;
+
+ return $method_registry->{$self};
+}
+
+sub map_method_by_name {
+ my ($self, $name) = @_;
+
+ my $info = $method_by_name->{$self}->{$name};
+ die "no such method '${self}::$name'\n" if !$info;
+
+ return $info;
+}
+
+sub map_path_to_methods {
+ my ($class, $stack, $uri_param, $pathmatchref) = @_;
+
+ my $path_lookup = $method_path_lookup->{$class};
+
+ # Note: $pathmatchref can be used to obtain path including
+ # uri patterns like '/cluster/firewall/groups/{group}'.
+ # Used by pvesh to display help
+ if (defined($pathmatchref)) {
+ $$pathmatchref = '' if !$$pathmatchref;
+ }
+
+ while (defined(my $comp = shift @$stack)) {
+ return undef if !$path_lookup; # not registerd?
+ if ($path_lookup->{regex}) {
+ my $name = $path_lookup->{regex}->{match_name};
+ my $regex = $path_lookup->{regex}->{match_re};
+
+ return undef if $comp !~ m/^($regex)$/;
+ $uri_param->{$name} = $1;
+ $path_lookup = $path_lookup->{regex};
+ $$pathmatchref .= '/{' . $name . '}' if defined($pathmatchref);
+ } elsif ($path_lookup->{folders}) {
+ $path_lookup = $path_lookup->{folders}->{$comp};
+ $$pathmatchref .= '/' . $comp if defined($pathmatchref);
+ } else {
+ die "internal error";
+ }
+
+ return undef if !$path_lookup;
+
+ if (my $info = $path_lookup->{SUBCLASS}) {
+ $class = $info->{subclass};
+
+ my $fd = $info->{fragmentDelimiter};
+
+ if (defined($fd)) {
+ # we only support the empty string '' (match whole URI)
+ die "unsupported fragmentDelimiter '$fd'"
+ if $fd ne '';
+
+ $stack = [ join ('/', @$stack) ] if scalar(@$stack) > 1;
+ }
+ $path_lookup = $method_path_lookup->{$class};
+ }
+ }
+
+ return undef if !$path_lookup;
+
+ return ($class, $path_lookup);
+}
+
+sub find_handler {
+ my ($class, $method, $path, $uri_param, $pathmatchref) = @_;
+
+ my $stack = [ grep { length($_) > 0 } split('\/+' , $path)]; # skip empty fragments
+
+ my ($handler_class, $path_info);
+ eval {
+ ($handler_class, $path_info) = $class->map_path_to_methods($stack, $uri_param, $pathmatchref);
+ };
+ my $err = $@;
+ syslog('err', $err) if $err;
+
+ return undef if !($handler_class && $path_info);
+
+ my $method_info = $path_info->{$method};
+
+ return undef if !$method_info;
+
+ return ($handler_class, $method_info);
+}
+
+sub handle {
+ my ($self, $info, $param) = @_;
+
+ my $func = $info->{code};
+
+ if (!($info->{name} && $func)) {
+ raise("Method lookup failed ('$info->{name}')\n",
+ code => HTTP_INTERNAL_SERVER_ERROR);
+ }
+
+ if (my $schema = $info->{parameters}) {
+ # warn "validate ". Dumper($param}) . "\n" . Dumper($schema);
+ PVE::APIClient::JSONSchema::validate($param, $schema);
+ # untaint data (already validated)
+ my $extra = delete $param->{'extra-args'};
+ while (my ($key, $val) = each %$param) {
+ ($param->{$key}) = $val =~ /^(.*)$/s;
+ }
+ $param->{'extra-args'} = [map { /^(.*)$/ } @$extra] if $extra;
+ }
+
+ my $result = &$func($param);
+
+ # todo: this is only to be safe - disable?
+ if (my $schema = $info->{returns}) {
+ PVE::APIClient::JSONSchema::validate($result, $schema, "Result verification failed\n");
+ }
+
+ return $result;
+}
+
+# format option, display type and description
+# $name: option name
+# $display_name: for example "-$name" of "<$name>", pass undef to use "$name:"
+# $phash: json schema property hash
+# $format: 'asciidoc', 'short', 'long' or 'full'
+# $style: 'config', 'config-sub', 'arg' or 'fixed'
+# $mapdef: parameter mapping ({ desc => XXX, func => sub {...} })
+my $get_property_description = sub {
+ my ($name, $style, $phash, $format, $hidepw, $mapdef) = @_;
+
+ my $res = '';
+
+ $format = 'asciidoc' if !defined($format);
+
+ my $descr = $phash->{description} || "no description available";
+
+ if ($phash->{verbose_description} &&
+ ($style eq 'config' || $style eq 'config-sub')) {
+ $descr = $phash->{verbose_description};
+ }
+
+ chomp $descr;
+
+ my $type_text = PVE::APIClient::JSONSchema::schema_get_type_text($phash, $style);
+
+ if ($hidepw && $name eq 'password') {
+ $type_text = '';
+ }
+
+ if ($mapdef && $phash->{type} eq 'string') {
+ $type_text = $mapdef->{desc};
+ }
+
+ if ($format eq 'asciidoc') {
+
+ if ($style eq 'config') {
+ $res .= "`$name`: ";
+ } elsif ($style eq 'config-sub') {
+ $res .= "`$name`=";
+ } elsif ($style eq 'arg') {
+ $res .= "`--$name` ";
+ } elsif ($style eq 'fixed') {
+ $res .= "`<$name>`: ";
+ } else {
+ die "unknown style '$style'";
+ }
+
+ $res .= "`$type_text` " if $type_text;
+
+ if (defined(my $dv = $phash->{default})) {
+ $res .= "('default =' `$dv`)";
+ }
+
+ if ($style eq 'config-sub') {
+ $res .= ";;\n\n";
+ } else {
+ $res .= "::\n\n";
+ }
+
+ my $wdescr = $descr;
+ chomp $wdescr;
+ $wdescr =~ s/^$/+/mg;
+
+ $res .= $wdescr . "\n";
+
+ if (my $req = $phash->{requires}) {
+ my $tmp .= ref($req) ? join(', ', @$req) : $req;
+ $res .= "+\nNOTE: Requires option(s): `$tmp`\n";
+ }
+ $res .= "\n";
+
+ } elsif ($format eq 'short' || $format eq 'long' || $format eq 'full') {
+
+ my $defaulttxt = '';
+ if (defined(my $dv = $phash->{default})) {
+ $defaulttxt = " (default=$dv)";
+ }
+
+ my $display_name;
+ if ($style eq 'config') {
+ $display_name = "$name:";
+ } elsif ($style eq 'arg') {
+ $display_name = "-$name";
+ } elsif ($style eq 'fixed') {
+ $display_name = "<$name>";
+ } else {
+ die "unknown style '$style'";
+ }
+
+ my $tmp = sprintf " %-10s %s$defaulttxt\n", $display_name, "$type_text";
+ my $indend = " ";
+
+ $res .= Text::Wrap::wrap('', $indend, ($tmp));
+ $res .= "\n",
+ $res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n";
+
+ if (my $req = $phash->{requires}) {
+ my $tmp = "Requires option(s): ";
+ $tmp .= ref($req) ? join(', ', @$req) : $req;
+ $res .= Text::Wrap::wrap($indend, $indend, ($tmp)). "\n\n";
+ }
+
+ } else {
+ die "unknown format '$format'";
+ }
+
+ return $res;
+};
+
+# translate parameter mapping definition
+# $mapping_array is a array which can contain:
+# strings ... in that case we assume it is a parameter name, and
+# we want to load that parameter from a file
+# [ param_name, func, desc] ... allows you to specify a arbitrary
+# mapping func for any param
+#
+# Returns: a hash indexed by parameter_name,
+# i.e. { param_name => { func => .., desc => ... } }
+my $compute_param_mapping_hash = sub {
+ my ($mapping_array) = @_;
+
+ my $res = {};
+
+ return $res if !defined($mapping_array);
+
+ foreach my $item (@$mapping_array) {
+ my ($name, $func, $desc, $interactive);
+ if (ref($item) eq 'ARRAY') {
+ ($name, $func, $desc, $interactive) = @$item;
+ } else {
+ $name = $item;
+ $func = sub { return PVE::APIClient::Tools::file_get_contents($_[0]) };
+ }
+ $desc //= '<filepath>';
+ $res->{$name} = { desc => $desc, func => $func, interactive => $interactive };
+ }
+
+ return $res;
+};
+
+# generate usage information for command line tools
+#
+# $name ... the name of the method
+# $prefix ... usually something like "$exename $cmd" ('pvesm add')
+# $arg_param ... list of parameters we want to get as ordered arguments
+# on the command line (or single parameter name for lists)
+# $fixed_param ... do not generate and info about those parameters
+# $format:
+# 'long' ... default (text, list all options)
+# 'short' ... command line only (text, one line)
+# 'full' ... text, include description
+# 'asciidoc' ... generate asciidoc for man pages (like 'full')
+# $hidepw ... hide password option (use this if you provide a read passwork callback)
+# $param_mapping_func ... mapping for string parameters to file path parameters
+sub usage_str {
+ my ($self, $name, $prefix, $arg_param, $fixed_param, $format, $hidepw, $param_mapping_func) = @_;
+
+ $format = 'long' if !$format;
+
+ my $info = $self->map_method_by_name($name);
+ my $schema = $info->{parameters};
+ my $prop = $schema->{properties};
+
+ my $out = '';
+
+ my $arg_hash = {};
+
+ my $args = '';
+
+ $arg_param = [ $arg_param ] if $arg_param && !ref($arg_param);
+
+ foreach my $p (@$arg_param) {
+ next if !$prop->{$p}; # just to be sure
+ my $pd = $prop->{$p};
+
+ $arg_hash->{$p} = 1;
+ $args .= " " if $args;
+ if ($pd->{format} && $pd->{format} =~ m/-list/) {
+ $args .= "{<$p>}";
+ } else {
+ $args .= $pd->{optional} ? "[<$p>]" : "<$p>";
+ }
+ }
+
+ my $argdescr = '';
+ foreach my $k (@$arg_param) {
+ next if defined($fixed_param->{$k}); # just to be sure
+ next if !$prop->{$k}; # just to be sure
+ $argdescr .= &$get_property_description($k, 'fixed', $prop->{$k}, $format, 0);
+ }
+
+ my $idx_param = {}; # -vlan\d+ -scsi\d+
+
+ my $opts = '';
+ foreach my $k (sort keys %$prop) {
+ next if $arg_hash->{$k};
+ next if defined($fixed_param->{$k});
+
+ my $type_text = $prop->{$k}->{type} || 'string';
+
+ next if $hidepw && ($k eq 'password') && !$prop->{$k}->{optional};
+
+ my $base = $k;
+ if ($k =~ m/^([a-z]+)(\d+)$/) {
+ my ($name, $idx) = ($1, $2);
+ next if $idx_param->{$name};
+ if ($idx == 0 && defined($prop->{"${name}1"})) {
+ $idx_param->{$name} = 1;
+ $base = "${name}[n]";
+ }
+ }
+
+ my $param_mapping_hash = $compute_param_mapping_hash->(&$param_mapping_func($name))
+ if $param_mapping_func;
+
+ $opts .= &$get_property_description($base, 'arg', $prop->{$k}, $format,
+ $hidepw, $param_mapping_hash->{$k});
+
+ if (!$prop->{$k}->{optional}) {
+ $args .= " " if $args;
+ $args .= "--$base <$type_text>"
+ }
+ }
+
+ if ($format eq 'asciidoc') {
+ $out .= "*${prefix}*";
+ $out .= " `$args`" if $args;
+ $out .= $opts ? " `[OPTIONS]`\n" : "\n";
+ } else {
+ $out .= "USAGE: " if $format ne 'short';
+ $out .= "$prefix $args";
+ $out .= $opts ? " [OPTIONS]\n" : "\n";
+ }
+
+ return $out if $format eq 'short';
+
+ if ($info->{description}) {
+ if ($format eq 'asciidoc') {
+ my $desc = Text::Wrap::wrap('', '', ($info->{description}));
+ $out .= "\n$desc\n\n";
+ } elsif ($format eq 'full') {
+ my $desc = Text::Wrap::wrap(' ', ' ', ($info->{description}));
+ $out .= "\n$desc\n\n";
+ }
+ }
+
+ $out .= $argdescr if $argdescr;
+
+ $out .= $opts if $opts;
+
+ return $out;
+}
+
+# generate docs from JSON schema properties
+sub dump_properties {
+ my ($prop, $format, $style, $filterFn) = @_;
+
+ my $raw = '';
+
+ $style //= 'config';
+
+ my $idx_param = {}; # -vlan\d+ -scsi\d+
+
+ foreach my $k (sort keys %$prop) {
+ my $phash = $prop->{$k};
+
+ next if defined($filterFn) && &$filterFn($k, $phash);
+ next if $phash->{alias};
+
+ my $base = $k;
+ if ($k =~ m/^([a-z]+)(\d+)$/) {
+ my ($name, $idx) = ($1, $2);
+ next if $idx_param->{$name};
+ if ($idx == 0 && defined($prop->{"${name}1"})) {
+ $idx_param->{$name} = 1;
+ $base = "${name}[n]";
+ }
+ }
+
+ $raw .= &$get_property_description($base, $style, $phash, $format, 0);
+
+ next if $style ne 'config';
+
+ my $prop_fmt = $phash->{format};
+ next if !$prop_fmt;
+
+ if (ref($prop_fmt) ne 'HASH') {
+ $prop_fmt = PVE::APIClient::JSONSchema::get_format($prop_fmt);
+ }
+
+ next if !(ref($prop_fmt) && (ref($prop_fmt) eq 'HASH'));
+
+ $raw .= dump_properties($prop_fmt, $format, 'config-sub')
+
+ }
+
+ return $raw;
+}
+
+my $replace_file_names_with_contents = sub {
+ my ($param, $param_mapping_hash) = @_;
+
+ while (my ($k, $d) = each %$param_mapping_hash) {
+ next if $d->{interactive}; # handled by the JSONSchema's get_options code
+ $param->{$k} = $d->{func}->($param->{$k})
+ if defined($param->{$k});
+ }
+
+ return $param;
+};
+
+sub cli_handler {
+ my ($self, $prefix, $name, $args, $arg_param, $fixed_param, $read_password_func, $param_mapping_func) = @_;
+
+ my $info = $self->map_method_by_name($name);
+
+ my $res;
+ eval {
+ my $param_mapping_hash = $compute_param_mapping_hash->($param_mapping_func->($name)) if $param_mapping_func;
+ my $param = PVE::APIClient::JSONSchema::get_options($info->{parameters}, $args, $arg_param, $fixed_param, $read_password_func, $param_mapping_hash);
+
+ if (defined($param_mapping_hash)) {
+ &$replace_file_names_with_contents($param, $param_mapping_hash);
+ }
+
+ $res = $self->handle($info, $param);
+ };
+ if (my $err = $@) {
+ my $ec = ref($err);
+
+ die $err if !$ec || $ec ne "PVE::APIClient::Exception" || !$err->is_param_exc();
+
+ $err->{usage} = $self->usage_str($name, $prefix, $arg_param, $fixed_param, 'short', $read_password_func, $param_mapping_func);
+
+ die $err;
+ }
+
+ return $res;
+}
+
+# utility methods
+# note: this modifies the original hash by adding the id property
+sub hash_to_array {
+ my ($hash, $idprop) = @_;
+
+ my $res = [];
+ return $res if !$hash;
+
+ foreach my $k (keys %$hash) {
+ $hash->{$k}->{$idprop} = $k;
+ push @$res, $hash->{$k};
+ }
+
+ return $res;
+}
+
+1;
--- /dev/null
+package PVE::APIClient::SafeSyslog;
+
+use strict;
+use warnings;
+use File::Basename;
+use Sys::Syslog ();
+use Encode;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = '1.00';
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw(syslog initlog);
+
+my $log_tag = "unknown";
+
+# never log to console - thats too slow, and
+# it corrupts the DBD database connection!
+
+sub syslog {
+ eval { Sys::Syslog::syslog (@_); }; # ignore errors
+}
+
+sub initlog {
+ my ($tag, $facility) = @_;
+
+ if ($tag) {
+ $tag = basename($tag);
+
+ $tag = encode("ascii", decode_utf8($tag));
+
+ $log_tag = $tag;
+ }
+
+ $facility = "daemon" if !$facility;
+
+ # never log to console - thats too slow
+ Sys::Syslog::setlogsock ('unix');
+
+ Sys::Syslog::openlog ($log_tag, 'pid', $facility);
+}
+
+sub tag {
+ return $log_tag;
+}
+
+1;
--- /dev/null
+package PVE::APIClient::SectionConfig;
+
+use strict;
+use warnings;
+use Digest::SHA;
+use PVE::APIClient::Exception qw(raise_param_exc);
+use PVE::APIClient::JSONSchema qw(get_standard_option);
+
+use Data::Dumper;
+
+my $defaultData = {
+ options => {},
+ plugins => {},
+ plugindata => {},
+ propertyList => {},
+};
+
+sub private {
+ die "overwrite me";
+ return $defaultData;
+}
+
+sub register {
+ my ($class) = @_;
+
+ my $type = $class->type();
+ my $pdata = $class->private();
+
+ die "duplicate plugin registration (type = $type)"
+ if defined($pdata->{plugins}->{$type});
+
+ my $plugindata = $class->plugindata();
+ $pdata->{plugindata}->{$type} = $plugindata;
+ $pdata->{plugins}->{$type} = $class;
+}
+
+sub type {
+ die "overwrite me";
+}
+
+sub properties {
+ return {};
+}
+
+sub options {
+ return {};
+}
+
+sub plugindata {
+ return {};
+}
+
+sub createSchema {
+ my ($class, $skip_type) = @_;
+
+ my $pdata = $class->private();
+ my $propertyList = $pdata->{propertyList};
+ my $plugins = $pdata->{plugins};
+
+ my $props = {};
+
+ my $copy_property = sub {
+ my ($src) = @_;
+
+ my $res = {};
+ foreach my $k (keys %$src) {
+ $res->{$k} = $src->{$k};
+ }
+
+ return $res;
+ };
+
+ foreach my $p (keys %$propertyList) {
+ next if $skip_type && $p eq 'type';
+
+ if (!$propertyList->{$p}->{optional}) {
+ $props->{$p} = $propertyList->{$p};
+ next;
+ }
+
+ my $required = 1;
+
+ my $copts = $class->options();
+ $required = 0 if defined($copts->{$p}) && $copts->{$p}->{optional};
+
+ foreach my $t (keys %$plugins) {
+ my $opts = $pdata->{options}->{$t} || {};
+ $required = 0 if !defined($opts->{$p}) || $opts->{$p}->{optional};
+ }
+
+ if ($required) {
+ # make a copy, because we modify the optional property
+ my $res = &$copy_property($propertyList->{$p});
+ $res->{optional} = 0;
+ $props->{$p} = $res;
+ } else {
+ $props->{$p} = $propertyList->{$p};
+ }
+ }
+
+ return {
+ type => "object",
+ additionalProperties => 0,
+ properties => $props,
+ };
+}
+
+sub updateSchema {
+ my ($class, $single_class) = @_;
+
+ my $pdata = $class->private();
+ my $propertyList = $pdata->{propertyList};
+ my $plugins = $pdata->{plugins};
+
+ my $props = {};
+
+ my $filter_type = $class->type() if $single_class;
+
+ foreach my $p (keys %$propertyList) {
+ next if $p eq 'type';
+
+ my $copts = $class->options();
+
+ next if defined($filter_type) && !defined($copts->{$p});
+
+ if (!$propertyList->{$p}->{optional}) {
+ $props->{$p} = $propertyList->{$p};
+ next;
+ }
+
+ my $modifyable = 0;
+
+ $modifyable = 1 if defined($copts->{$p}) && !$copts->{$p}->{fixed};
+
+ foreach my $t (keys %$plugins) {
+ my $opts = $pdata->{options}->{$t} || {};
+ next if !defined($opts->{$p});
+ $modifyable = 1 if !$opts->{$p}->{fixed};
+ }
+ next if !$modifyable;
+
+ $props->{$p} = $propertyList->{$p};
+ }
+
+ $props->{digest} = get_standard_option('pve-config-digest');
+
+ $props->{delete} = {
+ type => 'string', format => 'pve-configid-list',
+ description => "A list of settings you want to delete.",
+ maxLength => 4096,
+ optional => 1,
+ };
+
+ return {
+ type => "object",
+ additionalProperties => 0,
+ properties => $props,
+ };
+}
+
+sub init {
+ my ($class) = @_;
+
+ my $pdata = $class->private();
+
+ foreach my $k (qw(options plugins plugindata propertyList)) {
+ $pdata->{$k} = {} if !$pdata->{$k};
+ }
+
+ my $plugins = $pdata->{plugins};
+ my $propertyList = $pdata->{propertyList};
+
+ foreach my $type (keys %$plugins) {
+ my $props = $plugins->{$type}->properties();
+ foreach my $p (keys %$props) {
+ die "duplicate property '$p'" if defined($propertyList->{$p});
+ my $res = $propertyList->{$p} = {};
+ my $data = $props->{$p};
+ for my $a (keys %$data) {
+ $res->{$a} = $data->{$a};
+ }
+ $res->{optional} = 1;
+ }
+ }
+
+ foreach my $type (keys %$plugins) {
+ my $opts = $plugins->{$type}->options();
+ foreach my $p (keys %$opts) {
+ die "undefined property '$p'" if !$propertyList->{$p};
+ }
+ $pdata->{options}->{$type} = $opts;
+ }
+
+ $propertyList->{type}->{type} = 'string';
+ $propertyList->{type}->{enum} = [sort keys %$plugins];
+}
+
+sub lookup {
+ my ($class, $type) = @_;
+
+ my $pdata = $class->private();
+ my $plugin = $pdata->{plugins}->{$type};
+
+ die "unknown section type '$type'\n" if !$plugin;
+
+ return $plugin;
+}
+
+sub lookup_types {
+ my ($class) = @_;
+
+ my $pdata = $class->private();
+
+ return [ sort keys %{$pdata->{plugins}} ];
+}
+
+sub decode_value {
+ my ($class, $type, $key, $value) = @_;
+
+ return $value;
+}
+
+sub encode_value {
+ my ($class, $type, $key, $value) = @_;
+
+ return $value;
+}
+
+sub check_value {
+ my ($class, $type, $key, $value, $storeid, $skipSchemaCheck) = @_;
+
+ my $pdata = $class->private();
+
+ return $value if $key eq 'type' && $type eq $value;
+
+ my $opts = $pdata->{options}->{$type};
+ die "unknown section type '$type'\n" if !$opts;
+
+ die "unexpected property '$key'\n" if !defined($opts->{$key});
+
+ my $schema = $pdata->{propertyList}->{$key};
+ die "unknown property type\n" if !$schema;
+
+ my $ct = $schema->{type};
+
+ $value = 1 if $ct eq 'boolean' && !defined($value);
+
+ die "got undefined value\n" if !defined($value);
+
+ die "property contains a line feed\n" if $value =~ m/[\n\r]/;
+
+ if (!$skipSchemaCheck) {
+ my $errors = {};
+ PVE::APIClient::JSONSchema::check_prop($value, $schema, '', $errors);
+ if (scalar(keys %$errors)) {
+ die "$errors->{$key}\n" if $errors->{$key};
+ die "$errors->{_root}\n" if $errors->{_root};
+ die "unknown error\n";
+ }
+ }
+
+ if ($ct eq 'boolean' || $ct eq 'integer' || $ct eq 'number') {
+ return $value + 0; # convert to number
+ }
+
+ return $value;
+}
+
+sub parse_section_header {
+ my ($class, $line) = @_;
+
+ if ($line =~ m/^(\S+):\s*(\S+)\s*$/) {
+ my ($type, $sectionId) = ($1, $2);
+ my $errmsg = undef; # set if you want to skip whole section
+ my $config = {}; # to return additional attributes
+ return ($type, $sectionId, $errmsg, $config);
+ }
+ return undef;
+}
+
+sub format_section_header {
+ my ($class, $type, $sectionId, $scfg, $done_hash) = @_;
+
+ return "$type: $sectionId\n";
+}
+
+
+sub parse_config {
+ my ($class, $filename, $raw) = @_;
+
+ my $pdata = $class->private();
+
+ my $ids = {};
+ my $order = {};
+
+ $raw = '' if !defined($raw);
+
+ my $digest = Digest::SHA::sha1_hex($raw);
+
+ my $pri = 1;
+
+ my $lineno = 0;
+ my @lines = split(/\n/, $raw);
+ my $nextline = sub {
+ while (my $line = shift @lines) {
+ $lineno++;
+ return $line if $line !~ /^\s*(?:#|$)/;
+ }
+ };
+
+ while (my $line = &$nextline()) {
+ my $errprefix = "file $filename line $lineno";
+
+ my ($type, $sectionId, $errmsg, $config) = $class->parse_section_header($line);
+ if ($config) {
+ my $ignore = 0;
+
+ my $plugin;
+
+ if ($errmsg) {
+ $ignore = 1;
+ chomp $errmsg;
+ warn "$errprefix (skip section '$sectionId'): $errmsg\n";
+ } elsif (!$type) {
+ $ignore = 1;
+ warn "$errprefix (skip section '$sectionId'): missing type - internal error\n";
+ } else {
+ if (!($plugin = $pdata->{plugins}->{$type})) {
+ $ignore = 1;
+ warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n";
+ }
+ }
+
+ while ($line = &$nextline()) {
+ next if $ignore; # skip
+
+ $errprefix = "file $filename line $lineno";
+
+ if ($line =~ m/^\s+(\S+)(\s+(.*\S))?\s*$/) {
+ my ($k, $v) = ($1, $3);
+
+ eval {
+ die "duplicate attribute\n" if defined($config->{$k});
+ $config->{$k} = $plugin->check_value($type, $k, $v, $sectionId);
+ };
+ warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $@" if $@;
+
+ } else {
+ warn "$errprefix (section '$sectionId') - ignore config line: $line\n";
+ }
+ }
+
+ if (!$ignore && $type && $plugin && $config) {
+ $config->{type} = $type;
+ eval { $ids->{$sectionId} = $plugin->check_config($sectionId, $config, 1, 1); };
+ warn "$errprefix (skip section '$sectionId'): $@" if $@;
+ $order->{$sectionId} = $pri++;
+ }
+
+ } else {
+ warn "$errprefix - ignore config line: $line\n";
+ }
+ }
+
+
+ my $cfg = { ids => $ids, order => $order, digest => $digest};
+
+ return $cfg;
+}
+
+sub check_config {
+ my ($class, $sectionId, $config, $create, $skipSchemaCheck) = @_;
+
+ my $type = $class->type();
+ my $pdata = $class->private();
+ my $opts = $pdata->{options}->{$type};
+
+ my $settings = { type => $type };
+
+ foreach my $k (keys %$config) {
+ my $value = $config->{$k};
+
+ die "can't change value of fixed parameter '$k'\n"
+ if !$create && $opts->{$k}->{fixed};
+
+ if (defined($value)) {
+ my $tmp = $class->check_value($type, $k, $value, $sectionId, $skipSchemaCheck);
+ $settings->{$k} = $class->decode_value($type, $k, $tmp);
+ } else {
+ die "got undefined value for option '$k'\n";
+ }
+ }
+
+ if ($create) {
+ # check if we have a value for all required options
+ foreach my $k (keys %$opts) {
+ next if $opts->{$k}->{optional};
+ die "missing value for required option '$k'\n"
+ if !defined($config->{$k});
+ }
+ }
+
+ return $settings;
+}
+
+my $format_config_line = sub {
+ my ($schema, $key, $value) = @_;
+
+ my $ct = $schema->{type};
+
+ die "property '$key' contains a line feed\n"
+ if ($key =~ m/[\n\r]/) || ($value =~ m/[\n\r]/);
+
+ if ($ct eq 'boolean') {
+ return "\t$key " . ($value ? 1 : 0) . "\n"
+ if defined($value);
+ } else {
+ return "\t$key $value\n" if "$value" ne '';
+ }
+};
+
+sub write_config {
+ my ($class, $filename, $cfg) = @_;
+
+ my $pdata = $class->private();
+ my $propertyList = $pdata->{propertyList};
+
+ my $out = '';
+
+ my $ids = $cfg->{ids};
+ my $order = $cfg->{order};
+
+ my $maxpri = 0;
+ foreach my $sectionId (keys %$ids) {
+ my $pri = $order->{$sectionId};
+ $maxpri = $pri if $pri && $pri > $maxpri;
+ }
+ foreach my $sectionId (keys %$ids) {
+ if (!defined ($order->{$sectionId})) {
+ $order->{$sectionId} = ++$maxpri;
+ }
+ }
+
+ foreach my $sectionId (sort {$order->{$a} <=> $order->{$b}} keys %$ids) {
+ my $scfg = $ids->{$sectionId};
+ my $type = $scfg->{type};
+ my $opts = $pdata->{options}->{$type};
+
+ die "unknown section type '$type'\n" if !$opts;
+
+ my $done_hash = {};
+
+ my $data = $class->format_section_header($type, $sectionId, $scfg, $done_hash);
+ if ($scfg->{comment} && !$done_hash->{comment}) {
+ my $k = 'comment';
+ my $v = $class->encode_value($type, $k, $scfg->{$k});
+ $data .= &$format_config_line($propertyList->{$k}, $k, $v);
+ }
+
+ $data .= "\tdisable\n" if $scfg->{disable} && !$done_hash->{disable};
+
+ $done_hash->{comment} = 1;
+ $done_hash->{disable} = 1;
+
+ my @option_keys = sort keys %$opts;
+ foreach my $k (@option_keys) {
+ next if defined($done_hash->{$k});
+ next if $opts->{$k}->{optional};
+ $done_hash->{$k} = 1;
+ my $v = $scfg->{$k};
+ die "section '$sectionId' - missing value for required option '$k'\n"
+ if !defined ($v);
+ $v = $class->encode_value($type, $k, $v);
+ $data .= &$format_config_line($propertyList->{$k}, $k, $v);
+ }
+
+ foreach my $k (@option_keys) {
+ next if defined($done_hash->{$k});
+ my $v = $scfg->{$k};
+ next if !defined($v);
+ $v = $class->encode_value($type, $k, $v);
+ $data .= &$format_config_line($propertyList->{$k}, $k, $v);
+ }
+
+ $out .= "$data\n";
+ }
+
+ return $out;
+}
+
+sub assert_if_modified {
+ my ($cfg, $digest) = @_;
+
+ PVE::APIClient::Tools::assert_if_modified($cfg->{digest}, $digest);
+}
+
+1;
--- /dev/null
+package PVE::APIClient::Tools;
+
+use strict;
+use warnings;
+use POSIX qw(EINTR EEXIST EOPNOTSUPP);
+use base 'Exporter';
+
+use IO::File;
+use Text::ParseWords;
+
+our @EXPORT_OK = qw(
+$IPV6RE
+$IPV4RE
+split_list
+file_set_contents
+file_get_contents
+extract_param
+);
+
+my $IPV4OCTET = "(?:25[0-5]|(?:2[0-4]|1[0-9]|[1-9])?[0-9])";
+our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)";
+my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})";
+my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))";
+
+our $IPV6RE = "(?:" .
+ "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" .
+ "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" .
+ "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" .
+ "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))";
+
+our $IPRE = "(?:$IPV4RE|$IPV6RE)";
+
+sub file_set_contents {
+ my ($filename, $data, $perm) = @_;
+
+ $perm = 0644 if !defined($perm);
+
+ my $tmpname = "$filename.tmp.$$";
+
+ eval {
+ my ($fh, $tries) = (undef, 0);
+ while (!$fh && $tries++ < 3) {
+ $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT|O_EXCL, $perm);
+ if (!$fh && $! == EEXIST) {
+ unlink($tmpname) or die "unable to delete old temp file: $!\n";
+ }
+ }
+ die "unable to open file '$tmpname' - $!\n" if !$fh;
+ die "unable to write '$tmpname' - $!\n" unless print $fh $data;
+ die "closing file '$tmpname' failed - $!\n" unless close $fh;
+ };
+ my $err = $@;
+
+ if ($err) {
+ unlink $tmpname;
+ die $err;
+ }
+
+ if (!rename($tmpname, $filename)) {
+ my $msg = "close (rename) atomic file '$filename' failed: $!\n";
+ unlink $tmpname;
+ die $msg;
+ }
+}
+
+sub file_get_contents {
+ my ($filename, $max) = @_;
+
+ my $fh = IO::File->new($filename, "r") ||
+ die "can't open '$filename' - $!\n";
+
+ my $content = safe_read_from($fh, $max, 0, $filename);
+
+ close $fh;
+
+ return $content;
+}
+
+sub file_read_firstline {
+ my ($filename) = @_;
+
+ my $fh = IO::File->new ($filename, "r");
+ return undef if !$fh;
+ my $res = <$fh>;
+ chomp $res if $res;
+ $fh->close;
+ return $res;
+}
+
+sub safe_read_from {
+ my ($fh, $max, $oneline, $filename) = @_;
+
+ $max = 32768 if !$max;
+
+ my $subject = defined($filename) ? "file '$filename'" : 'input';
+
+ my $br = 0;
+ my $input = '';
+ my $count;
+ while ($count = sysread($fh, $input, 8192, $br)) {
+ $br += $count;
+ die "$subject too long - aborting\n" if $br > $max;
+ if ($oneline && $input =~ m/^(.*)\n/) {
+ $input = $1;
+ last;
+ }
+ }
+ die "unable to read $subject - $!\n" if !defined($count);
+
+ return $input;
+}
+
+sub split_list {
+ my $listtxt = shift || '';
+
+ return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
+
+ $listtxt =~ s/[,;]/ /g;
+ $listtxt =~ s/^\s+//;
+
+ my @data = split (/\s+/, $listtxt);
+
+ return @data;
+}
+
+# split an shell argument string into an array,
+sub split_args {
+ my ($str) = @_;
+
+ return $str ? [ Text::ParseWords::shellwords($str) ] : [];
+}
+
+sub extract_param {
+ my ($param, $key) = @_;
+
+ my $res = $param->{$key};
+ delete $param->{$key};
+
+ return $res;
+}
+
+1;
+++ /dev/null
-package PVE::CLIHandler;
-
-use strict;
-use warnings;
-
-use PVE::SafeSyslog;
-use PVE::Exception qw(raise raise_param_exc);
-use PVE::RESTHandler;
-
-use base qw(PVE::RESTHandler);
-
-# $cmddef defines which (sub)commands are available in a specific CLI class.
-# A real command is always an array consisting of its class, name, array of
-# position fixed (required) parameters and hash of predefined parameters when
-# mapping a CLI command t o an API call. Optionally an output method can be
-# passed at the end, e.g., for formatting or transformation purpose.
-#
-# [class, name, fixed_params, API_pre-set params, output_sub ]
-#
-# In case of so called 'simple commands', the $cmddef can be also just an
-# array.
-#
-# Examples:
-# $cmddef = {
-# command => [ 'PVE::API2::Class', 'command', [ 'arg1', 'arg2' ], { node => $nodename } ],
-# do => {
-# this => [ 'PVE::API2::OtherClass', 'method', [ 'arg1' ], undef, sub {
-# my ($res) = @_;
-# print "$res\n";
-# }],
-# that => [ 'PVE::API2::OtherClass', 'subroutine' [] ],
-# },
-# dothat => { alias => 'do that' },
-# }
-my $cmddef;
-my $exename;
-my $cli_handler_class;
-
-my $assert_initialized = sub {
- my @caller = caller;
- die "$caller[0]:$caller[2] - not initialized\n"
- if !($cmddef && $exename && $cli_handler_class);
-};
-
-my $abort = sub {
- my ($reason, $cmd) = @_;
- print_usage_short (\*STDERR, $reason, $cmd);
- exit (-1);
-};
-
-my $expand_command_name = sub {
- my ($def, $cmd) = @_;
-
- return $cmd if exists $def->{$cmd}; # command is already complete
-
- my @expanded = grep { /^\Q$cmd\E/ } keys %$def;
- return $expanded[0] if scalar(@expanded) == 1; # enforce exact match
-
- return undef;
-};
-
-my $get_commands = sub {
- my $def = shift // die "no command definition passed!";
- return [ grep { !(ref($def->{$_}) eq 'HASH' && defined($def->{$_}->{alias})) } sort keys %$def ];
-};
-
-my $complete_command_names = sub { $get_commands->($cmddef) };
-
-# traverses the command definition using the $argv array, resolving one level
-# of aliases.
-# Returns the matching (sub) command and its definition, and argument array for
-# this (sub) command and a hash where we marked which (sub) commands got
-# expanded (e.g. st => status) while traversing
-sub resolve_cmd {
- my ($argv, $is_alias) = @_;
-
- my ($def, $cmd) = ($cmddef, $argv);
- my $cmdstr = $exename;
-
- if (ref($argv) eq 'ARRAY') {
- my $expanded_last_arg;
- my $last_arg_id = scalar(@$argv) - 1;
-
- for my $i (0..$last_arg_id) {
- $cmd = $expand_command_name->($def, $argv->[$i]);
- if (defined($cmd)) {
- # If the argument was expanded (or was already complete) and it
- # is the final argument, tell our caller about it:
- $expanded_last_arg = $cmd if $i == $last_arg_id;
- } else {
- # Otherwise continue with the unexpanded version of it.
- $cmd = $argv->[$i];
- }
- $cmdstr .= " $cmd";
- $def = $def->{$cmd};
- last if !defined($def);
-
- if (ref($def) eq 'ARRAY') {
- # could expand to a real command, rest of $argv are its arguments
- my $cmd_args = [ @$argv[$i+1..$last_arg_id] ];
- return ($cmd, $def, $cmd_args, $expanded_last_arg, $cmdstr);
- }
-
- if (defined($def->{alias})) {
- die "alias loop detected for '$cmd'" if $is_alias; # avoids cycles
- # replace aliased (sub)command with the expanded aliased command
- splice @$argv, $i, 1, split(/ +/, $def->{alias});
- return resolve_cmd($argv, 1);
- }
- }
- # got either a special command (bashcomplete, verifyapi) or an unknown
- # cmd, just return first entry as cmd and the rest of $argv as cmd_arg
- my $cmd_args = [ @$argv[1..$last_arg_id] ];
- return ($argv->[0], $def, $cmd_args, $expanded_last_arg, $cmdstr);
- }
- return ($cmd, $def, undef, undef, $cmdstr);
-}
-
-sub generate_usage_str {
- my ($format, $cmd, $indent, $separator, $sortfunc) = @_;
-
- $assert_initialized->();
- die 'format required' if !$format;
-
- $sortfunc //= sub { sort keys %{$_[0]} };
- $separator //= '';
- $indent //= '';
-
- my $read_password_func = $cli_handler_class->can('read_password');
- my $param_mapping_func = $cli_handler_class->can('param_mapping') ||
- $cli_handler_class->can('string_param_file_mapping');
-
- my ($subcmd, $def, undef, undef, $cmdstr) = resolve_cmd($cmd);
- die "no such command '$cmd->[0]'\n" if !defined($def) && ref($cmd) eq 'ARRAY';
-
- my $generate;
- $generate = sub {
- my ($indent, $separator, $def, $prefix) = @_;
-
- my $str = '';
- if (ref($def) eq 'HASH') {
- my $oldclass = undef;
- foreach my $cmd (&$sortfunc($def)) {
-
- if (ref($def->{$cmd}) eq 'ARRAY') {
- my ($class, $name, $arg_param, $fixed_param) = @{$def->{$cmd}};
-
- $str .= $separator if $oldclass && $oldclass ne $class;
- $str .= $indent;
- $str .= $class->usage_str($name, "$prefix $cmd", $arg_param,
- $fixed_param, $format,
- $read_password_func, $param_mapping_func);
- $oldclass = $class;
-
- } elsif (defined($def->{$cmd}->{alias}) && ($format eq 'asciidoc')) {
-
- $str .= "*$prefix $cmd*\n\nAn alias for '$exename $def->{$cmd}->{alias}'.\n\n";
-
- } else {
- next if $def->{$cmd}->{alias};
-
- my $substr = $generate->($indent, $separator, $def->{$cmd}, "$prefix $cmd");
- if ($substr) {
- $substr .= $separator if $substr !~ /\Q$separator\E{2}/;
- $str .= $substr;
- }
- }
-
- }
- } else {
- my ($class, $name, $arg_param, $fixed_param) = @$def;
- $abort->("unknown command '$cmd'") if !$class;
-
- $str .= $indent;
- $str .= $class->usage_str($name, $prefix, $arg_param, $fixed_param, $format,
- $read_password_func, $param_mapping_func);
- }
- return $str;
- };
-
- return $generate->($indent, $separator, $def, $cmdstr);
-}
-
-__PACKAGE__->register_method ({
- name => 'help',
- path => 'help',
- method => 'GET',
- description => "Get help about specified command.",
- parameters => {
- additionalProperties => 0,
- properties => {
- 'extra-args' => PVE::JSONSchema::get_standard_option('extra-args', {
- description => 'Shows help for a specific command',
- completion => $complete_command_names,
- }),
- verbose => {
- description => "Verbose output format.",
- type => 'boolean',
- optional => 1,
- },
- },
- },
- returns => { type => 'null' },
-
- code => sub {
- my ($param) = @_;
-
- $assert_initialized->();
-
- my $cmd = $param->{'extra-args'};
-
- my $verbose = defined($cmd) && $cmd;
- $verbose = $param->{verbose} if defined($param->{verbose});
-
- if (!$cmd) {
- if ($verbose) {
- print_usage_verbose();
- } else {
- print_usage_short(\*STDOUT);
- }
- return undef;
- }
-
- my $str;
- if ($verbose) {
- $str = generate_usage_str('full', $cmd, '');
- } else {
- $str = generate_usage_str('short', $cmd, ' ' x 7);
- }
- $str =~ s/^\s+//;
-
- if ($verbose) {
- print "$str\n";
- } else {
- print "USAGE: $str\n";
- }
-
- return undef;
-
- }});
-
-sub print_simple_asciidoc_synopsis {
- $assert_initialized->();
-
- my $synopsis = "*${exename}* `help`\n\n";
- $synopsis .= generate_usage_str('asciidoc');
-
- return $synopsis;
-}
-
-sub print_asciidoc_synopsis {
- $assert_initialized->();
-
- my $synopsis = "";
-
- $synopsis .= "*${exename}* `<COMMAND> [ARGS] [OPTIONS]`\n\n";
-
- $synopsis .= generate_usage_str('asciidoc');
-
- $synopsis .= "\n";
-
- return $synopsis;
-}
-
-sub print_usage_verbose {
- $assert_initialized->();
-
- print "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n\n";
-
- my $str = generate_usage_str('full');
-
- print "$str\n";
-}
-
-sub print_usage_short {
- my ($fd, $msg, $cmd) = @_;
-
- $assert_initialized->();
-
- print $fd "ERROR: $msg\n" if $msg;
- print $fd "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n";
-
- print {$fd} generate_usage_str('short', $cmd, ' ' x 7, "\n", sub {
- my ($h) = @_;
- return sort {
- if (ref($h->{$a}) eq 'ARRAY' && ref($h->{$b}) eq 'ARRAY') {
- # $a and $b are both real commands order them by their class
- return $h->{$a}->[0] cmp $h->{$b}->[0] || $a cmp $b;
- } elsif (ref($h->{$a}) eq 'ARRAY' xor ref($h->{$b}) eq 'ARRAY') {
- # real command and subcommand mixed, put sub commands first
- return ref($h->{$b}) eq 'ARRAY' ? -1 : 1;
- } else {
- # both are either from the same class or subcommands
- return $a cmp $b;
- }
- } keys %$h;
- });
-}
-
-my $print_bash_completion = sub {
- my ($simple_cmd, $bash_command, $cur, $prev) = @_;
-
- my $debug = 0;
-
- return if !(defined($cur) && defined($prev) && defined($bash_command));
- return if !defined($ENV{COMP_LINE});
- return if !defined($ENV{COMP_POINT});
-
- my $cmdline = substr($ENV{COMP_LINE}, 0, $ENV{COMP_POINT});
- print STDERR "\nCMDLINE: $ENV{COMP_LINE}\n" if $debug;
-
- my $args = PVE::Tools::split_args($cmdline);
- shift @$args; # no need for program name
- my $print_result = sub {
- foreach my $p (@_) {
- print "$p\n" if $p =~ m/^$cur/;
- }
- };
-
- my ($cmd, $def) = ($simple_cmd, $cmddef);
- if (!$simple_cmd) {
- ($cmd, $def, $args, my $expanded) = resolve_cmd($args);
-
- if (defined($expanded) && $prev ne $expanded) {
- print "$expanded\n";
- return;
- }
-
- if (ref($def) eq 'HASH') {
- &$print_result(@{$get_commands->($def)});
- return;
- }
- }
- return if !$def;
-
- my $pos = scalar(@$args) - 1;
- $pos += 1 if $cmdline =~ m/\s+$/;
- print STDERR "pos: $pos\n" if $debug;
- return if $pos < 0;
-
- my $skip_param = {};
-
- my ($class, $name, $arg_param, $uri_param) = @$def;
- $arg_param //= [];
- $uri_param //= {};
-
- $arg_param = [ $arg_param ] if !ref($arg_param);
-
- map { $skip_param->{$_} = 1; } @$arg_param;
- map { $skip_param->{$_} = 1; } keys %$uri_param;
-
- my $info = $class->map_method_by_name($name);
-
- my $prop = $info->{parameters}->{properties};
-
- my $print_parameter_completion = sub {
- my ($pname) = @_;
- my $d = $prop->{$pname};
- if ($d->{completion}) {
- my $vt = ref($d->{completion});
- if ($vt eq 'CODE') {
- my $res = $d->{completion}->($cmd, $pname, $cur, $args);
- &$print_result(@$res);
- }
- } elsif ($d->{type} eq 'boolean') {
- &$print_result('0', '1');
- } elsif ($d->{enum}) {
- &$print_result(@{$d->{enum}});
- }
- };
-
- # positional arguments
- if ($pos < scalar(@$arg_param)) {
- my $pname = $arg_param->[$pos];
- &$print_parameter_completion($pname);
- return;
- }
-
- my @option_list = ();
- foreach my $key (keys %$prop) {
- next if $skip_param->{$key};
- push @option_list, "--$key";
- }
-
- if ($cur =~ m/^-/) {
- &$print_result(@option_list);
- return;
- }
-
- if ($prev =~ m/^--?(.+)$/ && $prop->{$1}) {
- my $pname = $1;
- &$print_parameter_completion($pname);
- return;
- }
-
- &$print_result(@option_list);
-};
-
-sub verify_api {
- my ($class) = @_;
-
- # simply verify all registered methods
- PVE::RESTHandler::validate_method_schemas();
-}
-
-my $get_exe_name = sub {
- my ($class) = @_;
-
- my $name = $class;
- $name =~ s/^.*:://;
- $name =~ s/_/-/g;
-
- return $name;
-};
-
-sub generate_bash_completions {
- my ($class) = @_;
-
- # generate bash completion config
-
- $exename = &$get_exe_name($class);
-
- print <<__EOD__;
-# $exename bash completion
-
-# see http://tiswww.case.edu/php/chet/bash/FAQ
-# and __ltrim_colon_completions() in /usr/share/bash-completion/bash_completion
-# this modifies global var, but I found no better way
-COMP_WORDBREAKS=\${COMP_WORDBREAKS//:}
-
-complete -o default -C '$exename bashcomplete' $exename
-__EOD__
-}
-
-sub generate_asciidoc_synopsys {
- my ($class) = @_;
- $class->generate_asciidoc_synopsis();
-};
-
-sub generate_asciidoc_synopsis {
- my ($class) = @_;
-
- $cli_handler_class = $class;
-
- $exename = &$get_exe_name($class);
-
- no strict 'refs';
- my $def = ${"${class}::cmddef"};
- $cmddef = $def;
-
- if (ref($def) eq 'ARRAY') {
- print_simple_asciidoc_synopsis();
- } else {
- $cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ];
-
- print_asciidoc_synopsis();
- }
-}
-
-# overwrite this if you want to run/setup things early
-sub setup_environment {
- my ($class) = @_;
-
- # do nothing by default
-}
-
-my $handle_cmd = sub {
- my ($args, $read_password_func, $preparefunc, $param_mapping_func) = @_;
-
- $cmddef->{help} = [ __PACKAGE__, 'help', ['extra-args'] ];
-
- my ($cmd, $def, $cmd_args, undef, $cmd_str) = resolve_cmd($args);
-
- $abort->("no command specified") if !$cmd;
-
- # call verifyapi before setup_environment(), don't execute any real code in
- # this case
- if ($cmd eq 'verifyapi') {
- PVE::RESTHandler::validate_method_schemas();
- return;
- }
-
- $cli_handler_class->setup_environment();
-
- if ($cmd eq 'bashcomplete') {
- &$print_bash_completion(undef, @$cmd_args);
- return;
- }
-
- # checked special commands, if def is still a hash we got an incomplete sub command
- $abort->("incomplete command '$cmd_str'") if ref($def) eq 'HASH';
-
- &$preparefunc() if $preparefunc;
-
- my ($class, $name, $arg_param, $uri_param, $outsub) = @{$def || []};
- $abort->("unknown command '$cmd_str'") if !$class;
-
- my $res = $class->cli_handler($cmd_str, $name, $cmd_args, $arg_param, $uri_param, $read_password_func, $param_mapping_func);
-
- &$outsub($res) if $outsub;
-};
-
-my $handle_simple_cmd = sub {
- my ($args, $read_password_func, $preparefunc, $param_mapping_func) = @_;
-
- my ($class, $name, $arg_param, $uri_param, $outsub) = @{$cmddef};
- die "no class specified" if !$class;
-
- if (scalar(@$args) >= 1) {
- if ($args->[0] eq 'help') {
- my $str = "USAGE: $name help\n";
- $str .= generate_usage_str('long');
- print STDERR "$str\n\n";
- return;
- } elsif ($args->[0] eq 'verifyapi') {
- PVE::RESTHandler::validate_method_schemas();
- return;
- }
- }
-
- $cli_handler_class->setup_environment();
-
- if (scalar(@$args) >= 1) {
- if ($args->[0] eq 'bashcomplete') {
- shift @$args;
- &$print_bash_completion($name, @$args);
- return;
- }
- }
-
- &$preparefunc() if $preparefunc;
-
- my $res = $class->cli_handler($name, $name, \@ARGV, $arg_param, $uri_param, $read_password_func, $param_mapping_func);
-
- &$outsub($res) if $outsub;
-};
-
-sub run_cli_handler {
- my ($class, %params) = @_;
-
- $cli_handler_class = $class;
-
- $ENV{'PATH'} = '/sbin:/bin:/usr/sbin:/usr/bin';
-
- foreach my $key (keys %params) {
- next if $key eq 'prepare';
- next if $key eq 'no_init'; # not used anymore
- next if $key eq 'no_rpcenv'; # not used anymore
- die "unknown parameter '$key'";
- }
-
- my $preparefunc = $params{prepare};
-
- my $read_password_func = $class->can('read_password');
- my $param_mapping_func = $cli_handler_class->can('param_mapping') ||
- $class->can('string_param_file_mapping');
-
- $exename = &$get_exe_name($class);
-
- initlog($exename);
-
- no strict 'refs';
- $cmddef = ${"${class}::cmddef"};
-
- if (ref($cmddef) eq 'ARRAY') {
- &$handle_simple_cmd(\@ARGV, $read_password_func, $preparefunc, $param_mapping_func);
- } else {
- &$handle_cmd(\@ARGV, $read_password_func, $preparefunc, $param_mapping_func);
- }
-
- exit 0;
-}
-
-1;
+++ /dev/null
-package PVE::Exception;
-
-# a way to add more information to exceptions (see man perlfunc (die))
-# use PVE::Exception qw(raise);
-# raise ("my error message", code => 400, errors => { param1 => "err1", ...} );
-
-use strict;
-use warnings;
-use vars qw(@ISA @EXPORT_OK);
-require Exporter;
-use Storable qw(dclone);
-use HTTP::Status qw(:constants);
-
-@ISA = qw(Exporter);
-
-use overload '""' => sub {local $@; shift->stringify};
-use overload 'cmp' => sub {
- my ($a, $b) = @_;
- local $@;
- return "$a" cmp "$b"; # compare as string
-};
-
-@EXPORT_OK = qw(raise raise_param_exc raise_perm_exc);
-
-sub new {
- my ($class, $msg, %param) = @_;
-
- $class = ref($class) || $class;
-
- my $self = {
- msg => $msg,
- };
-
- foreach my $p (keys %param) {
- next if defined($self->{$p});
- my $v = $param{$p};
- $self->{$p} = ref($v) ? dclone($v) : $v;
- }
-
- return bless $self;
-}
-
-sub raise {
-
- my $exc = PVE::Exception->new(@_);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub raise_perm_exc {
- my ($what) = @_;
-
- my $param = { code => HTTP_FORBIDDEN };
-
- my $msg = "Permission check failed";
-
- $msg .= " ($what)" if $what;
-
- my $exc = PVE::Exception->new("$msg\n", %$param);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub is_param_exc {
- my ($self) = @_;
-
- return $self->{code} && $self->{code} eq HTTP_BAD_REQUEST;
-}
-
-sub raise_param_exc {
- my ($errors, $usage) = @_;
-
- my $param = {
- code => HTTP_BAD_REQUEST,
- errors => $errors,
- };
-
- $param->{usage} = $usage if $usage;
-
- my $exc = PVE::Exception->new("Parameter verification failed.\n", %$param);
-
- my ($pkg, $filename, $line) = caller;
-
- $exc->{filename} = $filename;
- $exc->{line} = $line;
-
- die $exc;
-}
-
-sub stringify {
- my $self = shift;
-
- my $msg = $self->{code} ? "$self->{code} $self->{msg}" : $self->{msg};
-
- if ($msg !~ m/\n$/) {
-
- if ($self->{filename} && $self->{line}) {
- $msg .= " at $self->{filename} line $self->{line}";
- }
-
- $msg .= "\n";
- }
-
- if ($self->{errors}) {
- foreach my $e (keys %{$self->{errors}}) {
- $msg .= "$e: $self->{errors}->{$e}\n";
- }
- }
-
- if ($self->{propagate}) {
- foreach my $pi (@{$self->{propagate}}) {
- $msg .= "\t...propagated at $pi->[0] line $pi->[1]\n";
- }
- }
-
- if ($self->{usage}) {
- $msg .= $self->{usage};
- $msg .= "\n" if $msg !~ m/\n$/;
- }
-
- return $msg;
-}
-
-sub PROPAGATE {
- my ($self, $file, $line) = @_;
-
- push @{$self->{propagate}}, [$file, $line];
-
- return $self;
-}
-
-1;
+++ /dev/null
-package PVE::JSONSchema;
-
-use strict;
-use warnings;
-use Storable; # for dclone
-use Getopt::Long;
-use Encode::Locale;
-use Encode;
-use Devel::Cycle -quiet; # todo: remove?
-use PVE::Tools qw(split_list $IPV6RE $IPV4RE);
-use PVE::Exception qw(raise);
-use HTTP::Status qw(:constants);
-use Net::IP qw(:PROC);
-use Data::Dumper;
-
-use base 'Exporter';
-
-our @EXPORT_OK = qw(
-register_standard_option
-get_standard_option
-);
-
-# Note: This class implements something similar to JSON schema, but it is not 100% complete.
-# see: http://tools.ietf.org/html/draft-zyp-json-schema-02
-# see: http://json-schema.org/
-
-# the code is similar to the javascript parser from http://code.google.com/p/jsonschema/
-
-my $standard_options = {};
-sub register_standard_option {
- my ($name, $schema) = @_;
-
- die "standard option '$name' already registered\n"
- if $standard_options->{$name};
-
- $standard_options->{$name} = $schema;
-}
-
-sub get_standard_option {
- my ($name, $base) = @_;
-
- my $std = $standard_options->{$name};
- die "no such standard option '$name'\n" if !$std;
-
- my $res = $base || {};
-
- foreach my $opt (keys %$std) {
- next if defined($res->{$opt});
- $res->{$opt} = $std->{$opt};
- }
-
- return $res;
-};
-
-register_standard_option('pve-vmid', {
- description => "The (unique) ID of the VM.",
- type => 'integer', format => 'pve-vmid',
- minimum => 1
-});
-
-register_standard_option('pve-node', {
- description => "The cluster node name.",
- type => 'string', format => 'pve-node',
-});
-
-register_standard_option('pve-node-list', {
- description => "List of cluster node names.",
- type => 'string', format => 'pve-node-list',
-});
-
-register_standard_option('pve-iface', {
- description => "Network interface name.",
- type => 'string', format => 'pve-iface',
- minLength => 2, maxLength => 20,
-});
-
-register_standard_option('pve-storage-id', {
- description => "The storage identifier.",
- type => 'string', format => 'pve-storage-id',
-});
-
-register_standard_option('pve-config-digest', {
- description => 'Prevent changes if current configuration file has different SHA1 digest. This can be used to prevent concurrent modifications.',
- type => 'string',
- optional => 1,
- maxLength => 40, # sha1 hex digest lenght is 40
-});
-
-register_standard_option('skiplock', {
- description => "Ignore locks - only root is allowed to use this option.",
- type => 'boolean',
- optional => 1,
-});
-
-register_standard_option('extra-args', {
- description => "Extra arguments as array",
- type => 'array',
- items => { type => 'string' },
- optional => 1
-});
-
-register_standard_option('fingerprint-sha256', {
- description => "Certificate SHA 256 fingerprint.",
- type => 'string',
- pattern => '([A-Fa-f0-9]{2}:){31}[A-Fa-f0-9]{2}',
-});
-
-my $format_list = {};
-
-sub register_format {
- my ($format, $code) = @_;
-
- die "JSON schema format '$format' already registered\n"
- if $format_list->{$format};
-
- $format_list->{$format} = $code;
-}
-
-sub get_format {
- my ($format) = @_;
- return $format_list->{$format};
-}
-
-# register some common type for pve
-
-register_format('string', sub {}); # allow format => 'string-list'
-
-register_format('urlencoded', \&pve_verify_urlencoded);
-sub pve_verify_urlencoded {
- my ($text, $noerr) = @_;
- if ($text !~ /^[-%a-zA-Z0-9_.!~*'()]*$/) {
- return undef if $noerr;
- die "invalid urlencoded string: $text\n";
- }
- return $text;
-}
-
-register_format('pve-configid', \&pve_verify_configid);
-sub pve_verify_configid {
- my ($id, $noerr) = @_;
-
- if ($id !~ m/^[a-z][a-z0-9_]+$/i) {
- return undef if $noerr;
- die "invalid configuration ID '$id'\n";
- }
- return $id;
-}
-
-PVE::JSONSchema::register_format('pve-storage-id', \&parse_storage_id);
-sub parse_storage_id {
- my ($storeid, $noerr) = @_;
-
- if ($storeid !~ m/^[a-z][a-z0-9\-\_\.]*[a-z0-9]$/i) {
- return undef if $noerr;
- die "storage ID '$storeid' contains illegal characters\n";
- }
- return $storeid;
-}
-
-
-register_format('pve-vmid', \&pve_verify_vmid);
-sub pve_verify_vmid {
- my ($vmid, $noerr) = @_;
-
- if ($vmid !~ m/^[1-9][0-9]{2,8}$/) {
- return undef if $noerr;
- die "value does not look like a valid VM ID\n";
- }
- return $vmid;
-}
-
-register_format('pve-node', \&pve_verify_node_name);
-sub pve_verify_node_name {
- my ($node, $noerr) = @_;
-
- if ($node !~ m/^([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)$/) {
- return undef if $noerr;
- die "value does not look like a valid node name\n";
- }
- return $node;
-}
-
-register_format('ipv4', \&pve_verify_ipv4);
-sub pve_verify_ipv4 {
- my ($ipv4, $noerr) = @_;
-
- if ($ipv4 !~ m/^(?:$IPV4RE)$/) {
- return undef if $noerr;
- die "value does not look like a valid IPv4 address\n";
- }
- return $ipv4;
-}
-
-register_format('ipv6', \&pve_verify_ipv6);
-sub pve_verify_ipv6 {
- my ($ipv6, $noerr) = @_;
-
- if ($ipv6 !~ m/^(?:$IPV6RE)$/) {
- return undef if $noerr;
- die "value does not look like a valid IPv6 address\n";
- }
- return $ipv6;
-}
-
-register_format('ip', \&pve_verify_ip);
-sub pve_verify_ip {
- my ($ip, $noerr) = @_;
-
- if ($ip !~ m/^(?:(?:$IPV4RE)|(?:$IPV6RE))$/) {
- return undef if $noerr;
- die "value does not look like a valid IP address\n";
- }
- return $ip;
-}
-
-my $ipv4_mask_hash = {
- '128.0.0.0' => 1,
- '192.0.0.0' => 2,
- '224.0.0.0' => 3,
- '240.0.0.0' => 4,
- '248.0.0.0' => 5,
- '252.0.0.0' => 6,
- '254.0.0.0' => 7,
- '255.0.0.0' => 8,
- '255.128.0.0' => 9,
- '255.192.0.0' => 10,
- '255.224.0.0' => 11,
- '255.240.0.0' => 12,
- '255.248.0.0' => 13,
- '255.252.0.0' => 14,
- '255.254.0.0' => 15,
- '255.255.0.0' => 16,
- '255.255.128.0' => 17,
- '255.255.192.0' => 18,
- '255.255.224.0' => 19,
- '255.255.240.0' => 20,
- '255.255.248.0' => 21,
- '255.255.252.0' => 22,
- '255.255.254.0' => 23,
- '255.255.255.0' => 24,
- '255.255.255.128' => 25,
- '255.255.255.192' => 26,
- '255.255.255.224' => 27,
- '255.255.255.240' => 28,
- '255.255.255.248' => 29,
- '255.255.255.252' => 30,
- '255.255.255.254' => 31,
- '255.255.255.255' => 32,
-};
-
-register_format('ipv4mask', \&pve_verify_ipv4mask);
-sub pve_verify_ipv4mask {
- my ($mask, $noerr) = @_;
-
- if (!defined($ipv4_mask_hash->{$mask})) {
- return undef if $noerr;
- die "value does not look like a valid IP netmask\n";
- }
- return $mask;
-}
-
-register_format('CIDRv6', \&pve_verify_cidrv6);
-sub pve_verify_cidrv6 {
- my ($cidr, $noerr) = @_;
-
- if ($cidr =~ m!^(?:$IPV6RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 128)) {
- return $cidr;
- }
-
- return undef if $noerr;
- die "value does not look like a valid IPv6 CIDR network\n";
-}
-
-register_format('CIDRv4', \&pve_verify_cidrv4);
-sub pve_verify_cidrv4 {
- my ($cidr, $noerr) = @_;
-
- if ($cidr =~ m!^(?:$IPV4RE)(?:/(\d+))$! && ($1 > 7) && ($1 <= 32)) {
- return $cidr;
- }
-
- return undef if $noerr;
- die "value does not look like a valid IPv4 CIDR network\n";
-}
-
-register_format('CIDR', \&pve_verify_cidr);
-sub pve_verify_cidr {
- my ($cidr, $noerr) = @_;
-
- if (!(pve_verify_cidrv4($cidr, 1) ||
- pve_verify_cidrv6($cidr, 1)))
- {
- return undef if $noerr;
- die "value does not look like a valid CIDR network\n";
- }
-
- return $cidr;
-}
-
-register_format('pve-ipv4-config', \&pve_verify_ipv4_config);
-sub pve_verify_ipv4_config {
- my ($config, $noerr) = @_;
-
- return $config if $config =~ /^(?:dhcp|manual)$/ ||
- pve_verify_cidrv4($config, 1);
- return undef if $noerr;
- die "value does not look like a valid ipv4 network configuration\n";
-}
-
-register_format('pve-ipv6-config', \&pve_verify_ipv6_config);
-sub pve_verify_ipv6_config {
- my ($config, $noerr) = @_;
-
- return $config if $config =~ /^(?:auto|dhcp|manual)$/ ||
- pve_verify_cidrv6($config, 1);
- return undef if $noerr;
- die "value does not look like a valid ipv6 network configuration\n";
-}
-
-register_format('email', \&pve_verify_email);
-sub pve_verify_email {
- my ($email, $noerr) = @_;
-
- # we use same regex as in Utils.js
- if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,63}$/) {
- return undef if $noerr;
- die "value does not look like a valid email address\n";
- }
- return $email;
-}
-
-register_format('dns-name', \&pve_verify_dns_name);
-sub pve_verify_dns_name {
- my ($name, $noerr) = @_;
-
- my $namere = "([a-zA-Z0-9]([a-zA-Z0-9\-]*[a-zA-Z0-9])?)";
-
- if ($name !~ /^(${namere}\.)*${namere}$/) {
- return undef if $noerr;
- die "value does not look like a valid DNS name\n";
- }
- return $name;
-}
-
-# network interface name
-register_format('pve-iface', \&pve_verify_iface);
-sub pve_verify_iface {
- my ($id, $noerr) = @_;
-
- if ($id !~ m/^[a-z][a-z0-9_]{1,20}([:\.]\d+)?$/i) {
- return undef if $noerr;
- die "invalid network interface name '$id'\n";
- }
- return $id;
-}
-
-# general addresses by name or IP
-register_format('address', \&pve_verify_address);
-sub pve_verify_address {
- my ($addr, $noerr) = @_;
-
- if (!(pve_verify_ip($addr, 1) ||
- pve_verify_dns_name($addr, 1)))
- {
- return undef if $noerr;
- die "value does not look like a valid address: $addr\n";
- }
- return $addr;
-}
-
-register_format('disk-size', \&pve_verify_disk_size);
-sub pve_verify_disk_size {
- my ($size, $noerr) = @_;
- if (!defined(parse_size($size))) {
- return undef if $noerr;
- die "value does not look like a valid disk size: $size\n";
- }
- return $size;
-}
-
-register_standard_option('spice-proxy', {
- description => "SPICE proxy server. This can be used by the client to specify the proxy server. All nodes in a cluster runs 'spiceproxy', so it is up to the client to choose one. By default, we return the node where the VM is currently running. As resonable setting is to use same node you use to connect to the API (This is window.location.hostname for the JS GUI).",
- type => 'string', format => 'address',
-});
-
-register_standard_option('remote-viewer-config', {
- description => "Returned values can be directly passed to the 'remote-viewer' application.",
- additionalProperties => 1,
- properties => {
- type => { type => 'string' },
- password => { type => 'string' },
- proxy => { type => 'string' },
- host => { type => 'string' },
- 'tls-port' => { type => 'integer' },
- },
-});
-
-register_format('pve-startup-order', \&pve_verify_startup_order);
-sub pve_verify_startup_order {
- my ($value, $noerr) = @_;
-
- return $value if pve_parse_startup_order($value);
-
- return undef if $noerr;
-
- die "unable to parse startup options\n";
-}
-
-my %bwlimit_opt = (
- optional => 1,
- type => 'number', minimum => '0',
- format_description => 'LIMIT',
-);
-
-my $bwlimit_format = {
- default => {
- %bwlimit_opt,
- description => 'default bandwidth limit in MiB/s',
- },
- restore => {
- %bwlimit_opt,
- description => 'bandwidth limit in MiB/s for restoring guests from backups',
- },
- migration => {
- %bwlimit_opt,
- description => 'bandwidth limit in MiB/s for migrating guests',
- },
- clone => {
- %bwlimit_opt,
- description => 'bandwidth limit in MiB/s for cloning disks',
- },
- move => {
- %bwlimit_opt,
- description => 'bandwidth limit in MiB/s for moving disks',
- },
-};
-register_format('bwlimit', $bwlimit_format);
-register_standard_option('bwlimit', {
- description => "Set bandwidth/io limits various operations.",
- optional => 1,
- type => 'string',
- format => $bwlimit_format,
-});
-
-sub pve_parse_startup_order {
- my ($value) = @_;
-
- return undef if !$value;
-
- my $res = {};
-
- foreach my $p (split(/,/, $value)) {
- next if $p =~ m/^\s*$/;
-
- if ($p =~ m/^(order=)?(\d+)$/) {
- $res->{order} = $2;
- } elsif ($p =~ m/^up=(\d+)$/) {
- $res->{up} = $1;
- } elsif ($p =~ m/^down=(\d+)$/) {
- $res->{down} = $1;
- } else {
- return undef;
- }
- }
-
- return $res;
-}
-
-PVE::JSONSchema::register_standard_option('pve-startup-order', {
- description => "Startup and shutdown behavior. Order is a non-negative number defining the general startup order. Shutdown in done with reverse ordering. Additionally you can set the 'up' or 'down' delay in seconds, which specifies a delay to wait before the next VM is started or stopped.",
- optional => 1,
- type => 'string', format => 'pve-startup-order',
- typetext => '[[order=]\d+] [,up=\d+] [,down=\d+] ',
-});
-
-sub check_format {
- my ($format, $value, $path) = @_;
-
- return parse_property_string($format, $value, $path) if ref($format) eq 'HASH';
- return if $format eq 'regex';
-
- if ($format =~ m/^(.*)-a?list$/) {
-
- my $code = $format_list->{$1};
-
- die "undefined format '$format'\n" if !$code;
-
- # Note: we allow empty lists
- foreach my $v (split_list($value)) {
- &$code($v);
- }
-
- } elsif ($format =~ m/^(.*)-opt$/) {
-
- my $code = $format_list->{$1};
-
- die "undefined format '$format'\n" if !$code;
-
- return if !$value; # allow empty string
-
- &$code($value);
-
- } else {
-
- my $code = $format_list->{$format};
-
- die "undefined format '$format'\n" if !$code;
-
- return parse_property_string($code, $value, $path) if ref($code) eq 'HASH';
- &$code($value);
- }
-}
-
-sub parse_size {
- my ($value) = @_;
-
- return undef if $value !~ m/^(\d+(\.\d+)?)([KMGT])?$/;
- my ($size, $unit) = ($1, $3);
- if ($unit) {
- if ($unit eq 'K') {
- $size = $size * 1024;
- } elsif ($unit eq 'M') {
- $size = $size * 1024 * 1024;
- } elsif ($unit eq 'G') {
- $size = $size * 1024 * 1024 * 1024;
- } elsif ($unit eq 'T') {
- $size = $size * 1024 * 1024 * 1024 * 1024;
- }
- }
- return int($size);
-};
-
-sub format_size {
- my ($size) = @_;
-
- $size = int($size);
-
- my $kb = int($size/1024);
- return $size if $kb*1024 != $size;
-
- my $mb = int($kb/1024);
- return "${kb}K" if $mb*1024 != $kb;
-
- my $gb = int($mb/1024);
- return "${mb}M" if $gb*1024 != $mb;
-
- my $tb = int($gb/1024);
- return "${gb}G" if $tb*1024 != $gb;
-
- return "${tb}T";
-};
-
-sub parse_boolean {
- my ($bool) = @_;
- return 1 if $bool =~ m/^(1|on|yes|true)$/i;
- return 0 if $bool =~ m/^(0|off|no|false)$/i;
- return undef;
-}
-
-sub parse_property_string {
- my ($format, $data, $path, $additional_properties) = @_;
-
- # In property strings we default to not allowing additional properties
- $additional_properties = 0 if !defined($additional_properties);
-
- # Support named formats here, too:
- if (!ref($format)) {
- if (my $desc = $format_list->{$format}) {
- $format = $desc;
- } else {
- die "unknown format: $format\n";
- }
- } elsif (ref($format) ne 'HASH') {
- die "unexpected format value of type ".ref($format)."\n";
- }
-
- my $default_key;
-
- my $res = {};
- foreach my $part (split(/,/, $data)) {
- next if $part =~ /^\s*$/;
-
- if ($part =~ /^([^=]+)=(.+)$/) {
- my ($k, $v) = ($1, $2);
- die "duplicate key in comma-separated list property: $k\n" if defined($res->{$k});
- my $schema = $format->{$k};
- if (my $alias = $schema->{alias}) {
- if (my $key_alias = $schema->{keyAlias}) {
- die "key alias '$key_alias' is already defined\n" if defined($res->{$key_alias});
- $res->{$key_alias} = $k;
- }
- $k = $alias;
- $schema = $format->{$k};
- }
-
- die "invalid key in comma-separated list property: $k\n" if !$schema;
- if ($schema->{type} && $schema->{type} eq 'boolean') {
- $v = parse_boolean($v) // $v;
- }
- $res->{$k} = $v;
- } elsif ($part !~ /=/) {
- die "duplicate key in comma-separated list property: $default_key\n" if $default_key;
- foreach my $key (keys %$format) {
- if ($format->{$key}->{default_key}) {
- $default_key = $key;
- if (!$res->{$default_key}) {
- $res->{$default_key} = $part;
- last;
- }
- die "duplicate key in comma-separated list property: $default_key\n";
- }
- }
- die "value without key, but schema does not define a default key\n" if !$default_key;
- } else {
- die "missing key in comma-separated list property\n";
- }
- }
-
- my $errors = {};
- check_object($path, $format, $res, $additional_properties, $errors);
- if (scalar(%$errors)) {
- raise "format error\n", errors => $errors;
- }
-
- return $res;
-}
-
-sub add_error {
- my ($errors, $path, $msg) = @_;
-
- $path = '_root' if !$path;
-
- if ($errors->{$path}) {
- $errors->{$path} = join ('\n', $errors->{$path}, $msg);
- } else {
- $errors->{$path} = $msg;
- }
-}
-
-sub is_number {
- my $value = shift;
-
- # see 'man perlretut'
- return $value =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
-}
-
-sub is_integer {
- my $value = shift;
-
- return $value =~ m/^[+-]?\d+$/;
-}
-
-sub check_type {
- my ($path, $type, $value, $errors) = @_;
-
- return 1 if !$type;
-
- if (!defined($value)) {
- return 1 if $type eq 'null';
- die "internal error"
- }
-
- if (my $tt = ref($type)) {
- if ($tt eq 'ARRAY') {
- foreach my $t (@$type) {
- my $tmperr = {};
- check_type($path, $t, $value, $tmperr);
- return 1 if !scalar(%$tmperr);
- }
- my $ttext = join ('|', @$type);
- add_error($errors, $path, "type check ('$ttext') failed");
- return undef;
- } elsif ($tt eq 'HASH') {
- my $tmperr = {};
- check_prop($value, $type, $path, $tmperr);
- return 1 if !scalar(%$tmperr);
- add_error($errors, $path, "type check failed");
- return undef;
- } else {
- die "internal error - got reference type '$tt'";
- }
-
- } else {
-
- return 1 if $type eq 'any';
-
- if ($type eq 'null') {
- if (defined($value)) {
- add_error($errors, $path, "type check ('$type') failed - value is not null");
- return undef;
- }
- return 1;
- }
-
- my $vt = ref($value);
-
- if ($type eq 'array') {
- if (!$vt || $vt ne 'ARRAY') {
- add_error($errors, $path, "type check ('$type') failed");
- return undef;
- }
- return 1;
- } elsif ($type eq 'object') {
- if (!$vt || $vt ne 'HASH') {
- add_error($errors, $path, "type check ('$type') failed");
- return undef;
- }
- return 1;
- } elsif ($type eq 'coderef') {
- if (!$vt || $vt ne 'CODE') {
- add_error($errors, $path, "type check ('$type') failed");
- return undef;
- }
- return 1;
- } elsif ($type eq 'string' && $vt eq 'Regexp') {
- # qr// regexes can be used as strings and make sense for format=regex
- return 1;
- } else {
- if ($vt) {
- add_error($errors, $path, "type check ('$type') failed - got $vt");
- return undef;
- } else {
- if ($type eq 'string') {
- return 1; # nothing to check ?
- } elsif ($type eq 'boolean') {
- #if ($value =~ m/^(1|true|yes|on)$/i) {
- if ($value eq '1') {
- return 1;
- #} elsif ($value =~ m/^(0|false|no|off)$/i) {
- } elsif ($value eq '0') {
- return 1; # return success (not value)
- } else {
- add_error($errors, $path, "type check ('$type') failed - got '$value'");
- return undef;
- }
- } elsif ($type eq 'integer') {
- if (!is_integer($value)) {
- add_error($errors, $path, "type check ('$type') failed - got '$value'");
- return undef;
- }
- return 1;
- } elsif ($type eq 'number') {
- if (!is_number($value)) {
- add_error($errors, $path, "type check ('$type') failed - got '$value'");
- return undef;
- }
- return 1;
- } else {
- return 1; # no need to verify unknown types
- }
- }
- }
- }
-
- return undef;
-}
-
-sub check_object {
- my ($path, $schema, $value, $additional_properties, $errors) = @_;
-
- # print "Check Object " . Dumper($value) . "\nSchema: " . Dumper($schema);
-
- my $st = ref($schema);
- if (!$st || $st ne 'HASH') {
- add_error($errors, $path, "Invalid schema definition.");
- return;
- }
-
- my $vt = ref($value);
- if (!$vt || $vt ne 'HASH') {
- add_error($errors, $path, "an object is required");
- return;
- }
-
- foreach my $k (keys %$schema) {
- check_prop($value->{$k}, $schema->{$k}, $path ? "$path.$k" : $k, $errors);
- }
-
- foreach my $k (keys %$value) {
-
- my $newpath = $path ? "$path.$k" : $k;
-
- if (my $subschema = $schema->{$k}) {
- if (my $requires = $subschema->{requires}) {
- if (ref($requires)) {
- #print "TEST: " . Dumper($value) . "\n", Dumper($requires) ;
- check_prop($value, $requires, $path, $errors);
- } elsif (!defined($value->{$requires})) {
- add_error($errors, $path ? "$path.$requires" : $requires,
- "missing property - '$newpath' requires this property");
- }
- }
-
- next; # value is already checked above
- }
-
- if (defined ($additional_properties) && !$additional_properties) {
- add_error($errors, $newpath, "property is not defined in schema " .
- "and the schema does not allow additional properties");
- next;
- }
- check_prop($value->{$k}, $additional_properties, $newpath, $errors)
- if ref($additional_properties);
- }
-}
-
-sub check_object_warn {
- my ($path, $schema, $value, $additional_properties) = @_;
- my $errors = {};
- check_object($path, $schema, $value, $additional_properties, $errors);
- if (scalar(%$errors)) {
- foreach my $k (keys %$errors) {
- warn "parse error: $k: $errors->{$k}\n";
- }
- return 0;
- }
- return 1;
-}
-
-sub check_prop {
- my ($value, $schema, $path, $errors) = @_;
-
- die "internal error - no schema" if !$schema;
- die "internal error" if !$errors;
-
- #print "check_prop $path\n" if $value;
-
- my $st = ref($schema);
- if (!$st || $st ne 'HASH') {
- add_error($errors, $path, "Invalid schema definition.");
- return;
- }
-
- # if it extends another schema, it must pass that schema as well
- if($schema->{extends}) {
- check_prop($value, $schema->{extends}, $path, $errors);
- }
-
- if (!defined ($value)) {
- return if $schema->{type} && $schema->{type} eq 'null';
- if (!$schema->{optional} && !$schema->{alias} && !$schema->{group}) {
- add_error($errors, $path, "property is missing and it is not optional");
- }
- return;
- }
-
- return if !check_type($path, $schema->{type}, $value, $errors);
-
- if ($schema->{disallow}) {
- my $tmperr = {};
- if (check_type($path, $schema->{disallow}, $value, $tmperr)) {
- add_error($errors, $path, "disallowed value was matched");
- return;
- }
- }
-
- if (my $vt = ref($value)) {
-
- if ($vt eq 'ARRAY') {
- if ($schema->{items}) {
- my $it = ref($schema->{items});
- if ($it && $it eq 'ARRAY') {
- #die "implement me $path: $vt " . Dumper($schema) ."\n". Dumper($value);
- die "not implemented";
- } else {
- my $ind = 0;
- foreach my $el (@$value) {
- check_prop($el, $schema->{items}, "${path}[$ind]", $errors);
- $ind++;
- }
- }
- }
- return;
- } elsif ($schema->{properties} || $schema->{additionalProperties}) {
- check_object($path, defined($schema->{properties}) ? $schema->{properties} : {},
- $value, $schema->{additionalProperties}, $errors);
- return;
- }
-
- } else {
-
- if (my $format = $schema->{format}) {
- eval { check_format($format, $value, $path); };
- if ($@) {
- add_error($errors, $path, "invalid format - $@");
- return;
- }
- }
-
- if (my $pattern = $schema->{pattern}) {
- if ($value !~ m/^$pattern$/) {
- add_error($errors, $path, "value does not match the regex pattern");
- return;
- }
- }
-
- if (defined (my $max = $schema->{maxLength})) {
- if (length($value) > $max) {
- add_error($errors, $path, "value may only be $max characters long");
- return;
- }
- }
-
- if (defined (my $min = $schema->{minLength})) {
- if (length($value) < $min) {
- add_error($errors, $path, "value must be at least $min characters long");
- return;
- }
- }
-
- if (is_number($value)) {
- if (defined (my $max = $schema->{maximum})) {
- if ($value > $max) {
- add_error($errors, $path, "value must have a maximum value of $max");
- return;
- }
- }
-
- if (defined (my $min = $schema->{minimum})) {
- if ($value < $min) {
- add_error($errors, $path, "value must have a minimum value of $min");
- return;
- }
- }
- }
-
- if (my $ea = $schema->{enum}) {
-
- my $found;
- foreach my $ev (@$ea) {
- if ($ev eq $value) {
- $found = 1;
- last;
- }
- }
- if (!$found) {
- add_error($errors, $path, "value '$value' does not have a value in the enumeration '" .
- join(", ", @$ea) . "'");
- }
- }
- }
-}
-
-sub validate {
- my ($instance, $schema, $errmsg) = @_;
-
- my $errors = {};
- $errmsg = "Parameter verification failed.\n" if !$errmsg;
-
- # todo: cycle detection is only needed for debugging, I guess
- # we can disable that in the final release
- # todo: is there a better/faster way to detect cycles?
- my $cycles = 0;
- find_cycle($instance, sub { $cycles = 1 });
- if ($cycles) {
- add_error($errors, undef, "data structure contains recursive cycles");
- } elsif ($schema) {
- check_prop($instance, $schema, '', $errors);
- }
-
- if (scalar(%$errors)) {
- raise $errmsg, code => HTTP_BAD_REQUEST, errors => $errors;
- }
-
- return 1;
-}
-
-my $schema_valid_types = ["string", "object", "coderef", "array", "boolean", "number", "integer", "null", "any"];
-my $default_schema_noref = {
- description => "This is the JSON Schema for JSON Schemas.",
- type => [ "object" ],
- additionalProperties => 0,
- properties => {
- type => {
- type => ["string", "array"],
- description => "This is a type definition value. This can be a simple type, or a union type",
- optional => 1,
- default => "any",
- items => {
- type => "string",
- enum => $schema_valid_types,
- },
- enum => $schema_valid_types,
- },
- optional => {
- type => "boolean",
- description => "This indicates that the instance property in the instance object is not required.",
- optional => 1,
- default => 0
- },
- properties => {
- type => "object",
- description => "This is a definition for the properties of an object value",
- optional => 1,
- default => {},
- },
- items => {
- type => "object",
- description => "When the value is an array, this indicates the schema to use to validate each item in an array",
- optional => 1,
- default => {},
- },
- additionalProperties => {
- type => [ "boolean", "object"],
- description => "This provides a default property definition for all properties that are not explicitly defined in an object type definition.",
- optional => 1,
- default => {},
- },
- minimum => {
- type => "number",
- optional => 1,
- description => "This indicates the minimum value for the instance property when the type of the instance value is a number.",
- },
- maximum => {
- type => "number",
- optional => 1,
- description => "This indicates the maximum value for the instance property when the type of the instance value is a number.",
- },
- minLength => {
- type => "integer",
- description => "When the instance value is a string, this indicates minimum length of the string",
- optional => 1,
- minimum => 0,
- default => 0,
- },
- maxLength => {
- type => "integer",
- description => "When the instance value is a string, this indicates maximum length of the string.",
- optional => 1,
- },
- typetext => {
- type => "string",
- optional => 1,
- description => "A text representation of the type (used to generate documentation).",
- },
- pattern => {
- type => "string",
- format => "regex",
- description => "When the instance value is a string, this provides a regular expression that a instance string value should match in order to be valid.",
- optional => 1,
- default => ".*",
- },
- enum => {
- type => "array",
- optional => 1,
- description => "This provides an enumeration of possible values that are valid for the instance property.",
- },
- description => {
- type => "string",
- optional => 1,
- description => "This provides a description of the purpose the instance property. The value can be a string or it can be an object with properties corresponding to various different instance languages (with an optional default property indicating the default description).",
- },
- verbose_description => {
- type => "string",
- optional => 1,
- description => "This provides a more verbose description.",
- },
- format_description => {
- type => "string",
- optional => 1,
- description => "This provides a shorter (usually just one word) description for a property used to generate descriptions for comma separated list property strings.",
- },
- title => {
- type => "string",
- optional => 1,
- description => "This provides the title of the property",
- },
- requires => {
- type => [ "string", "object" ],
- optional => 1,
- description => "indicates a required property or a schema that must be validated if this property is present",
- },
- format => {
- type => [ "string", "object" ],
- optional => 1,
- description => "This indicates what format the data is among some predefined formats which may include:\n\ndate - a string following the ISO format \naddress \nschema - a schema definition object \nperson \npage \nhtml - a string representing HTML",
- },
- default_key => {
- type => "boolean",
- optional => 1,
- description => "Whether this is the default key in a comma separated list property string.",
- },
- alias => {
- type => 'string',
- optional => 1,
- description => "When a key represents the same property as another it can be an alias to it, causing the parsed datastructure to use the other key to store the current value under.",
- },
- keyAlias => {
- type => 'string',
- optional => 1,
- description => "Allows to store the current 'key' as value of another property. Only valid if used together with 'alias'.",
- requires => 'alias',
- },
- default => {
- type => "any",
- optional => 1,
- description => "This indicates the default for the instance property."
- },
- completion => {
- type => 'coderef',
- description => "Bash completion function. This function should return a list of possible values.",
- optional => 1,
- },
- disallow => {
- type => "object",
- optional => 1,
- description => "This attribute may take the same values as the \"type\" attribute, however if the instance matches the type or if this value is an array and the instance matches any type or schema in the array, then this instance is not valid.",
- },
- extends => {
- type => "object",
- optional => 1,
- description => "This indicates the schema extends the given schema. All instances of this schema must be valid to by the extended schema also.",
- default => {},
- },
- # this is from hyper schema
- links => {
- type => "array",
- description => "This defines the link relations of the instance objects",
- optional => 1,
- items => {
- type => "object",
- properties => {
- href => {
- type => "string",
- description => "This defines the target URL for the relation and can be parameterized using {propertyName} notation. It should be resolved as a URI-reference relative to the URI that was used to retrieve the instance document",
- },
- rel => {
- type => "string",
- description => "This is the name of the link relation",
- optional => 1,
- default => "full",
- },
- method => {
- type => "string",
- description => "For submission links, this defines the method that should be used to access the target resource",
- optional => 1,
- default => "GET",
- },
- },
- },
- },
- }
-};
-
-my $default_schema = Storable::dclone($default_schema_noref);
-
-$default_schema->{properties}->{properties}->{additionalProperties} = $default_schema;
-$default_schema->{properties}->{additionalProperties}->{properties} = $default_schema->{properties};
-
-$default_schema->{properties}->{items}->{properties} = $default_schema->{properties};
-$default_schema->{properties}->{items}->{additionalProperties} = 0;
-
-$default_schema->{properties}->{disallow}->{properties} = $default_schema->{properties};
-$default_schema->{properties}->{disallow}->{additionalProperties} = 0;
-
-$default_schema->{properties}->{requires}->{properties} = $default_schema->{properties};
-$default_schema->{properties}->{requires}->{additionalProperties} = 0;
-
-$default_schema->{properties}->{extends}->{properties} = $default_schema->{properties};
-$default_schema->{properties}->{extends}->{additionalProperties} = 0;
-
-my $method_schema = {
- type => "object",
- additionalProperties => 0,
- properties => {
- description => {
- description => "This a description of the method",
- optional => 1,
- },
- name => {
- type => 'string',
- description => "This indicates the name of the function to call.",
- optional => 1,
- requires => {
- additionalProperties => 1,
- properties => {
- name => {},
- description => {},
- code => {},
- method => {},
- parameters => {},
- path => {},
- parameters => {},
- returns => {},
- }
- },
- },
- method => {
- type => 'string',
- description => "The HTTP method name.",
- enum => [ 'GET', 'POST', 'PUT', 'DELETE' ],
- optional => 1,
- },
- protected => {
- type => 'boolean',
- description => "Method needs special privileges - only pvedaemon can execute it",
- optional => 1,
- },
- download => {
- type => 'boolean',
- description => "Method downloads the file content (filename is the return value of the method).",
- optional => 1,
- },
- proxyto => {
- type => 'string',
- description => "A parameter name. If specified, all calls to this method are proxied to the host contained in that parameter.",
- optional => 1,
- },
- proxyto_callback => {
- type => 'coderef',
- description => "A function which is called to resolve the proxyto attribute. The default implementaion returns the value of the 'proxyto' parameter.",
- optional => 1,
- },
- permissions => {
- type => 'object',
- description => "Required access permissions. By default only 'root' is allowed to access this method.",
- optional => 1,
- additionalProperties => 0,
- properties => {
- description => {
- description => "Describe access permissions.",
- optional => 1,
- },
- user => {
- description => "A simply way to allow access for 'all' authenticated users. Value 'world' is used to allow access without credentials.",
- type => 'string',
- enum => ['all', 'world'],
- optional => 1,
- },
- check => {
- description => "Array of permission checks (prefix notation).",
- type => 'array',
- optional => 1
- },
- },
- },
- match_name => {
- description => "Used internally",
- optional => 1,
- },
- match_re => {
- description => "Used internally",
- optional => 1,
- },
- path => {
- type => 'string',
- description => "path for URL matching (uri template)",
- },
- fragmentDelimiter => {
- type => 'string',
- description => "A ways to override the default fragment delimiter '/'. This onyl works on a whole sub-class. You can set this to the empty string to match the whole rest of the URI.",
- optional => 1,
- },
- parameters => {
- type => 'object',
- description => "JSON Schema for parameters.",
- optional => 1,
- },
- returns => {
- type => 'object',
- description => "JSON Schema for return value.",
- optional => 1,
- },
- code => {
- type => 'coderef',
- description => "method implementaion (code reference)",
- optional => 1,
- },
- subclass => {
- type => 'string',
- description => "Delegate call to this class (perl class string).",
- optional => 1,
- requires => {
- additionalProperties => 0,
- properties => {
- subclass => {},
- path => {},
- match_name => {},
- match_re => {},
- fragmentDelimiter => { optional => 1 }
- }
- },
- },
- },
-
-};
-
-sub validate_schema {
- my ($schema) = @_;
-
- my $errmsg = "internal error - unable to verify schema\n";
- validate($schema, $default_schema, $errmsg);
-}
-
-sub validate_method_info {
- my $info = shift;
-
- my $errmsg = "internal error - unable to verify method info\n";
- validate($info, $method_schema, $errmsg);
-
- validate_schema($info->{parameters}) if $info->{parameters};
- validate_schema($info->{returns}) if $info->{returns};
-}
-
-# run a self test on load
-# make sure we can verify the default schema
-validate_schema($default_schema_noref);
-validate_schema($method_schema);
-
-# and now some utility methods (used by pve api)
-sub method_get_child_link {
- my ($info) = @_;
-
- return undef if !$info;
-
- my $schema = $info->{returns};
- return undef if !$schema || !$schema->{type} || $schema->{type} ne 'array';
-
- my $links = $schema->{links};
- return undef if !$links;
-
- my $found;
- foreach my $lnk (@$links) {
- if ($lnk->{href} && $lnk->{rel} && ($lnk->{rel} eq 'child')) {
- $found = $lnk;
- last;
- }
- }
-
- return $found;
-}
-
-# a way to parse command line parameters, using a
-# schema to configure Getopt::Long
-sub get_options {
- my ($schema, $args, $arg_param, $fixed_param, $pwcallback, $param_mapping_hash) = @_;
-
- if (!$schema || !$schema->{properties}) {
- raise("too many arguments\n", code => HTTP_BAD_REQUEST)
- if scalar(@$args) != 0;
- return {};
- }
-
- my $list_param;
- if ($arg_param && !ref($arg_param)) {
- my $pd = $schema->{properties}->{$arg_param};
- die "expected list format $pd->{format}"
- if !($pd && $pd->{format} && $pd->{format} =~ m/-list/);
- $list_param = $arg_param;
- }
-
- my @interactive = ();
- my @getopt = ();
- foreach my $prop (keys %{$schema->{properties}}) {
- my $pd = $schema->{properties}->{$prop};
- next if $list_param && $prop eq $list_param;
- next if defined($fixed_param->{$prop});
-
- my $mapping = $param_mapping_hash->{$prop};
- if ($mapping && $mapping->{interactive}) {
- # interactive parameters such as passwords: make the argument
- # optional and call the mapping function afterwards.
- push @getopt, "$prop:s";
- push @interactive, [$prop, $mapping->{func}];
- } elsif ($prop eq 'password' && $pwcallback) {
- # we do not accept plain password on input line, instead
- # we turn this into a boolean option and ask for password below
- # using $pwcallback() (for security reasons).
- push @getopt, "$prop";
- } elsif ($pd->{type} eq 'boolean') {
- push @getopt, "$prop:s";
- } else {
- if ($pd->{format} && $pd->{format} =~ m/-a?list/) {
- push @getopt, "$prop=s@";
- } else {
- push @getopt, "$prop=s";
- }
- }
- }
-
- Getopt::Long::Configure('prefix_pattern=(--|-)');
-
- my $opts = {};
- raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
- if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
-
- if (@$args) {
- if ($list_param) {
- $opts->{$list_param} = $args;
- $args = [];
- } elsif (ref($arg_param)) {
- foreach my $arg_name (@$arg_param) {
- if ($opts->{'extra-args'}) {
- raise("internal error: extra-args must be the last argument\n", code => HTTP_BAD_REQUEST);
- }
- if ($arg_name eq 'extra-args') {
- $opts->{'extra-args'} = $args;
- $args = [];
- next;
- }
- raise("not enough arguments\n", code => HTTP_BAD_REQUEST) if !@$args;
- $opts->{$arg_name} = shift @$args;
- }
- raise("too many arguments\n", code => HTTP_BAD_REQUEST) if @$args;
- } else {
- raise("too many arguments\n", code => HTTP_BAD_REQUEST)
- if scalar(@$args) != 0;
- }
- } else {
- if (ref($arg_param)) {
- foreach my $arg_name (@$arg_param) {
- if ($arg_name eq 'extra-args') {
- $opts->{'extra-args'} = [];
- } else {
- raise("not enough arguments\n", code => HTTP_BAD_REQUEST);
- }
- }
- }
- }
-
- if (my $pd = $schema->{properties}->{password}) {
- if ($pd->{type} ne 'boolean' && $pwcallback) {
- if ($opts->{password} || !$pd->{optional}) {
- $opts->{password} = &$pwcallback();
- }
- }
- }
-
- foreach my $entry (@interactive) {
- my ($opt, $func) = @$entry;
- my $pd = $schema->{properties}->{$opt};
- my $value = $opts->{$opt};
- if (defined($value) || !$pd->{optional}) {
- $opts->{$opt} = $func->($value);
- }
- }
-
- # decode after Getopt as we are not sure how well it handles unicode
- foreach my $p (keys %$opts) {
- if (!ref($opts->{$p})) {
- $opts->{$p} = decode('locale', $opts->{$p});
- } elsif (ref($opts->{$p}) eq 'ARRAY') {
- my $tmp = [];
- foreach my $v (@{$opts->{$p}}) {
- push @$tmp, decode('locale', $v);
- }
- $opts->{$p} = $tmp;
- } elsif (ref($opts->{$p}) eq 'SCALAR') {
- $opts->{$p} = decode('locale', $$opts->{$p});
- } else {
- raise("decoding options failed, unknown reference\n", code => HTTP_BAD_REQUEST);
- }
- }
-
- foreach my $p (keys %$opts) {
- if (my $pd = $schema->{properties}->{$p}) {
- if ($pd->{type} eq 'boolean') {
- if ($opts->{$p} eq '') {
- $opts->{$p} = 1;
- } elsif (defined(my $bool = parse_boolean($opts->{$p}))) {
- $opts->{$p} = $bool;
- } else {
- raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
- }
- } elsif ($pd->{format}) {
-
- if ($pd->{format} =~ m/-list/) {
- # allow --vmid 100 --vmid 101 and --vmid 100,101
- # allow --dow mon --dow fri and --dow mon,fri
- $opts->{$p} = join(",", @{$opts->{$p}}) if ref($opts->{$p}) eq 'ARRAY';
- } elsif ($pd->{format} =~ m/-alist/) {
- # we encode array as \0 separated strings
- # Note: CGI.pm also use this encoding
- if (scalar(@{$opts->{$p}}) != 1) {
- $opts->{$p} = join("\0", @{$opts->{$p}});
- } else {
- # st that split_list knows it is \0 terminated
- my $v = $opts->{$p}->[0];
- $opts->{$p} = "$v\0";
- }
- }
- }
- }
- }
-
- foreach my $p (keys %$fixed_param) {
- $opts->{$p} = $fixed_param->{$p};
- }
-
- return $opts;
-}
-
-# A way to parse configuration data by giving a json schema
-sub parse_config {
- my ($schema, $filename, $raw) = @_;
-
- # do fast check (avoid validate_schema($schema))
- die "got strange schema" if !$schema->{type} ||
- !$schema->{properties} || $schema->{type} ne 'object';
-
- my $cfg = {};
-
- while ($raw =~ /^\s*(.+?)\s*$/gm) {
- my $line = $1;
-
- next if $line =~ /^#/;
-
- if ($line =~ m/^(\S+?):\s*(.*)$/) {
- my $key = $1;
- my $value = $2;
- if ($schema->{properties}->{$key} &&
- $schema->{properties}->{$key}->{type} eq 'boolean') {
-
- $value = parse_boolean($value) // $value;
- }
- $cfg->{$key} = $value;
- } else {
- warn "ignore config line: $line\n"
- }
- }
-
- my $errors = {};
- check_prop($cfg, $schema, '', $errors);
-
- foreach my $k (keys %$errors) {
- warn "parse error in '$filename' - '$k': $errors->{$k}\n";
- delete $cfg->{$k};
- }
-
- return $cfg;
-}
-
-# generate simple key/value file
-sub dump_config {
- my ($schema, $filename, $cfg) = @_;
-
- # do fast check (avoid validate_schema($schema))
- die "got strange schema" if !$schema->{type} ||
- !$schema->{properties} || $schema->{type} ne 'object';
-
- validate($cfg, $schema, "validation error in '$filename'\n");
-
- my $data = '';
-
- foreach my $k (keys %$cfg) {
- $data .= "$k: $cfg->{$k}\n";
- }
-
- return $data;
-}
-
-# helpers used to generate our manual pages
-
-my $find_schema_default_key = sub {
- my ($format) = @_;
-
- my $default_key;
- my $keyAliasProps = {};
-
- foreach my $key (keys %$format) {
- my $phash = $format->{$key};
- if ($phash->{default_key}) {
- die "multiple default keys in schema ($default_key, $key)\n"
- if defined($default_key);
- die "default key '$key' is an alias - this is not allowed\n"
- if defined($phash->{alias});
- die "default key '$key' with keyAlias attribute is not allowed\n"
- if $phash->{keyAlias};
- $default_key = $key;
- }
- my $key_alias = $phash->{keyAlias};
- die "found keyAlias without 'alias definition for '$key'\n"
- if $key_alias && !$phash->{alias};
-
- if ($phash->{alias} && $key_alias) {
- die "inconsistent keyAlias '$key_alias' definition"
- if defined($keyAliasProps->{$key_alias}) &&
- $keyAliasProps->{$key_alias} ne $phash->{alias};
- $keyAliasProps->{$key_alias} = $phash->{alias};
- }
- }
-
- return wantarray ? ($default_key, $keyAliasProps) : $default_key;
-};
-
-sub generate_typetext {
- my ($format, $list_enums) = @_;
-
- my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
-
- my $res = '';
- my $add_sep = 0;
-
- my $add_option_string = sub {
- my ($text, $optional) = @_;
-
- if ($add_sep) {
- $text = ",$text";
- $res .= ' ';
- }
- $text = "[$text]" if $optional;
- $res .= $text;
- $add_sep = 1;
- };
-
- my $format_key_value = sub {
- my ($key, $phash) = @_;
-
- die "internal error" if defined($phash->{alias});
-
- my $keytext = $key;
-
- my $typetext = '';
-
- if (my $desc = $phash->{format_description}) {
- $typetext .= "<$desc>";
- } elsif (my $text = $phash->{typetext}) {
- $typetext .= $text;
- } elsif (my $enum = $phash->{enum}) {
- if ($list_enums || (scalar(@$enum) <= 3)) {
- $typetext .= '<' . join('|', @$enum) . '>';
- } else {
- $typetext .= '<enum>';
- }
- } elsif ($phash->{type} eq 'boolean') {
- $typetext .= '<1|0>';
- } elsif ($phash->{type} eq 'integer') {
- $typetext .= '<integer>';
- } elsif ($phash->{type} eq 'number') {
- $typetext .= '<number>';
- } else {
- die "internal error: neither format_description nor typetext found for option '$key'";
- }
-
- if (defined($default_key) && ($default_key eq $key)) {
- &$add_option_string("[$keytext=]$typetext", $phash->{optional});
- } else {
- &$add_option_string("$keytext=$typetext", $phash->{optional});
- }
- };
-
- my $done = {};
-
- my $cond_add_key = sub {
- my ($key) = @_;
-
- return if $done->{$key}; # avoid duplicates
-
- $done->{$key} = 1;
-
- my $phash = $format->{$key};
-
- return if !$phash; # should not happen
-
- return if $phash->{alias};
-
- &$format_key_value($key, $phash);
-
- };
-
- &$cond_add_key($default_key) if defined($default_key);
-
- # add required keys first
- foreach my $key (sort keys %$format) {
- my $phash = $format->{$key};
- &$cond_add_key($key) if $phash && !$phash->{optional};
- }
-
- # add the rest
- foreach my $key (sort keys %$format) {
- &$cond_add_key($key);
- }
-
- foreach my $keyAlias (sort keys %$keyAliasProps) {
- &$add_option_string("<$keyAlias>=<$keyAliasProps->{$keyAlias }>", 1);
- }
-
- return $res;
-}
-
-sub print_property_string {
- my ($data, $format, $skip, $path) = @_;
-
- if (ref($format) ne 'HASH') {
- my $schema = get_format($format);
- die "not a valid format: $format\n" if !$schema;
- $format = $schema;
- }
-
- my $errors = {};
- check_object($path, $format, $data, undef, $errors);
- if (scalar(%$errors)) {
- raise "format error", errors => $errors;
- }
-
- my ($default_key, $keyAliasProps) = &$find_schema_default_key($format);
-
- my $res = '';
- my $add_sep = 0;
-
- my $add_option_string = sub {
- my ($text) = @_;
-
- $res .= ',' if $add_sep;
- $res .= $text;
- $add_sep = 1;
- };
-
- my $format_value = sub {
- my ($key, $value, $format) = @_;
-
- if (defined($format) && ($format eq 'disk-size')) {
- return format_size($value);
- } else {
- die "illegal value with commas for $key\n" if $value =~ /,/;
- return $value;
- }
- };
-
- my $done = { map { $_ => 1 } @$skip };
-
- my $cond_add_key = sub {
- my ($key, $isdefault) = @_;
-
- return if $done->{$key}; # avoid duplicates
-
- $done->{$key} = 1;
-
- my $value = $data->{$key};
-
- return if !defined($value);
-
- my $phash = $format->{$key};
-
- # try to combine values if we have key aliases
- if (my $combine = $keyAliasProps->{$key}) {
- if (defined(my $combine_value = $data->{$combine})) {
- my $combine_format = $format->{$combine}->{format};
- my $value_str = &$format_value($key, $value, $phash->{format});
- my $combine_str = &$format_value($combine, $combine_value, $combine_format);
- &$add_option_string("${value_str}=${combine_str}");
- $done->{$combine} = 1;
- return;
- }
- }
-
- if ($phash && $phash->{alias}) {
- $phash = $format->{$phash->{alias}};
- }
-
- die "invalid key '$key'\n" if !$phash;
- die "internal error" if defined($phash->{alias});
-
- my $value_str = &$format_value($key, $value, $phash->{format});
- if ($isdefault) {
- &$add_option_string($value_str);
- } else {
- &$add_option_string("$key=${value_str}");
- }
- };
-
- # add default key first
- &$cond_add_key($default_key, 1) if defined($default_key);
-
- # add required keys first
- foreach my $key (sort keys %$data) {
- my $phash = $format->{$key};
- &$cond_add_key($key) if $phash && !$phash->{optional};
- }
-
- # add the rest
- foreach my $key (sort keys %$data) {
- &$cond_add_key($key);
- }
-
- return $res;
-}
-
-sub schema_get_type_text {
- my ($phash, $style) = @_;
-
- my $type = $phash->{type} || 'string';
-
- if ($phash->{typetext}) {
- return $phash->{typetext};
- } elsif ($phash->{format_description}) {
- return "<$phash->{format_description}>";
- } elsif ($phash->{enum}) {
- return "<" . join(' | ', sort @{$phash->{enum}}) . ">";
- } elsif ($phash->{pattern}) {
- return $phash->{pattern};
- } elsif ($type eq 'integer' || $type eq 'number') {
- # NOTE: always access values as number (avoid converion to string)
- if (defined($phash->{minimum}) && defined($phash->{maximum})) {
- return "<$type> (" . ($phash->{minimum} + 0) . " - " .
- ($phash->{maximum} + 0) . ")";
- } elsif (defined($phash->{minimum})) {
- return "<$type> (" . ($phash->{minimum} + 0) . " - N)";
- } elsif (defined($phash->{maximum})) {
- return "<$type> (-N - " . ($phash->{maximum} + 0) . ")";
- }
- } elsif ($type eq 'string') {
- if (my $format = $phash->{format}) {
- $format = get_format($format) if ref($format) ne 'HASH';
- if (ref($format) eq 'HASH') {
- my $list_enums = 0;
- $list_enums = 1 if $style && $style eq 'config-sub';
- return generate_typetext($format, $list_enums);
- }
- }
- }
-
- return "<$type>";
-}
-
-1;
+++ /dev/null
-package PVE::PTY;
-
-use strict;
-use warnings;
-
-use Fcntl;
-use POSIX qw(O_RDWR O_NOCTTY);
-
-# Constants
-
-use constant {
- TCGETS => 0x5401, # fixed, from asm-generic/ioctls.h
- TCSETS => 0x5402, # fixed, from asm-generic/ioctls.h
- TIOCGWINSZ => 0x5413, # fixed, from asm-generic/ioctls.h
- TIOCSWINSZ => 0x5414, # fixed, from asm-generic/ioctls.h
- TIOCSCTTY => 0x540E, # fixed, from asm-generic/ioctls.h
- TIOCNOTTY => 0x5422, # fixed, from asm-generic/ioctls.h
- TIOCGPGRP => 0x540F, # fixed, from asm-generic/ioctls.h
- TIOCSPGRP => 0x5410, # fixed, from asm-generic/ioctls.h
-
- # IOC: dir:2 size:14 type:8 nr:8
- # Get pty number: dir=2 size=4 type='T' nr=0x30
- TIOCGPTN => 0x80045430,
-
- # Set pty lock: dir=1 size=4 type='T' nr=0x31
- TIOCSPTLCK => 0x40045431,
-
- # Send signal: dir=1 size=4 type='T' nr=0x36
- TIOCSIG => 0x40045436,
-
- # c_cc indices:
- VINTR => 0,
- VQUIT => 1,
- VERASE => 2,
- VKILL => 3,
- VEOF => 4,
- VTIME => 5,
- VMIN => 6,
- VSWTC => 7,
- VSTART => 8,
- VSTOP => 9,
- VSUSP => 10,
- VEOL => 11,
- VREPRINT => 12,
- VDISCARD => 13,
- VWERASE => 14,
- VLNEXT => 15,
- VEOL2 => 16,
-};
-
-# Utility functions
-
-sub createpty() {
- # Open the master file descriptor:
- sysopen(my $master, '/dev/ptmx', O_RDWR | O_NOCTTY)
- or die "failed to create pty: $!\n";
-
- # Find the tty number
- my $ttynum = pack('L', 0);
- ioctl($master, TIOCGPTN, $ttynum)
- or die "failed to query pty number: $!\n";
- $ttynum = unpack('L', $ttynum);
-
- # Get the slave name/path
- my $ttyname = "/dev/pts/$ttynum";
-
- # Unlock
- my $false = pack('L', 0);
- ioctl($master, TIOCSPTLCK, $false)
- or die "failed to unlock pty: $!\n";
-
- return ($master, $ttyname);
-}
-
-my $openslave = sub {
- my ($ttyname) = @_;
-
- # Create a slave file descriptor:
- sysopen(my $slave, $ttyname, O_RDWR | O_NOCTTY)
- or die "failed to open slave pty handle: $!\n";
- return $slave;
-};
-
-sub lose_controlling_terminal() {
- # Can we open our current terminal?
- if (sysopen(my $ttyfd, '/dev/tty', O_RDWR)) {
- # Disconnect:
- ioctl($ttyfd, TIOCNOTTY, 0)
- or die "failed to disconnect controlling tty: $!\n";
- close($ttyfd);
- }
-}
-
-sub termios(%) {
- my (%termios) = @_;
- my $cc = $termios{cc} // [];
- if (@$cc < 19) {
- push @$cc, (0) x (19-@$cc);
- } elsif (@$cc > 19) {
- @$cc = $$cc[0..18];
- }
-
- return pack('LLLLCC[19]',
- $termios{iflag} || 0,
- $termios{oflag} || 0,
- $termios{cflag} || 0,
- $termios{lflag} || 0,
- $termios{line} || 0,
- @$cc);
-}
-
-my $parse_termios = sub {
- my ($blob) = @_;
- my ($iflag, $oflag, $cflag, $lflag, $line, @cc) =
- unpack('LLLLCC[19]', $blob);
- return {
- iflag => $iflag,
- oflag => $oflag,
- cflag => $cflag,
- lflag => $lflag,
- line => $line,
- cc => \@cc
- };
-};
-
-sub cfmakeraw($) {
- my ($termios) = @_;
- $termios->{iflag} &=
- ~(POSIX::IGNBRK | POSIX::BRKINT | POSIX::PARMRK | POSIX::ISTRIP |
- POSIX::INLCR | POSIX::IGNCR | POSIX::ICRNL | POSIX::IXON);
- $termios->{oflag} &= ~POSIX::OPOST;
- $termios->{lflag} &=
- ~(POSIX::ECHO | POSIX::ECHONL | POSIX::ICANON | POSIX::ISIG |
- POSIX::IEXTEN);
- $termios->{cflag} &= ~(POSIX::CSIZE | POSIX::PARENB);
- $termios->{cflag} |= POSIX::CS8;
-}
-
-sub tcgetattr($) {
- my ($fd) = @_;
- my $blob = termios();
- ioctl($fd, TCGETS, $blob) or die "failed to get terminal attributes\n";
- return $parse_termios->($blob);
-}
-
-sub tcsetattr($$) {
- my ($fd, $termios) = @_;
- my $blob = termios(%$termios);
- ioctl($fd, TCSETS, $blob) or die "failed to set terminal attributes\n";
-}
-
-# tcgetsize -> (columns, rows)
-sub tcgetsize($) {
- my ($fd) = @_;
- my $struct_winsz = pack('SSSS', 0, 0, 0, 0);
- ioctl($fd, TIOCGWINSZ, $struct_winsz)
- or die "failed to get window size: $!\n";
- return reverse unpack('SS', $struct_winsz);
-}
-
-sub tcsetsize($$$) {
- my ($fd, $columns, $rows) = @_;
- my $struct_winsz = pack('SSSS', $rows, $columns, 0, 0);
- ioctl($fd, TIOCSWINSZ, $struct_winsz)
- or die "failed to set window size: $!\n";
-}
-
-sub read_password($;$$) {
- my ($query, $infd, $outfd) = @_;
-
- my $password = '';
-
- $infd //= \*STDIN;
-
- if (!-t $infd) { # Not a terminal? Then just get a line...
- local $/ = "\n";
- $password = <$infd>;
- die "EOF while reading password\n" if !defined $password;
- chomp $password; # Chop off the newline
- return $password;
- }
-
- $outfd //= \*STDOUT;
-
- # Raw read loop:
- my $old_termios;
- $old_termios = tcgetattr($infd);
- my $raw_termios = {%$old_termios};
- cfmakeraw($raw_termios);
- tcsetattr($infd, $raw_termios);
- eval {
- my $echo = undef;
- my ($ch, $got);
- syswrite($outfd, $query, length($query));
- while (($got = sysread($infd, $ch, 1))) {
- my ($ord) = unpack('C', $ch);
- last if $ord == 4; # ^D / EOF
- if ($ord == 0xA || $ord == 0xD) {
- # newline, we're done
- syswrite($outfd, "\r\n", 2);
- last;
- } elsif ($ord == 3) { # ^C
- die "password input aborted\n";
- } elsif ($ord == 0x7f) {
- # backspace - if it's the first key disable
- # asterisks
- $echo //= 0;
- if (length($password)) {
- chop $password;
- syswrite($outfd, "\b \b", 3);
- }
- } elsif ($ord == 0x09) {
- # TAB disables the asterisk-echo
- $echo = 0;
- } else {
- # other character, append to password, if it's
- # the first character enable asterisks echo
- $echo //= 1;
- $password .= $ch;
- syswrite($outfd, '*', 1) if $echo;
- }
- }
- die "read error: $!\n" if !defined($got);
- };
- my $err = $@;
- tcsetattr($infd, $old_termios);
- die $err if $err;
- return $password;
-}
-
-# Class functions
-
-sub new {
- my ($class) = @_;
-
- my ($master, $ttyname) = createpty();
-
- my $self = {
- master => $master,
- ttyname => $ttyname,
- };
-
- return bless $self, $class;
-}
-
-# Properties
-
-sub master { return $_[0]->{master} }
-sub ttyname { return $_[0]->{ttyname} }
-
-# Methods
-
-sub close {
- my ($self) = @_;
- close($self->{master});
-}
-
-sub open_slave {
- my ($self) = @_;
- return $openslave->($self->{ttyname});
-}
-
-sub set_size {
- my ($self, $columns, $rows) = @_;
- tcsetsize($self->{master}, $columns, $rows);
-}
-
-# get_size -> (columns, rows)
-sub get_size {
- my ($self) = @_;
- return tcgetsize($self->{master});
-}
-
-sub kill {
- my ($self, $signal) = @_;
- if (!ioctl($self->{master}, TIOCSIG, $signal)) {
- # kill fallback if the ioctl does not work
- kill $signal, $self->get_foreground_pid()
- or die "failed to send signal: $!\n";
- }
-}
-
-sub get_foreground_pid {
- my ($self) = @_;
- my $pid = pack('L', 0);
- ioctl($self->{master}, TIOCGPGRP, $pid)
- or die "failed to get foreground pid: $!\n";
- return unpack('L', $pid);
-}
-
-sub has_process {
- my ($self) = @_;
- return 0 != $self->get_foreground_pid();
-}
-
-sub make_controlling_terminal {
- my ($self) = @_;
-
- #lose_controlling_terminal();
- POSIX::setsid();
- my $slave = $self->open_slave();
- ioctl($slave, TIOCSCTTY, 0)
- or die "failed to change controlling tty: $!\n";
- POSIX::dup2(fileno($slave), 0) or die "failed to dup stdin\n";
- POSIX::dup2(fileno($slave), 1) or die "failed to dup stdout\n";
- POSIX::dup2(fileno($slave), 2) or die "failed to dup stderr\n";
- CORE::close($slave) if fileno($slave) > 2;
- CORE::close($self->{master});
-}
-
-sub getattr {
- my ($self) = @_;
- return tcgetattr($self->{master});
-}
-
-sub setattr {
- my ($self, $termios) = @_;
- return tcsetattr($self->{master}, $termios);
-}
-
-sub send_cc {
- my ($self, $ccidx) = @_;
- my $attrs = $self->getattr();
- my $data = pack('C', $attrs->{cc}->[$ccidx]);
- syswrite($self->{master}, $data)
- == 1 || die "write failed: $!\n";
-}
-
-sub send_eof {
- my ($self) = @_;
- $self->send_cc(VEOF);
-}
-
-sub send_interrupt {
- my ($self) = @_;
- $self->send_cc(VINTR);
-}
-
-1;
+++ /dev/null
-package PVE::RESTHandler;
-
-use strict;
-no strict 'refs'; # our autoload requires this
-use warnings;
-use PVE::SafeSyslog;
-use PVE::Exception qw(raise raise_param_exc);
-use PVE::JSONSchema;
-use PVE::Tools;
-use HTTP::Status qw(:constants :is status_message);
-use Text::Wrap;
-use Clone qw(clone);
-
-my $method_registry = {};
-my $method_by_name = {};
-my $method_path_lookup = {};
-
-our $AUTOLOAD; # it's a package global
-
-sub api_clone_schema {
- my ($schema) = @_;
-
- my $res = {};
- my $ref = ref($schema);
- die "not a HASH reference" if !($ref && $ref eq 'HASH');
-
- foreach my $k (keys %$schema) {
- my $d = $schema->{$k};
- if ($k ne 'properties') {
- $res->{$k} = ref($d) ? clone($d) : $d;
- next;
- }
- # convert indexed parameters like -net\d+ to -net[n]
- foreach my $p (keys %$d) {
- my $pd = $d->{$p};
- if ($p =~ m/^([a-z]+)(\d+)$/) {
- my ($name, $idx) = ($1, $2);
- if ($idx == 0 && defined($d->{"${name}1"})) {
- $p = "${name}[n]";
- } elsif (defined($d->{"${name}0"})) {
- next; # only handle once for -xx0, but only if -xx0 exists
- }
- }
- my $tmp = ref($pd) ? clone($pd) : $pd;
- # NOTE: add typetext property for more complex types, to
- # make the web api viewer code simpler
- if (!(defined($tmp->{enum}) || defined($tmp->{pattern}))) {
- my $typetext = PVE::JSONSchema::schema_get_type_text($tmp);
- if ($tmp->{type} && ($tmp->{type} ne $typetext)) {
- $tmp->{typetext} = $typetext;
- }
- }
- $res->{$k}->{$p} = $tmp;
- }
- }
-
- return $res;
-}
-
-sub api_dump_full {
- my ($tree, $index, $class, $prefix) = @_;
-
- $prefix = '' if !$prefix;
-
- my $ma = $method_registry->{$class};
-
- foreach my $info (@$ma) {
-
- my $path = "$prefix/$info->{path}";
- $path =~ s/\/+$//;
-
- if ($info->{subclass}) {
- api_dump_full($tree, $index, $info->{subclass}, $path);
- } else {
- next if !$path;
-
- # check if method is unique
- my $realpath = $path;
- $realpath =~ s/\{[^\}]+\}/\{\}/g;
- my $fullpath = "$info->{method} $realpath";
- die "duplicate path '$realpath'" if $index->{$fullpath};
- $index->{$fullpath} = $info;
-
- # insert into tree
- my $treedir = $tree;
- my $res;
- my $sp = '';
- foreach my $dir (split('/', $path)) {
- next if !$dir;
- $sp .= "/$dir";
- $res = (grep { $_->{text} eq $dir } @$treedir)[0];
- if ($res) {
- $res->{children} = [] if !$res->{children};
- $treedir = $res->{children};
- } else {
- $res = {
- path => $sp,
- text => $dir,
- children => [],
- };
- push @$treedir, $res;
- $treedir = $res->{children};
- }
- }
-
- if ($res) {
- my $data = {};
- foreach my $k (keys %$info) {
- next if $k eq 'code' || $k eq "match_name" || $k eq "match_re" ||
- $k eq "path";
-
- my $d = $info->{$k};
-
- if ($k eq 'parameters') {
- $data->{$k} = api_clone_schema($d);
- } else {
-
- $data->{$k} = ref($d) ? clone($d) : $d;
- }
- }
- $res->{info}->{$info->{method}} = $data;
- };
- }
- }
-};
-
-sub api_dump_cleanup_tree {
- my ($tree) = @_;
-
- foreach my $rec (@$tree) {
- delete $rec->{children} if $rec->{children} && !scalar(@{$rec->{children}});
- if ($rec->{children}) {
- $rec->{leaf} = 0;
- api_dump_cleanup_tree($rec->{children});
- } else {
- $rec->{leaf} = 1;
- }
- }
-
-}
-
-# api_dump_remove_refs: prepare API tree for use with to_json($tree)
-sub api_dump_remove_refs {
- my ($tree) = @_;
-
- my $class = ref($tree);
- return $tree if !$class;
-
- if ($class eq 'ARRAY') {
- my $res = [];
- foreach my $el (@$tree) {
- push @$res, api_dump_remove_refs($el);
- }
- return $res;
- } elsif ($class eq 'HASH') {
- my $res = {};
- foreach my $k (keys %$tree) {
- if (my $itemclass = ref($tree->{$k})) {
- if ($itemclass eq 'CODE') {
- next if $k eq 'completion';
- }
- $res->{$k} = api_dump_remove_refs($tree->{$k});
- } else {
- $res->{$k} = $tree->{$k};
- }
- }
- return $res;
- } elsif ($class eq 'Regexp') {
- return "$tree"; # return string representation
- } else {
- die "unknown class '$class'\n";
- }
-}
-
-sub api_dump {
- my ($class, $prefix) = @_;
-
- my $tree = [];
-
- my $index = {};
- api_dump_full($tree, $index, $class);
- api_dump_cleanup_tree($tree);
- return $tree;
-};
-
-sub validate_method_schemas {
-
- foreach my $class (keys %$method_registry) {
- my $ma = $method_registry->{$class};
-
- foreach my $info (@$ma) {
- PVE::JSONSchema::validate_method_info($info);
- }
- }
-}
-
-sub register_method {
- my ($self, $info) = @_;
-
- my $match_re = [];
- my $match_name = [];
-
- my $errprefix;
-
- my $method;
- if ($info->{subclass}) {
- $errprefix = "register subclass $info->{subclass} at ${self}/$info->{path} -";
- $method = 'SUBCLASS';
- } else {
- $errprefix = "register method ${self}/$info->{path} -";
- $info->{method} = 'GET' if !$info->{method};
- $method = $info->{method};
- }
-
- $method_path_lookup->{$self} = {} if !defined($method_path_lookup->{$self});
- my $path_lookup = $method_path_lookup->{$self};
-
- die "$errprefix no path" if !defined($info->{path});
-
- foreach my $comp (split(/\/+/, $info->{path})) {
- die "$errprefix path compoment has zero length\n" if $comp eq '';
- my ($name, $regex);
- if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) {
- $name = $1;
- $regex = $3 ? $3 : '\S+';
- push @$match_re, $regex;
- push @$match_name, $name;
- } else {
- $name = $comp;
- push @$match_re, $name;
- push @$match_name, undef;
- }
-
- if ($regex) {
- $path_lookup->{regex} = {} if !defined($path_lookup->{regex});
-
- my $old_name = $path_lookup->{regex}->{match_name};
- die "$errprefix found changed regex match name\n"
- if defined($old_name) && ($old_name ne $name);
- my $old_re = $path_lookup->{regex}->{match_re};
- die "$errprefix found changed regex\n"
- if defined($old_re) && ($old_re ne $regex);
- $path_lookup->{regex}->{match_name} = $name;
- $path_lookup->{regex}->{match_re} = $regex;
-
- die "$errprefix path match error - regex and fixed items\n"
- if defined($path_lookup->{folders});
-
- $path_lookup = $path_lookup->{regex};
-
- } else {
- $path_lookup->{folders}->{$name} = {} if !defined($path_lookup->{folders}->{$name});
-
- die "$errprefix path match error - regex and fixed items\n"
- if defined($path_lookup->{regex});
-
- $path_lookup = $path_lookup->{folders}->{$name};
- }
- }
-
- die "$errprefix duplicate method definition\n"
- if defined($path_lookup->{$method});
-
- if ($method eq 'SUBCLASS') {
- foreach my $m (qw(GET PUT POST DELETE)) {
- die "$errprefix duplicate method definition SUBCLASS and $m\n" if $path_lookup->{$m};
- }
- }
- $path_lookup->{$method} = $info;
-
- $info->{match_re} = $match_re;
- $info->{match_name} = $match_name;
-
- $method_by_name->{$self} = {} if !defined($method_by_name->{$self});
-
- if ($info->{name}) {
- die "$errprefix method name already defined\n"
- if defined($method_by_name->{$self}->{$info->{name}});
-
- $method_by_name->{$self}->{$info->{name}} = $info;
- }
-
- push @{$method_registry->{$self}}, $info;
-}
-
-sub DESTROY {}; # avoid problems with autoload
-
-sub AUTOLOAD {
- my ($this) = @_;
-
- # also see "man perldiag"
-
- my $sub = $AUTOLOAD;
- (my $method = $sub) =~ s/.*:://;
-
- my $info = $this->map_method_by_name($method);
-
- *{$sub} = sub {
- my $self = shift;
- return $self->handle($info, @_);
- };
- goto &$AUTOLOAD;
-}
-
-sub method_attributes {
- my ($self) = @_;
-
- return $method_registry->{$self};
-}
-
-sub map_method_by_name {
- my ($self, $name) = @_;
-
- my $info = $method_by_name->{$self}->{$name};
- die "no such method '${self}::$name'\n" if !$info;
-
- return $info;
-}
-
-sub map_path_to_methods {
- my ($class, $stack, $uri_param, $pathmatchref) = @_;
-
- my $path_lookup = $method_path_lookup->{$class};
-
- # Note: $pathmatchref can be used to obtain path including
- # uri patterns like '/cluster/firewall/groups/{group}'.
- # Used by pvesh to display help
- if (defined($pathmatchref)) {
- $$pathmatchref = '' if !$$pathmatchref;
- }
-
- while (defined(my $comp = shift @$stack)) {
- return undef if !$path_lookup; # not registerd?
- if ($path_lookup->{regex}) {
- my $name = $path_lookup->{regex}->{match_name};
- my $regex = $path_lookup->{regex}->{match_re};
-
- return undef if $comp !~ m/^($regex)$/;
- $uri_param->{$name} = $1;
- $path_lookup = $path_lookup->{regex};
- $$pathmatchref .= '/{' . $name . '}' if defined($pathmatchref);
- } elsif ($path_lookup->{folders}) {
- $path_lookup = $path_lookup->{folders}->{$comp};
- $$pathmatchref .= '/' . $comp if defined($pathmatchref);
- } else {
- die "internal error";
- }
-
- return undef if !$path_lookup;
-
- if (my $info = $path_lookup->{SUBCLASS}) {
- $class = $info->{subclass};
-
- my $fd = $info->{fragmentDelimiter};
-
- if (defined($fd)) {
- # we only support the empty string '' (match whole URI)
- die "unsupported fragmentDelimiter '$fd'"
- if $fd ne '';
-
- $stack = [ join ('/', @$stack) ] if scalar(@$stack) > 1;
- }
- $path_lookup = $method_path_lookup->{$class};
- }
- }
-
- return undef if !$path_lookup;
-
- return ($class, $path_lookup);
-}
-
-sub find_handler {
- my ($class, $method, $path, $uri_param, $pathmatchref) = @_;
-
- my $stack = [ grep { length($_) > 0 } split('\/+' , $path)]; # skip empty fragments
-
- my ($handler_class, $path_info);
- eval {
- ($handler_class, $path_info) = $class->map_path_to_methods($stack, $uri_param, $pathmatchref);
- };
- my $err = $@;
- syslog('err', $err) if $err;
-
- return undef if !($handler_class && $path_info);
-
- my $method_info = $path_info->{$method};
-
- return undef if !$method_info;
-
- return ($handler_class, $method_info);
-}
-
-sub handle {
- my ($self, $info, $param) = @_;
-
- my $func = $info->{code};
-
- if (!($info->{name} && $func)) {
- raise("Method lookup failed ('$info->{name}')\n",
- code => HTTP_INTERNAL_SERVER_ERROR);
- }
-
- if (my $schema = $info->{parameters}) {
- # warn "validate ". Dumper($param}) . "\n" . Dumper($schema);
- PVE::JSONSchema::validate($param, $schema);
- # untaint data (already validated)
- my $extra = delete $param->{'extra-args'};
- while (my ($key, $val) = each %$param) {
- ($param->{$key}) = $val =~ /^(.*)$/s;
- }
- $param->{'extra-args'} = [map { /^(.*)$/ } @$extra] if $extra;
- }
-
- my $result = &$func($param);
-
- # todo: this is only to be safe - disable?
- if (my $schema = $info->{returns}) {
- PVE::JSONSchema::validate($result, $schema, "Result verification failed\n");
- }
-
- return $result;
-}
-
-# format option, display type and description
-# $name: option name
-# $display_name: for example "-$name" of "<$name>", pass undef to use "$name:"
-# $phash: json schema property hash
-# $format: 'asciidoc', 'short', 'long' or 'full'
-# $style: 'config', 'config-sub', 'arg' or 'fixed'
-# $mapdef: parameter mapping ({ desc => XXX, func => sub {...} })
-my $get_property_description = sub {
- my ($name, $style, $phash, $format, $hidepw, $mapdef) = @_;
-
- my $res = '';
-
- $format = 'asciidoc' if !defined($format);
-
- my $descr = $phash->{description} || "no description available";
-
- if ($phash->{verbose_description} &&
- ($style eq 'config' || $style eq 'config-sub')) {
- $descr = $phash->{verbose_description};
- }
-
- chomp $descr;
-
- my $type_text = PVE::JSONSchema::schema_get_type_text($phash, $style);
-
- if ($hidepw && $name eq 'password') {
- $type_text = '';
- }
-
- if ($mapdef && $phash->{type} eq 'string') {
- $type_text = $mapdef->{desc};
- }
-
- if ($format eq 'asciidoc') {
-
- if ($style eq 'config') {
- $res .= "`$name`: ";
- } elsif ($style eq 'config-sub') {
- $res .= "`$name`=";
- } elsif ($style eq 'arg') {
- $res .= "`--$name` ";
- } elsif ($style eq 'fixed') {
- $res .= "`<$name>`: ";
- } else {
- die "unknown style '$style'";
- }
-
- $res .= "`$type_text` " if $type_text;
-
- if (defined(my $dv = $phash->{default})) {
- $res .= "('default =' `$dv`)";
- }
-
- if ($style eq 'config-sub') {
- $res .= ";;\n\n";
- } else {
- $res .= "::\n\n";
- }
-
- my $wdescr = $descr;
- chomp $wdescr;
- $wdescr =~ s/^$/+/mg;
-
- $res .= $wdescr . "\n";
-
- if (my $req = $phash->{requires}) {
- my $tmp .= ref($req) ? join(', ', @$req) : $req;
- $res .= "+\nNOTE: Requires option(s): `$tmp`\n";
- }
- $res .= "\n";
-
- } elsif ($format eq 'short' || $format eq 'long' || $format eq 'full') {
-
- my $defaulttxt = '';
- if (defined(my $dv = $phash->{default})) {
- $defaulttxt = " (default=$dv)";
- }
-
- my $display_name;
- if ($style eq 'config') {
- $display_name = "$name:";
- } elsif ($style eq 'arg') {
- $display_name = "-$name";
- } elsif ($style eq 'fixed') {
- $display_name = "<$name>";
- } else {
- die "unknown style '$style'";
- }
-
- my $tmp = sprintf " %-10s %s$defaulttxt\n", $display_name, "$type_text";
- my $indend = " ";
-
- $res .= Text::Wrap::wrap('', $indend, ($tmp));
- $res .= "\n",
- $res .= Text::Wrap::wrap($indend, $indend, ($descr)) . "\n\n";
-
- if (my $req = $phash->{requires}) {
- my $tmp = "Requires option(s): ";
- $tmp .= ref($req) ? join(', ', @$req) : $req;
- $res .= Text::Wrap::wrap($indend, $indend, ($tmp)). "\n\n";
- }
-
- } else {
- die "unknown format '$format'";
- }
-
- return $res;
-};
-
-# translate parameter mapping definition
-# $mapping_array is a array which can contain:
-# strings ... in that case we assume it is a parameter name, and
-# we want to load that parameter from a file
-# [ param_name, func, desc] ... allows you to specify a arbitrary
-# mapping func for any param
-#
-# Returns: a hash indexed by parameter_name,
-# i.e. { param_name => { func => .., desc => ... } }
-my $compute_param_mapping_hash = sub {
- my ($mapping_array) = @_;
-
- my $res = {};
-
- return $res if !defined($mapping_array);
-
- foreach my $item (@$mapping_array) {
- my ($name, $func, $desc, $interactive);
- if (ref($item) eq 'ARRAY') {
- ($name, $func, $desc, $interactive) = @$item;
- } else {
- $name = $item;
- $func = sub { return PVE::Tools::file_get_contents($_[0]) };
- }
- $desc //= '<filepath>';
- $res->{$name} = { desc => $desc, func => $func, interactive => $interactive };
- }
-
- return $res;
-};
-
-# generate usage information for command line tools
-#
-# $name ... the name of the method
-# $prefix ... usually something like "$exename $cmd" ('pvesm add')
-# $arg_param ... list of parameters we want to get as ordered arguments
-# on the command line (or single parameter name for lists)
-# $fixed_param ... do not generate and info about those parameters
-# $format:
-# 'long' ... default (text, list all options)
-# 'short' ... command line only (text, one line)
-# 'full' ... text, include description
-# 'asciidoc' ... generate asciidoc for man pages (like 'full')
-# $hidepw ... hide password option (use this if you provide a read passwork callback)
-# $param_mapping_func ... mapping for string parameters to file path parameters
-sub usage_str {
- my ($self, $name, $prefix, $arg_param, $fixed_param, $format, $hidepw, $param_mapping_func) = @_;
-
- $format = 'long' if !$format;
-
- my $info = $self->map_method_by_name($name);
- my $schema = $info->{parameters};
- my $prop = $schema->{properties};
-
- my $out = '';
-
- my $arg_hash = {};
-
- my $args = '';
-
- $arg_param = [ $arg_param ] if $arg_param && !ref($arg_param);
-
- foreach my $p (@$arg_param) {
- next if !$prop->{$p}; # just to be sure
- my $pd = $prop->{$p};
-
- $arg_hash->{$p} = 1;
- $args .= " " if $args;
- if ($pd->{format} && $pd->{format} =~ m/-list/) {
- $args .= "{<$p>}";
- } else {
- $args .= $pd->{optional} ? "[<$p>]" : "<$p>";
- }
- }
-
- my $argdescr = '';
- foreach my $k (@$arg_param) {
- next if defined($fixed_param->{$k}); # just to be sure
- next if !$prop->{$k}; # just to be sure
- $argdescr .= &$get_property_description($k, 'fixed', $prop->{$k}, $format, 0);
- }
-
- my $idx_param = {}; # -vlan\d+ -scsi\d+
-
- my $opts = '';
- foreach my $k (sort keys %$prop) {
- next if $arg_hash->{$k};
- next if defined($fixed_param->{$k});
-
- my $type_text = $prop->{$k}->{type} || 'string';
-
- next if $hidepw && ($k eq 'password') && !$prop->{$k}->{optional};
-
- my $base = $k;
- if ($k =~ m/^([a-z]+)(\d+)$/) {
- my ($name, $idx) = ($1, $2);
- next if $idx_param->{$name};
- if ($idx == 0 && defined($prop->{"${name}1"})) {
- $idx_param->{$name} = 1;
- $base = "${name}[n]";
- }
- }
-
- my $param_mapping_hash = $compute_param_mapping_hash->(&$param_mapping_func($name))
- if $param_mapping_func;
-
- $opts .= &$get_property_description($base, 'arg', $prop->{$k}, $format,
- $hidepw, $param_mapping_hash->{$k});
-
- if (!$prop->{$k}->{optional}) {
- $args .= " " if $args;
- $args .= "--$base <$type_text>"
- }
- }
-
- if ($format eq 'asciidoc') {
- $out .= "*${prefix}*";
- $out .= " `$args`" if $args;
- $out .= $opts ? " `[OPTIONS]`\n" : "\n";
- } else {
- $out .= "USAGE: " if $format ne 'short';
- $out .= "$prefix $args";
- $out .= $opts ? " [OPTIONS]\n" : "\n";
- }
-
- return $out if $format eq 'short';
-
- if ($info->{description}) {
- if ($format eq 'asciidoc') {
- my $desc = Text::Wrap::wrap('', '', ($info->{description}));
- $out .= "\n$desc\n\n";
- } elsif ($format eq 'full') {
- my $desc = Text::Wrap::wrap(' ', ' ', ($info->{description}));
- $out .= "\n$desc\n\n";
- }
- }
-
- $out .= $argdescr if $argdescr;
-
- $out .= $opts if $opts;
-
- return $out;
-}
-
-# generate docs from JSON schema properties
-sub dump_properties {
- my ($prop, $format, $style, $filterFn) = @_;
-
- my $raw = '';
-
- $style //= 'config';
-
- my $idx_param = {}; # -vlan\d+ -scsi\d+
-
- foreach my $k (sort keys %$prop) {
- my $phash = $prop->{$k};
-
- next if defined($filterFn) && &$filterFn($k, $phash);
- next if $phash->{alias};
-
- my $base = $k;
- if ($k =~ m/^([a-z]+)(\d+)$/) {
- my ($name, $idx) = ($1, $2);
- next if $idx_param->{$name};
- if ($idx == 0 && defined($prop->{"${name}1"})) {
- $idx_param->{$name} = 1;
- $base = "${name}[n]";
- }
- }
-
- $raw .= &$get_property_description($base, $style, $phash, $format, 0);
-
- next if $style ne 'config';
-
- my $prop_fmt = $phash->{format};
- next if !$prop_fmt;
-
- if (ref($prop_fmt) ne 'HASH') {
- $prop_fmt = PVE::JSONSchema::get_format($prop_fmt);
- }
-
- next if !(ref($prop_fmt) && (ref($prop_fmt) eq 'HASH'));
-
- $raw .= dump_properties($prop_fmt, $format, 'config-sub')
-
- }
-
- return $raw;
-}
-
-my $replace_file_names_with_contents = sub {
- my ($param, $param_mapping_hash) = @_;
-
- while (my ($k, $d) = each %$param_mapping_hash) {
- next if $d->{interactive}; # handled by the JSONSchema's get_options code
- $param->{$k} = $d->{func}->($param->{$k})
- if defined($param->{$k});
- }
-
- return $param;
-};
-
-sub cli_handler {
- my ($self, $prefix, $name, $args, $arg_param, $fixed_param, $read_password_func, $param_mapping_func) = @_;
-
- my $info = $self->map_method_by_name($name);
-
- my $res;
- eval {
- my $param_mapping_hash = $compute_param_mapping_hash->($param_mapping_func->($name)) if $param_mapping_func;
- my $param = PVE::JSONSchema::get_options($info->{parameters}, $args, $arg_param, $fixed_param, $read_password_func, $param_mapping_hash);
-
- if (defined($param_mapping_hash)) {
- &$replace_file_names_with_contents($param, $param_mapping_hash);
- }
-
- $res = $self->handle($info, $param);
- };
- if (my $err = $@) {
- my $ec = ref($err);
-
- die $err if !$ec || $ec ne "PVE::Exception" || !$err->is_param_exc();
-
- $err->{usage} = $self->usage_str($name, $prefix, $arg_param, $fixed_param, 'short', $read_password_func, $param_mapping_func);
-
- die $err;
- }
-
- return $res;
-}
-
-# utility methods
-# note: this modifies the original hash by adding the id property
-sub hash_to_array {
- my ($hash, $idprop) = @_;
-
- my $res = [];
- return $res if !$hash;
-
- foreach my $k (keys %$hash) {
- $hash->{$k}->{$idprop} = $k;
- push @$res, $hash->{$k};
- }
-
- return $res;
-}
-
-1;
+++ /dev/null
-package PVE::SafeSyslog;
-
-use strict;
-use warnings;
-use File::Basename;
-use Sys::Syslog ();
-use Encode;
-
-use vars qw($VERSION @ISA @EXPORT);
-
-$VERSION = '1.00';
-
-require Exporter;
-
-@ISA = qw(Exporter);
-
-@EXPORT = qw(syslog initlog);
-
-my $log_tag = "unknown";
-
-# never log to console - thats too slow, and
-# it corrupts the DBD database connection!
-
-sub syslog {
- eval { Sys::Syslog::syslog (@_); }; # ignore errors
-}
-
-sub initlog {
- my ($tag, $facility) = @_;
-
- if ($tag) {
- $tag = basename($tag);
-
- $tag = encode("ascii", decode_utf8($tag));
-
- $log_tag = $tag;
- }
-
- $facility = "daemon" if !$facility;
-
- # never log to console - thats too slow
- Sys::Syslog::setlogsock ('unix');
-
- Sys::Syslog::openlog ($log_tag, 'pid', $facility);
-}
-
-sub tag {
- return $log_tag;
-}
-
-1;
+++ /dev/null
-package PVE::SectionConfig;
-
-use strict;
-use warnings;
-use Digest::SHA;
-use PVE::Exception qw(raise_param_exc);
-use PVE::JSONSchema qw(get_standard_option);
-
-use Data::Dumper;
-
-my $defaultData = {
- options => {},
- plugins => {},
- plugindata => {},
- propertyList => {},
-};
-
-sub private {
- die "overwrite me";
- return $defaultData;
-}
-
-sub register {
- my ($class) = @_;
-
- my $type = $class->type();
- my $pdata = $class->private();
-
- die "duplicate plugin registration (type = $type)"
- if defined($pdata->{plugins}->{$type});
-
- my $plugindata = $class->plugindata();
- $pdata->{plugindata}->{$type} = $plugindata;
- $pdata->{plugins}->{$type} = $class;
-}
-
-sub type {
- die "overwrite me";
-}
-
-sub properties {
- return {};
-}
-
-sub options {
- return {};
-}
-
-sub plugindata {
- return {};
-}
-
-sub createSchema {
- my ($class, $skip_type) = @_;
-
- my $pdata = $class->private();
- my $propertyList = $pdata->{propertyList};
- my $plugins = $pdata->{plugins};
-
- my $props = {};
-
- my $copy_property = sub {
- my ($src) = @_;
-
- my $res = {};
- foreach my $k (keys %$src) {
- $res->{$k} = $src->{$k};
- }
-
- return $res;
- };
-
- foreach my $p (keys %$propertyList) {
- next if $skip_type && $p eq 'type';
-
- if (!$propertyList->{$p}->{optional}) {
- $props->{$p} = $propertyList->{$p};
- next;
- }
-
- my $required = 1;
-
- my $copts = $class->options();
- $required = 0 if defined($copts->{$p}) && $copts->{$p}->{optional};
-
- foreach my $t (keys %$plugins) {
- my $opts = $pdata->{options}->{$t} || {};
- $required = 0 if !defined($opts->{$p}) || $opts->{$p}->{optional};
- }
-
- if ($required) {
- # make a copy, because we modify the optional property
- my $res = &$copy_property($propertyList->{$p});
- $res->{optional} = 0;
- $props->{$p} = $res;
- } else {
- $props->{$p} = $propertyList->{$p};
- }
- }
-
- return {
- type => "object",
- additionalProperties => 0,
- properties => $props,
- };
-}
-
-sub updateSchema {
- my ($class, $single_class) = @_;
-
- my $pdata = $class->private();
- my $propertyList = $pdata->{propertyList};
- my $plugins = $pdata->{plugins};
-
- my $props = {};
-
- my $filter_type = $class->type() if $single_class;
-
- foreach my $p (keys %$propertyList) {
- next if $p eq 'type';
-
- my $copts = $class->options();
-
- next if defined($filter_type) && !defined($copts->{$p});
-
- if (!$propertyList->{$p}->{optional}) {
- $props->{$p} = $propertyList->{$p};
- next;
- }
-
- my $modifyable = 0;
-
- $modifyable = 1 if defined($copts->{$p}) && !$copts->{$p}->{fixed};
-
- foreach my $t (keys %$plugins) {
- my $opts = $pdata->{options}->{$t} || {};
- next if !defined($opts->{$p});
- $modifyable = 1 if !$opts->{$p}->{fixed};
- }
- next if !$modifyable;
-
- $props->{$p} = $propertyList->{$p};
- }
-
- $props->{digest} = get_standard_option('pve-config-digest');
-
- $props->{delete} = {
- type => 'string', format => 'pve-configid-list',
- description => "A list of settings you want to delete.",
- maxLength => 4096,
- optional => 1,
- };
-
- return {
- type => "object",
- additionalProperties => 0,
- properties => $props,
- };
-}
-
-sub init {
- my ($class) = @_;
-
- my $pdata = $class->private();
-
- foreach my $k (qw(options plugins plugindata propertyList)) {
- $pdata->{$k} = {} if !$pdata->{$k};
- }
-
- my $plugins = $pdata->{plugins};
- my $propertyList = $pdata->{propertyList};
-
- foreach my $type (keys %$plugins) {
- my $props = $plugins->{$type}->properties();
- foreach my $p (keys %$props) {
- die "duplicate property '$p'" if defined($propertyList->{$p});
- my $res = $propertyList->{$p} = {};
- my $data = $props->{$p};
- for my $a (keys %$data) {
- $res->{$a} = $data->{$a};
- }
- $res->{optional} = 1;
- }
- }
-
- foreach my $type (keys %$plugins) {
- my $opts = $plugins->{$type}->options();
- foreach my $p (keys %$opts) {
- die "undefined property '$p'" if !$propertyList->{$p};
- }
- $pdata->{options}->{$type} = $opts;
- }
-
- $propertyList->{type}->{type} = 'string';
- $propertyList->{type}->{enum} = [sort keys %$plugins];
-}
-
-sub lookup {
- my ($class, $type) = @_;
-
- my $pdata = $class->private();
- my $plugin = $pdata->{plugins}->{$type};
-
- die "unknown section type '$type'\n" if !$plugin;
-
- return $plugin;
-}
-
-sub lookup_types {
- my ($class) = @_;
-
- my $pdata = $class->private();
-
- return [ sort keys %{$pdata->{plugins}} ];
-}
-
-sub decode_value {
- my ($class, $type, $key, $value) = @_;
-
- return $value;
-}
-
-sub encode_value {
- my ($class, $type, $key, $value) = @_;
-
- return $value;
-}
-
-sub check_value {
- my ($class, $type, $key, $value, $storeid, $skipSchemaCheck) = @_;
-
- my $pdata = $class->private();
-
- return $value if $key eq 'type' && $type eq $value;
-
- my $opts = $pdata->{options}->{$type};
- die "unknown section type '$type'\n" if !$opts;
-
- die "unexpected property '$key'\n" if !defined($opts->{$key});
-
- my $schema = $pdata->{propertyList}->{$key};
- die "unknown property type\n" if !$schema;
-
- my $ct = $schema->{type};
-
- $value = 1 if $ct eq 'boolean' && !defined($value);
-
- die "got undefined value\n" if !defined($value);
-
- die "property contains a line feed\n" if $value =~ m/[\n\r]/;
-
- if (!$skipSchemaCheck) {
- my $errors = {};
- PVE::JSONSchema::check_prop($value, $schema, '', $errors);
- if (scalar(keys %$errors)) {
- die "$errors->{$key}\n" if $errors->{$key};
- die "$errors->{_root}\n" if $errors->{_root};
- die "unknown error\n";
- }
- }
-
- if ($ct eq 'boolean' || $ct eq 'integer' || $ct eq 'number') {
- return $value + 0; # convert to number
- }
-
- return $value;
-}
-
-sub parse_section_header {
- my ($class, $line) = @_;
-
- if ($line =~ m/^(\S+):\s*(\S+)\s*$/) {
- my ($type, $sectionId) = ($1, $2);
- my $errmsg = undef; # set if you want to skip whole section
- my $config = {}; # to return additional attributes
- return ($type, $sectionId, $errmsg, $config);
- }
- return undef;
-}
-
-sub format_section_header {
- my ($class, $type, $sectionId, $scfg, $done_hash) = @_;
-
- return "$type: $sectionId\n";
-}
-
-
-sub parse_config {
- my ($class, $filename, $raw) = @_;
-
- my $pdata = $class->private();
-
- my $ids = {};
- my $order = {};
-
- $raw = '' if !defined($raw);
-
- my $digest = Digest::SHA::sha1_hex($raw);
-
- my $pri = 1;
-
- my $lineno = 0;
- my @lines = split(/\n/, $raw);
- my $nextline = sub {
- while (my $line = shift @lines) {
- $lineno++;
- return $line if $line !~ /^\s*(?:#|$)/;
- }
- };
-
- while (my $line = &$nextline()) {
- my $errprefix = "file $filename line $lineno";
-
- my ($type, $sectionId, $errmsg, $config) = $class->parse_section_header($line);
- if ($config) {
- my $ignore = 0;
-
- my $plugin;
-
- if ($errmsg) {
- $ignore = 1;
- chomp $errmsg;
- warn "$errprefix (skip section '$sectionId'): $errmsg\n";
- } elsif (!$type) {
- $ignore = 1;
- warn "$errprefix (skip section '$sectionId'): missing type - internal error\n";
- } else {
- if (!($plugin = $pdata->{plugins}->{$type})) {
- $ignore = 1;
- warn "$errprefix (skip section '$sectionId'): unsupported type '$type'\n";
- }
- }
-
- while ($line = &$nextline()) {
- next if $ignore; # skip
-
- $errprefix = "file $filename line $lineno";
-
- if ($line =~ m/^\s+(\S+)(\s+(.*\S))?\s*$/) {
- my ($k, $v) = ($1, $3);
-
- eval {
- die "duplicate attribute\n" if defined($config->{$k});
- $config->{$k} = $plugin->check_value($type, $k, $v, $sectionId);
- };
- warn "$errprefix (section '$sectionId') - unable to parse value of '$k': $@" if $@;
-
- } else {
- warn "$errprefix (section '$sectionId') - ignore config line: $line\n";
- }
- }
-
- if (!$ignore && $type && $plugin && $config) {
- $config->{type} = $type;
- eval { $ids->{$sectionId} = $plugin->check_config($sectionId, $config, 1, 1); };
- warn "$errprefix (skip section '$sectionId'): $@" if $@;
- $order->{$sectionId} = $pri++;
- }
-
- } else {
- warn "$errprefix - ignore config line: $line\n";
- }
- }
-
-
- my $cfg = { ids => $ids, order => $order, digest => $digest};
-
- return $cfg;
-}
-
-sub check_config {
- my ($class, $sectionId, $config, $create, $skipSchemaCheck) = @_;
-
- my $type = $class->type();
- my $pdata = $class->private();
- my $opts = $pdata->{options}->{$type};
-
- my $settings = { type => $type };
-
- foreach my $k (keys %$config) {
- my $value = $config->{$k};
-
- die "can't change value of fixed parameter '$k'\n"
- if !$create && $opts->{$k}->{fixed};
-
- if (defined($value)) {
- my $tmp = $class->check_value($type, $k, $value, $sectionId, $skipSchemaCheck);
- $settings->{$k} = $class->decode_value($type, $k, $tmp);
- } else {
- die "got undefined value for option '$k'\n";
- }
- }
-
- if ($create) {
- # check if we have a value for all required options
- foreach my $k (keys %$opts) {
- next if $opts->{$k}->{optional};
- die "missing value for required option '$k'\n"
- if !defined($config->{$k});
- }
- }
-
- return $settings;
-}
-
-my $format_config_line = sub {
- my ($schema, $key, $value) = @_;
-
- my $ct = $schema->{type};
-
- die "property '$key' contains a line feed\n"
- if ($key =~ m/[\n\r]/) || ($value =~ m/[\n\r]/);
-
- if ($ct eq 'boolean') {
- return "\t$key " . ($value ? 1 : 0) . "\n"
- if defined($value);
- } else {
- return "\t$key $value\n" if "$value" ne '';
- }
-};
-
-sub write_config {
- my ($class, $filename, $cfg) = @_;
-
- my $pdata = $class->private();
- my $propertyList = $pdata->{propertyList};
-
- my $out = '';
-
- my $ids = $cfg->{ids};
- my $order = $cfg->{order};
-
- my $maxpri = 0;
- foreach my $sectionId (keys %$ids) {
- my $pri = $order->{$sectionId};
- $maxpri = $pri if $pri && $pri > $maxpri;
- }
- foreach my $sectionId (keys %$ids) {
- if (!defined ($order->{$sectionId})) {
- $order->{$sectionId} = ++$maxpri;
- }
- }
-
- foreach my $sectionId (sort {$order->{$a} <=> $order->{$b}} keys %$ids) {
- my $scfg = $ids->{$sectionId};
- my $type = $scfg->{type};
- my $opts = $pdata->{options}->{$type};
-
- die "unknown section type '$type'\n" if !$opts;
-
- my $done_hash = {};
-
- my $data = $class->format_section_header($type, $sectionId, $scfg, $done_hash);
- if ($scfg->{comment} && !$done_hash->{comment}) {
- my $k = 'comment';
- my $v = $class->encode_value($type, $k, $scfg->{$k});
- $data .= &$format_config_line($propertyList->{$k}, $k, $v);
- }
-
- $data .= "\tdisable\n" if $scfg->{disable} && !$done_hash->{disable};
-
- $done_hash->{comment} = 1;
- $done_hash->{disable} = 1;
-
- my @option_keys = sort keys %$opts;
- foreach my $k (@option_keys) {
- next if defined($done_hash->{$k});
- next if $opts->{$k}->{optional};
- $done_hash->{$k} = 1;
- my $v = $scfg->{$k};
- die "section '$sectionId' - missing value for required option '$k'\n"
- if !defined ($v);
- $v = $class->encode_value($type, $k, $v);
- $data .= &$format_config_line($propertyList->{$k}, $k, $v);
- }
-
- foreach my $k (@option_keys) {
- next if defined($done_hash->{$k});
- my $v = $scfg->{$k};
- next if !defined($v);
- $v = $class->encode_value($type, $k, $v);
- $data .= &$format_config_line($propertyList->{$k}, $k, $v);
- }
-
- $out .= "$data\n";
- }
-
- return $out;
-}
-
-sub assert_if_modified {
- my ($cfg, $digest) = @_;
-
- PVE::Tools::assert_if_modified($cfg->{digest}, $digest);
-}
-
-1;
+++ /dev/null
-package PVE::Tools;
-
-use strict;
-use warnings;
-use POSIX qw(EINTR EEXIST EOPNOTSUPP);
-use base 'Exporter';
-
-use IO::File;
-use Text::ParseWords;
-
-our @EXPORT_OK = qw(
-$IPV6RE
-$IPV4RE
-split_list
-file_set_contents
-file_get_contents
-extract_param
-);
-
-my $IPV4OCTET = "(?:25[0-5]|(?:2[0-4]|1[0-9]|[1-9])?[0-9])";
-our $IPV4RE = "(?:(?:$IPV4OCTET\\.){3}$IPV4OCTET)";
-my $IPV6H16 = "(?:[0-9a-fA-F]{1,4})";
-my $IPV6LS32 = "(?:(?:$IPV4RE|$IPV6H16:$IPV6H16))";
-
-our $IPV6RE = "(?:" .
- "(?:(?:" . "(?:$IPV6H16:){6})$IPV6LS32)|" .
- "(?:(?:" . "::(?:$IPV6H16:){5})$IPV6LS32)|" .
- "(?:(?:(?:" . "$IPV6H16)?::(?:$IPV6H16:){4})$IPV6LS32)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,1}$IPV6H16)?::(?:$IPV6H16:){3})$IPV6LS32)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,2}$IPV6H16)?::(?:$IPV6H16:){2})$IPV6LS32)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,3}$IPV6H16)?::(?:$IPV6H16:){1})$IPV6LS32)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,4}$IPV6H16)?::" . ")$IPV6LS32)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,5}$IPV6H16)?::" . ")$IPV6H16)|" .
- "(?:(?:(?:(?:$IPV6H16:){0,6}$IPV6H16)?::" . ")))";
-
-our $IPRE = "(?:$IPV4RE|$IPV6RE)";
-
-sub file_set_contents {
- my ($filename, $data, $perm) = @_;
-
- $perm = 0644 if !defined($perm);
-
- my $tmpname = "$filename.tmp.$$";
-
- eval {
- my ($fh, $tries) = (undef, 0);
- while (!$fh && $tries++ < 3) {
- $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT|O_EXCL, $perm);
- if (!$fh && $! == EEXIST) {
- unlink($tmpname) or die "unable to delete old temp file: $!\n";
- }
- }
- die "unable to open file '$tmpname' - $!\n" if !$fh;
- die "unable to write '$tmpname' - $!\n" unless print $fh $data;
- die "closing file '$tmpname' failed - $!\n" unless close $fh;
- };
- my $err = $@;
-
- if ($err) {
- unlink $tmpname;
- die $err;
- }
-
- if (!rename($tmpname, $filename)) {
- my $msg = "close (rename) atomic file '$filename' failed: $!\n";
- unlink $tmpname;
- die $msg;
- }
-}
-
-sub file_get_contents {
- my ($filename, $max) = @_;
-
- my $fh = IO::File->new($filename, "r") ||
- die "can't open '$filename' - $!\n";
-
- my $content = safe_read_from($fh, $max, 0, $filename);
-
- close $fh;
-
- return $content;
-}
-
-sub file_read_firstline {
- my ($filename) = @_;
-
- my $fh = IO::File->new ($filename, "r");
- return undef if !$fh;
- my $res = <$fh>;
- chomp $res if $res;
- $fh->close;
- return $res;
-}
-
-sub safe_read_from {
- my ($fh, $max, $oneline, $filename) = @_;
-
- $max = 32768 if !$max;
-
- my $subject = defined($filename) ? "file '$filename'" : 'input';
-
- my $br = 0;
- my $input = '';
- my $count;
- while ($count = sysread($fh, $input, 8192, $br)) {
- $br += $count;
- die "$subject too long - aborting\n" if $br > $max;
- if ($oneline && $input =~ m/^(.*)\n/) {
- $input = $1;
- last;
- }
- }
- die "unable to read $subject - $!\n" if !defined($count);
-
- return $input;
-}
-
-sub split_list {
- my $listtxt = shift || '';
-
- return split (/\0/, $listtxt) if $listtxt =~ m/\0/;
-
- $listtxt =~ s/[,;]/ /g;
- $listtxt =~ s/^\s+//;
-
- my @data = split (/\s+/, $listtxt);
-
- return @data;
-}
-
-# split an shell argument string into an array,
-sub split_args {
- my ($str) = @_;
-
- return $str ? [ Text::ParseWords::shellwords($str) ] : [];
-}
-
-sub extract_param {
- my ($param, $key) = @_;
-
- my $res = $param->{$key};
- delete $param->{$key};
-
- return $res;
-}
-
-1;
use strict;
use warnings;
use Cwd 'abs_path';
-use lib '/usr/share/pve-client';
-use lib '.';
use Data::Dumper;
use PVE::JSONSchema qw(register_standard_option get_standard_option);
projects / pve-client.git / commitdiff