mirror of
git://git.proxmox.com/git/pve-common.git
synced 2024-12-22 21:33:47 +03:00
imported from svn 'pve-common/trunk'
This commit is contained in:
Dietmar Maurer
commit
e143e9d86b
50
Makefile
Normal file
50
Makefile
Normal file
@ -0,0 +1,50 @@
|
||||
RELEASE=2.0
|
||||
|
||||
VERSION=1.0
|
||||
PKGREL=5
|
||||
|
||||
PACKAGE=libpve-common-perl
|
||||
|
||||
PREFIX=/usr
|
||||
BINDIR=${PREFIX}/bin
|
||||
MANDIR=${PREFIX}/share/man
|
||||
DOCDIR=${PREFIX}/share/doc
|
||||
MAN1DIR=${MANDIR}/man1/
|
||||
PERLDIR=${PREFIX}/share/perl5
|
||||
|
||||
ARCH=all
|
||||
DEB=${PACKAGE}_${VERSION}-${PKGREL}_${ARCH}.deb
|
||||
|
||||
all: ${DEB}
|
||||
|
||||
.PHONY: dinstall
|
||||
dinstall: deb
|
||||
dpkg -i ${DEB}
|
||||
|
||||
|
||||
.PHONY: deb
|
||||
deb ${DEB}:
|
||||
rm -rf build
|
||||
rsync -a --exclude .svn data/ build
|
||||
rsync -a --exclude .svn debian/ build/debian
|
||||
cd build; dpkg-buildpackage -rfakeroot -b -us -uc
|
||||
lintian ${DEB}
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
rm -rf *~ *.deb *.changes build ${PACKAGE}-*.tar.gz
|
||||
|
||||
.PHONY: distclean
|
||||
distclean: clean
|
||||
|
||||
|
||||
.PHONY: upload
|
||||
upload: ${DEB}
|
||||
umount /pve/${RELEASE}; mount /pve/${RELEASE} -o rw
|
||||
mkdir -p /pve/${RELEASE}/extra
|
||||
rm -f /pve/${RELEASE}/extra/${PACKAGE}_*.deb
|
||||
rm -f /pve/${RELEASE}/extra/Packages*
|
||||
cp ${DEB} /pve/${RELEASE}/extra
|
||||
cd /pve/${RELEASE}/extra; dpkg-scanpackages . /dev/null > Packages; gzip -9c Packages > Packages.gz
|
||||
umount /pve/${RELEASE}; mount /pve/${RELEASE} -o ro
|
||||
|
||||
198
README.dev
Normal file
198
README.dev
Normal file
@ -0,0 +1,198 @@
|
||||
====================================
|
||||
Setup PVE v2 Development Environment
|
||||
====================================
|
||||
|
||||
1. Install Debian 'squeeze'
|
||||
2. Install prerequisites for development environment:
|
||||
|
||||
apt-get -y install build-essential subversion debhelper autotools-dev \
|
||||
doxygen check pkg-config libnss3-dev groff quilt dpatch libxml2-dev \
|
||||
libncurses5-dev libslang2-dev libldap2-dev xsltproc python-pexpect \
|
||||
python-pycurl libdbus-1-dev openipmi sg3-utils libnet-snmp-perl \
|
||||
libnet-telnet-perl snmp python-openssl libxml2-utils automake autoconf \
|
||||
libsqlite3-dev sqlite3 libfuse-dev libglib2.0-dev librrd-dev \
|
||||
librrds-perl rrdcached lintian libdevel-cycle-perl libjson-perl \
|
||||
liblinux-inotify2-perl libio-stringy-perl unzip fuse-utils \
|
||||
libcrypt-openssl-random-perl libcrypt-openssl-rsa-perl \
|
||||
libauthen-pam-perl libterm-readline-gnu-perl libssl-dev open-iscsi \
|
||||
libapache2-mod-perl2 libfilesys-df-perl libfile-readbackwards-perl \
|
||||
libpci-dev texi2html libgnutls-dev libsdl1.2-dev bridge-utils \
|
||||
libvncserver0 rpm2cpio apache2-mpm-prefork libintl-perl \
|
||||
libapache2-request-perl libnet-dns-perl vlan libio-socket-ssl-perl \
|
||||
libfile-sync-perl ifenslave-2.6 libnet-ldap-perl console-data
|
||||
|
||||
3. Download and install the following svn modules in order from top to bottom:
|
||||
|
||||
svn://devel.proxmox.com/var/svn/pve/
|
||||
|
||||
libqb/trunk
|
||||
corosync/trunk
|
||||
openais/trunk
|
||||
pve-common/trunk
|
||||
pve-cluster/trunk
|
||||
redhat-cluster/trunk
|
||||
pve-access-control/trunk
|
||||
pve-storage/pve2
|
||||
pve-qemu-kvm/pve2
|
||||
qemu-server/pve2
|
||||
vncterm/pve2
|
||||
pve-manager/pve2
|
||||
pve-kernel-2.6.32-rh/pve2
|
||||
|
||||
Most source can be installed with 'make dinstall' command.
|
||||
|
||||
4. Reboot the system.
|
||||
5. Learn to use the quilt patch scripts.
|
||||
6. Happy coding.
|
||||
|
||||
There is an experimental package containing the API documentation
|
||||
as ExtJS application:
|
||||
|
||||
pve2-api-doc/trunk
|
||||
|
||||
|
||||
REST vs. SOAP
|
||||
=============
|
||||
|
||||
We decided to change our SOAP API (1.X) and use a REST like API. The
|
||||
concept is described in [1] (Resource Oriented Architecture
|
||||
(ROA)). The main advantage is that we are able to remove a lot of code
|
||||
(the whole SOAP stack) to reduce software complexity.
|
||||
|
||||
We also moved away from server side content generation. Instead we use
|
||||
the ExtJS Rich Internet Application Framework
|
||||
(http://www.sencha.com).
|
||||
|
||||
That framework, like any other AJAX toolkit, can talk directly to the
|
||||
REST API using JSON. So we were able to remove the server side
|
||||
template toolkit completely.
|
||||
|
||||
JSON and JSON Schema
|
||||
====================
|
||||
|
||||
We use JSON as data format, because it is simple and parse-able by any
|
||||
web browser.
|
||||
|
||||
Additionally, we use JSON Schema [2] to formally describe our API. So
|
||||
we can automatically generate the whole API Documentation, and we can
|
||||
verify all parameters and return values.
|
||||
|
||||
An great side effect was that we are able to use JSON Schema to
|
||||
produce command line argument parsers automatically. In fact, the REST
|
||||
API and the command line tools use the same code.
|
||||
|
||||
Object linkage is done using the JSON Hyper Schema (links property).
|
||||
|
||||
A small utility called 'pvesh' exposes the whole REST API on the command
|
||||
line.
|
||||
|
||||
So here is a summary of the advantage:
|
||||
|
||||
- easy, human readable data format (native web browser format)
|
||||
- automatic parameter verification (we can also verify return values)
|
||||
- automatic generation of API documentation
|
||||
- easy way to create command line tools (using same API).
|
||||
|
||||
API Implementation (PVE::RESTHandler)
|
||||
=====================================
|
||||
|
||||
All classes exposing methods on the API use PVE::RESTHandler as base class.
|
||||
|
||||
use base qw(PVE::RESTHandler);
|
||||
|
||||
To expose methods, one needs to call register_method():
|
||||
|
||||
__PACKAGE__->register_method ($schema);
|
||||
|
||||
Where $schema is a PVE method schema as described in
|
||||
PVE::JSONSchema. It includes a description of parameters and return
|
||||
values, and a reference to the actual code
|
||||
|
||||
__PACKAGE__->register_method ({
|
||||
name => 'echo',
|
||||
path => 'echo',
|
||||
method => 'GET',
|
||||
description => "simple return value of parameter 'text'",
|
||||
parameters => {
|
||||
additionalProperties => 0,
|
||||
properties => {
|
||||
text => {
|
||||
type => 'string',
|
||||
}
|
||||
},
|
||||
},
|
||||
returns => {
|
||||
type => 'string',
|
||||
},
|
||||
code => sub {
|
||||
my ($conn, $resp, $param) = @_;
|
||||
|
||||
return $param->{text};
|
||||
}
|
||||
});
|
||||
|
||||
The 'name' property is only used if you want to call the method
|
||||
directly from Perl. You can do that using:
|
||||
|
||||
print __PACKAGE__->echo({ text => "a test" });
|
||||
|
||||
We use Perl's AUTOLOAD feature to implement this. Note: You need to
|
||||
pass parameters a HASH reference.
|
||||
|
||||
There is a special helper method called cli_handler(). This is used by
|
||||
the CLIHandler Class for command line tools, where you want to pass
|
||||
arguments as array of strings. This uses Getopt::Long to parse parameters.
|
||||
|
||||
There is a second way to map names to methods - using the 'path'
|
||||
property. And you can register subclasses. That way you can set up a
|
||||
filesystem like hierarchy to access methods.
|
||||
|
||||
Here is an example:
|
||||
----------------------------
|
||||
package C1;
|
||||
|
||||
__PACKAGE__->register_method ({
|
||||
subclass => "C2",
|
||||
path => 'sub2',
|
||||
});
|
||||
|
||||
|
||||
__PACKAGE__->register_method ({
|
||||
name => 'list1',
|
||||
path => 'index',
|
||||
method => 'GET',
|
||||
...
|
||||
});
|
||||
|
||||
package C2;
|
||||
|
||||
__PACKAGE__->register_method ({
|
||||
name => 'list2',
|
||||
path => 'index',
|
||||
method => 'GET',
|
||||
...
|
||||
});
|
||||
-------------------------------
|
||||
|
||||
The utily method find_handler (in PVE::RESTHandler) can be use to do
|
||||
'path' related method lookups.
|
||||
|
||||
C1->find_handler('GET', "/index") => C1::list1
|
||||
C1->find_handler('GET', "/sub2/index") => C2::list2
|
||||
|
||||
The HTTP server use the URL (a path) to find the corresponding method.
|
||||
|
||||
|
||||
References
|
||||
==========
|
||||
[1] RESTful Web Services
|
||||
Web services for the real world
|
||||
|
||||
By
|
||||
Leonard Richardson, Sam Ruby
|
||||
Publisher:
|
||||
O'Reilly Media
|
||||
Released:
|
||||
May 2007
|
||||
|
||||
[2] JSON Schema links: http://json-schema.org/
|
||||
331
data/ChangeLog
Normal file
331
data/ChangeLog
Normal file
@ -0,0 +1,331 @@
|
||||
2011-08-17 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/PodParser.pm: split out pod generation code
|
||||
|
||||
2011-08-16 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (dump_config): a simply way to generate
|
||||
key/value configuration files.
|
||||
|
||||
2011-08-15 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (parse_config): a simply way to verify
|
||||
key/value configuration files.
|
||||
|
||||
2011-08-11 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/*: remove useless 'fixme' comments.
|
||||
|
||||
* PVE/Tools.pm (lock_file): removed $text parameter (to simplify
|
||||
code), better timeout error message.
|
||||
|
||||
2011-08-10 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/RESTHandler.pm (cli_handler): renamed cli_handler2 to
|
||||
cli_handler.
|
||||
|
||||
* PVE/CLIHandler.pm (print_pod_manpage): add method to generate
|
||||
pod base manual pages (SYNOPSIS is auto generated).
|
||||
|
||||
2011-08-05 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/CLIHandler.pm (help): avoid warning on undefined commands
|
||||
|
||||
2011-08-02 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/CLIHandler.pm (handle_cmd): auto-complete commands
|
||||
|
||||
2011-07-28 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (get_standard_option): register option
|
||||
'pve-node-list'
|
||||
|
||||
* PVE/Tools.pm (run_command): fix $laststderr (do not suppress
|
||||
last line in some rare cases).
|
||||
|
||||
2011-07-14 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (encode_text, decode_text): useful functions to
|
||||
store comments in config files (uri encoding)
|
||||
|
||||
2011-07-04 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (check_format): allow to add '-opt' to format
|
||||
specifier which allows to pass empty strings. For
|
||||
example format 'email' always requires a valid email address,
|
||||
whereas format 'email-opt' also accepts an emtpy string.
|
||||
|
||||
2011-06-21 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (run_command): use alarm to impl. timeout
|
||||
|
||||
* PVE/RESTHandler.pm (api_dump): new - used to generate docu
|
||||
|
||||
* PVE/Tools.pm (upid_decode): fix upid parser
|
||||
|
||||
2011-05-10 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/RESTHandler.pm (handle): untaint parameters after validate
|
||||
|
||||
2011-03-23 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (debmirrors): return list of debian mirrors (per
|
||||
country).
|
||||
|
||||
2011-03-21 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/INotify.pm (read_active_workers): simply skip entries we
|
||||
cannot parse, add additional 'id' field to upid
|
||||
|
||||
2011-03-18 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (upid_read_status): read/parse last line from
|
||||
worker output file.
|
||||
|
||||
2011-03-17 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/INotify.pm (read/write_active_workers): list/update list of
|
||||
active/recent worker processes
|
||||
|
||||
2011-03-16 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (upid_*): add code to handle worker processes.
|
||||
|
||||
2011-03-14 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (upid_encode,upid_decode): moved from
|
||||
pve-access-control.
|
||||
|
||||
2011-03-09 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/ProcFSTools.pm (read_proc_net_dev): first impl.
|
||||
|
||||
* PVE/Tools.pm (df): implement interruptible version of 'df'
|
||||
(workd with timeout on NFS)
|
||||
|
||||
2011-03-03 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/ProcFSTools.pm (read_memory_usage): memory usage of current
|
||||
process
|
||||
|
||||
2011-02-22 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (pve_verify_email): verify email address
|
||||
|
||||
2011-02-16 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/RPCEnvironment.pm: moved to pve-access-control
|
||||
|
||||
2011-02-15 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (template_replace): support simple uri templates
|
||||
|
||||
* PVE/JSONSchema.pm: add permissions property (path,
|
||||
privs). Allows use to specify required access permissions.
|
||||
|
||||
2011-02-14 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/ProcFSTools.pm: impl. new helpers read_loadavg(),
|
||||
read_meminfo() and read_proc_stat().
|
||||
|
||||
2011-02-08 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/INotify.pm (update_file): use PVE::Tools, changed interface
|
||||
(update_etc_resolv_conf): do not touch other options (like
|
||||
'sortlist' and 'options'),
|
||||
(read_etc_timezone): add timezone parser
|
||||
(write_etc_timezone): add timezone writer
|
||||
|
||||
* PVE/JSONSchema.pm (pve_verify_ipv4): register IPv4 format.
|
||||
|
||||
2011-02-02 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/Tools.pm (next_vnc_port): moved from qemu-server
|
||||
|
||||
2011-01-28 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/SafeSyslog.pm (initlog): enable default for facility.
|
||||
|
||||
2011-01-25 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* PVE/JSONSchema.pm (get_options): make boolean arguments
|
||||
optional, allow "true|yes|on|false|no|off|0|1"
|
||||
|
||||
2011-01-19 root <root@maui.maurer-it.com>
|
||||
|
||||
* PVE/SafeSyslog.pm (tag): a way to read the log tag
|
||||
|
||||
2011-01-12 root <root@maui.maurer-it.com>
|
||||
|
||||
* INotify.pm (read/write_etc_resolv_conf): functions to read/write
|
||||
resolv.config
|
||||
(nodename): new method to read actual node name (hostname)
|
||||
|
||||
2010-11-09 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (check_type): only allow '0' and '1' for boolean
|
||||
values, because we often use perl directly to test (if
|
||||
($param->{force}) ...)
|
||||
|
||||
* INotify.pm (read_vmlist): add parser for vmlist file.
|
||||
|
||||
2010-11-08 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* INotify.pm (read_etc_hostname): impl. read/write /etc/hostname
|
||||
|
||||
2010-09-17 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (AUTOLOAD): bug fix.
|
||||
(usage_str): add info about required options.
|
||||
|
||||
2010-09-15 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RPCEnvironment.pm (fork_worker): moved from PVE::Utils
|
||||
(get_remote_node_ip): new helper
|
||||
|
||||
* ProcFSTools.pm (read_proc_starttime): moved from PVE::Utils
|
||||
|
||||
2010-09-14 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (get_standard_option): allow to set defaults.
|
||||
|
||||
* RPCEnvironment.pm (get_nodelist): new helper
|
||||
|
||||
* RESTHandler.pm (register_method): do not validate method (that
|
||||
is too slow - delays startup).
|
||||
(validate_method_schemas): new method to validate all registered
|
||||
methods. We can no do that once when we create a package.
|
||||
|
||||
2010-09-13 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (validate): add minLength/maxLength to the default
|
||||
schema.
|
||||
|
||||
2010-09-10 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* INotify.pm (ccache_info): fix serious bug by duplicating cache info
|
||||
entry.
|
||||
|
||||
* CLIHandler.pm (print_usage_short): group command by class
|
||||
|
||||
* JSONSchema.pm (register_standard_option, get_standard_option): a
|
||||
way to register/get commom schemas by name.
|
||||
|
||||
* Tools.pm (extract_param): new helper
|
||||
|
||||
* CLIHandler.pm: new verbose option for help.
|
||||
|
||||
* Tools.pm (kvmkeymaps): moved from PVE::Utils.
|
||||
|
||||
* JSONSchema.pm: add a new attribute caled 'typetext' (any better
|
||||
name?), used to generate nice docs.
|
||||
|
||||
2010-09-08 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (usage_str): only print indexed options
|
||||
once (-vlan\d+ -scsi\d+)
|
||||
(usage_str): sort options
|
||||
(usage_str): use Text::Wrap to format output
|
||||
|
||||
* JSONSchema.pm (check_format): revert previous change - to keep
|
||||
it simply
|
||||
|
||||
2010-09-07 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (check_format): return parsed value
|
||||
|
||||
* ProcFSTools.pm: new file - utilities to read /proc/
|
||||
|
||||
* ProcFSTools.pm (get_cpu_info): read cpu info from /proc
|
||||
|
||||
2010-08-27 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (cli_handler2): simplify code - allow to pass
|
||||
optional parameters as arguments.
|
||||
(find_handler): return matched path template as 3rd argument
|
||||
|
||||
2010-08-26 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (usage_str): new '$hidepw' parameter to correctly
|
||||
handle hidden password parameter.
|
||||
|
||||
* README.dev: update docu about find_handler()
|
||||
|
||||
* RESTHandler.pm (find_handler): use '$path' instead of strange
|
||||
'$stack' parameter.
|
||||
|
||||
2010-08-25 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* Exception.pm (raise_param_exc): allow to specify usage information.
|
||||
|
||||
* RESTHandler.pm (usage_str): first try to autogenerate usage information.
|
||||
(cli_handler2): experimental code used by new CLIHandler.pm
|
||||
|
||||
* CLIHandler.pm: new class for command line tools like 'pvesm' -
|
||||
automatically create 'help' and usage information.
|
||||
|
||||
2010-08-24 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (handle): remove $conn parameter. We use new
|
||||
RPCEnvironment class to pass environment values.
|
||||
|
||||
2010-08-20 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (register_method): allow us to use regex in the
|
||||
path template, for example path => '{method:(lvm|iscsi|nfs)}'
|
||||
|
||||
* JSONSchema.pm (validate): new 'fragmentDelimiter' option.
|
||||
|
||||
* RESTHandler.pm (find_handler): remove 'require' - we load
|
||||
statically instead
|
||||
|
||||
2010-08-17 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (get_options): we use option type 's' for boolean
|
||||
values - that way we can pass true and false (and any alias for
|
||||
them)
|
||||
|
||||
* Exception.pm (raise_param_exc): new helper function
|
||||
|
||||
2010-08-16 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* Tools.pm (run_command): remove 'ticket' parameter - I think we
|
||||
do not need it.
|
||||
(file_read_firstline): new function to read first line of file -
|
||||
moved fron Storage.pm
|
||||
(trim): new trim() command
|
||||
|
||||
* RESTHandler.pm (handle): remove ugly $resp parameter - we can
|
||||
now use the new Expection object to return better error info.
|
||||
|
||||
* JSONSchema.pm (validate): use new PVE::Exception::raise() in validate()
|
||||
|
||||
* Exception.pm (new): finalize implementation
|
||||
|
||||
2010-08-13 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* JSONSchema.pm (register_format): implement a way to register
|
||||
'format' verification methods.
|
||||
(check_format): make it possible to automagically check comman
|
||||
separated lists.
|
||||
|
||||
2010-08-12 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (AUTOLOAD): cache autoload
|
||||
|
||||
2010-08-11 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* RESTHandler.pm (cli_handler): helper function to call method
|
||||
directly, parsing command line args using new JSONSchema::get_options()
|
||||
|
||||
* JSONSchema.pm (get_options): a way to parse command line
|
||||
parameters, using a schema to configure Getopt::Long
|
||||
|
||||
2010-08-10 Proxmox Support Team <support@proxmox.com>
|
||||
|
||||
* INotify.pm (parse_ccache_options): new shadow option
|
||||
(parse_ccache_options): new perm option (set file perm (example
|
||||
0664));
|
||||
(write_file): do not use PVE::AtomicFile, correctly set file
|
||||
permissions
|
||||
|
||||
35
data/Makefile
Normal file
35
data/Makefile
Normal file
@ -0,0 +1,35 @@
|
||||
|
||||
PREFIX=/usr
|
||||
BINDIR=${PREFIX}/bin
|
||||
MANDIR=${PREFIX}/share/man
|
||||
DOCDIR=${PREFIX}/share/doc
|
||||
MAN1DIR=${MANDIR}/man1/
|
||||
PERLDIR=${PREFIX}/share/perl5
|
||||
|
||||
LIB_SOURCES= \
|
||||
ProcFSTools.pm \
|
||||
PodParser.pm \
|
||||
CLIHandler.pm \
|
||||
RESTHandler.pm \
|
||||
JSONSchema.pm \
|
||||
SafeSyslog.pm \
|
||||
AtomicFile.pm \
|
||||
INotify.pm \
|
||||
Tools.pm \
|
||||
Exception.pm
|
||||
|
||||
all:
|
||||
|
||||
.PHONY: install
|
||||
install:
|
||||
install -d -m 0755 ${DESTDIR}${PERLDIR}/PVE
|
||||
for i in ${LIB_SOURCES}; do install -D -m 0644 PVE/$$i ${DESTDIR}${PERLDIR}/PVE/$$i; done
|
||||
|
||||
|
||||
.PHONY: clean
|
||||
clean:
|
||||
rm -rf *~
|
||||
|
||||
.PHONY: distclean
|
||||
distclean: clean
|
||||
|
||||
18
data/PVE/AtomicFile.pm
Normal file
18
data/PVE/AtomicFile.pm
Normal file
@ -0,0 +1,18 @@
|
||||
package PVE::AtomicFile;
|
||||
|
||||
use strict;
|
||||
use IO::AtomicFile;
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw(IO::AtomicFile);
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = $class->SUPER::new(@_);
|
||||
$self;
|
||||
}
|
||||
|
||||
|
||||
sub DESTROY {
|
||||
# dont close atomatically (explicit close required to commit changes)
|
||||
}
|
||||
195
data/PVE/CLIHandler.pm
Normal file
195
data/PVE/CLIHandler.pm
Normal file
@ -0,0 +1,195 @@
|
||||
package PVE::CLIHandler;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use PVE::Exception qw(raise raise_param_exc);
|
||||
use PVE::RESTHandler;
|
||||
use PVE::PodParser;
|
||||
|
||||
use base qw(PVE::RESTHandler);
|
||||
|
||||
my $cmddef;
|
||||
my $exename;
|
||||
|
||||
my $expand_command_name = sub {
|
||||
my ($def, $cmd) = @_;
|
||||
|
||||
if (!$def->{$cmd}) {
|
||||
my $expanded;
|
||||
for my $k (keys(%$def)) {
|
||||
if ($k =~ m/^$cmd/) {
|
||||
if ($expanded) {
|
||||
$expanded = undef; # more than one match
|
||||
last;
|
||||
} else {
|
||||
$expanded = $k;
|
||||
}
|
||||
}
|
||||
}
|
||||
$cmd = $expanded if $expanded;
|
||||
}
|
||||
return $cmd;
|
||||
};
|
||||
|
||||
__PACKAGE__->register_method ({
|
||||
name => 'help',
|
||||
path => 'help',
|
||||
method => 'GET',
|
||||
description => "Get help about specified command.",
|
||||
parameters => {
|
||||
additionalProperties => 0,
|
||||
properties => {
|
||||
cmd => {
|
||||
description => "Command name",
|
||||
type => 'string',
|
||||
optional => 1,
|
||||
},
|
||||
verbose => {
|
||||
description => "Verbose output format.",
|
||||
type => 'boolean',
|
||||
optional => 1,
|
||||
},
|
||||
},
|
||||
},
|
||||
returns => { type => 'null' },
|
||||
|
||||
code => sub {
|
||||
my ($param) = @_;
|
||||
|
||||
die "not initialized" if !($cmddef && $exename);
|
||||
|
||||
my $cmd = $param->{cmd};
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
$cmd = &$expand_command_name($cmddef, $cmd);
|
||||
|
||||
my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd} || []};
|
||||
|
||||
raise_param_exc({ cmd => "no such command '$cmd'"}) if !$class;
|
||||
|
||||
|
||||
my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, $verbose ? 'full' : 'short');
|
||||
if ($verbose) {
|
||||
print "$str\n";
|
||||
} else {
|
||||
print "USAGE: $str\n";
|
||||
}
|
||||
|
||||
return undef;
|
||||
|
||||
}});
|
||||
|
||||
sub print_pod_manpage {
|
||||
my ($podfn) = @_;
|
||||
|
||||
die "not initialized" if !($cmddef && $exename);
|
||||
die "no pod file specified" if !$podfn;
|
||||
|
||||
my $synopsis = "";
|
||||
|
||||
$synopsis .= " $exename <COMMAND> [ARGS] [OPTIONS]\n\n";
|
||||
|
||||
my $style = 'full'; # or should we use 'short'?
|
||||
my $oldclass;
|
||||
foreach my $cmd (sorted_commands()) {
|
||||
my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}};
|
||||
my $str = $class->usage_str($name, "$exename $cmd", $arg_param,
|
||||
$uri_param, $style);
|
||||
$str =~ s/^USAGE: //;
|
||||
|
||||
$synopsis .= "\n" if $oldclass && $oldclass ne $class;
|
||||
$str =~ s/\n/\n /g;
|
||||
$synopsis .= " $str\n\n";
|
||||
$oldclass = $class;
|
||||
}
|
||||
|
||||
$synopsis .= "\n";
|
||||
|
||||
my $parser = PVE::PodParser->new();
|
||||
$parser->{include}->{synopsis} = $synopsis;
|
||||
$parser->parse_from_file($podfn);
|
||||
}
|
||||
|
||||
sub print_usage_verbose {
|
||||
|
||||
die "not initialized" if !($cmddef && $exename);
|
||||
|
||||
print "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n\n";
|
||||
|
||||
foreach my $cmd (sort keys %$cmddef) {
|
||||
my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}};
|
||||
my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'full');
|
||||
print "$str\n\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub sorted_commands {
|
||||
return sort { ($cmddef->{$a}->[0] cmp $cmddef->{$b}->[0]) || ($a cmp $b)} keys %$cmddef;
|
||||
}
|
||||
|
||||
sub print_usage_short {
|
||||
my ($fd, $msg) = @_;
|
||||
|
||||
die "not initialized" if !($cmddef && $exename);
|
||||
|
||||
print $fd "ERROR: $msg\n" if $msg;
|
||||
print $fd "USAGE: $exename <COMMAND> [ARGS] [OPTIONS]\n";
|
||||
|
||||
my $oldclass;
|
||||
foreach my $cmd (sorted_commands()) {
|
||||
my ($class, $name, $arg_param, $uri_param) = @{$cmddef->{$cmd}};
|
||||
my $str = $class->usage_str($name, "$exename $cmd", $arg_param, $uri_param, 'short');
|
||||
print $fd "\n" if $oldclass && $oldclass ne $class;
|
||||
print $fd " $str";
|
||||
$oldclass = $class;
|
||||
}
|
||||
}
|
||||
|
||||
sub handle_cmd {
|
||||
my ($def, $cmdname, $cmd, $args, $pwcallback, $podfn) = @_;
|
||||
|
||||
$cmddef = $def;
|
||||
$exename = $cmdname;
|
||||
|
||||
$cmddef->{help} = [ __PACKAGE__, 'help', ['cmd'] ];
|
||||
|
||||
if (!$cmd) {
|
||||
print_usage_short (\*STDERR, "no command specified");
|
||||
exit (-1);
|
||||
} elsif ($cmd eq 'verifyapi') {
|
||||
PVE::RESTHandler::validate_method_schemas();
|
||||
return;
|
||||
} elsif ($cmd eq 'printmanpod') {
|
||||
print_pod_manpage($podfn);
|
||||
return;
|
||||
}
|
||||
|
||||
$cmd = &$expand_command_name($cmddef, $cmd);
|
||||
|
||||
my ($class, $name, $arg_param, $uri_param, $outsub) = @{$cmddef->{$cmd} || []};
|
||||
|
||||
if (!$class) {
|
||||
print_usage_short (\*STDERR, "unknown command '$cmd'");
|
||||
exit (-1);
|
||||
}
|
||||
|
||||
my $prefix = "$exename $cmd";
|
||||
my $res = $class->cli_handler($prefix, $name, \@ARGV, $arg_param, $uri_param, $pwcallback);
|
||||
if ($outsub) {
|
||||
&$outsub($res);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
119
data/PVE/Exception.pm
Executable file
119
data/PVE/Exception.pm
Executable file
@ -0,0 +1,119 @@
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
# 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", ...} );
|
||||
|
||||
package PVE::Exception;
|
||||
|
||||
use strict;
|
||||
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};
|
||||
|
||||
@EXPORT_OK = qw(raise raise_param_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 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;
|
||||
898
data/PVE/INotify.pm
Normal file
898
data/PVE/INotify.pm
Normal file
@ -0,0 +1,898 @@
|
||||
package PVE::INotify;
|
||||
|
||||
# todo: maybe we do not need update_file() ?
|
||||
|
||||
use strict;
|
||||
use POSIX;
|
||||
use IO::File;
|
||||
use IO::Dir;
|
||||
use File::stat;
|
||||
use File::Basename;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use PVE::SafeSyslog;
|
||||
use PVE::Exception qw(raise_param_exc);
|
||||
use PVE::Tools;
|
||||
use Storable qw(dclone);
|
||||
use Linux::Inotify2;
|
||||
use base 'Exporter';
|
||||
use JSON;
|
||||
|
||||
our @EXPORT_OK = qw(read_file write_file register_file);
|
||||
|
||||
my $ccache;
|
||||
my $ccachemap;
|
||||
my $ccacheregex;
|
||||
my $inotify;
|
||||
my $inotify_pid = 0;
|
||||
my $versions;
|
||||
my $shadowfiles = {
|
||||
'/etc/network/interfaces' => '/etc/network/interfaces.new',
|
||||
};
|
||||
|
||||
# to enable cached operation, you need to call 'inotify_init'
|
||||
# inotify handles are a limited resource, so use with care (only
|
||||
# enable the cache if you really need it)
|
||||
|
||||
# Note: please close the inotify handle after you fork
|
||||
|
||||
sub ccache_default_writer {
|
||||
my ($filename, $data) = @_;
|
||||
|
||||
die "undefined config writer for '$filename' :ERROR";
|
||||
}
|
||||
|
||||
sub ccache_default_parser {
|
||||
my ($filename, $srcfd) = @_;
|
||||
|
||||
die "undefined config reader for '$filename' :ERROR";
|
||||
}
|
||||
|
||||
sub ccache_compute_diff {
|
||||
my ($filename, $shadow) = @_;
|
||||
|
||||
my $diff = '';
|
||||
|
||||
open (TMP, "diff -b -N -u '$filename' '$shadow'|");
|
||||
|
||||
while (my $line = <TMP>) {
|
||||
$diff .= $line;
|
||||
}
|
||||
|
||||
close (TMP);
|
||||
|
||||
$diff = undef if !$diff;
|
||||
|
||||
return $diff;
|
||||
}
|
||||
|
||||
sub ccache_info {
|
||||
my ($filename) = @_;
|
||||
|
||||
foreach my $uid (keys %$ccacheregex) {
|
||||
my $ccinfo = $ccacheregex->{$uid};
|
||||
my $dir = $ccinfo->{dir};
|
||||
my $regex = $ccinfo->{regex};
|
||||
if ($filename =~ m|^$dir/+$regex$|) {
|
||||
if (!$ccache->{$filename}) {
|
||||
my $cp = {};
|
||||
while (my ($k, $v) = each %$ccinfo) {
|
||||
$cp->{$k} = $v;
|
||||
}
|
||||
$ccache->{$filename} = $cp;
|
||||
}
|
||||
return ($ccache->{$filename}, $filename);
|
||||
}
|
||||
}
|
||||
|
||||
$filename = $ccachemap->{$filename} if defined ($ccachemap->{$filename});
|
||||
|
||||
die "file '$filename' not added :ERROR" if !defined ($ccache->{$filename});
|
||||
|
||||
return ($ccache->{$filename}, $filename);
|
||||
}
|
||||
|
||||
sub write_file {
|
||||
my ($fileid, $data, $full) = @_;
|
||||
|
||||
my ($ccinfo, $filename) = ccache_info($fileid);
|
||||
|
||||
my $writer = $ccinfo->{writer};
|
||||
|
||||
my $realname = $filename;
|
||||
|
||||
my $shadow;
|
||||
if ($shadow = $shadowfiles->{$filename}) {
|
||||
$realname = $shadow;
|
||||
}
|
||||
|
||||
my $perm = $ccinfo->{perm} || 0644;
|
||||
|
||||
my $tmpname = "$realname.tmp.$$";
|
||||
|
||||
my $res;
|
||||
eval {
|
||||
my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm);
|
||||
die "unable to open file '$tmpname' - $!\n" if !$fh;
|
||||
|
||||
$res = &$writer($filename, $fh, $data);
|
||||
|
||||
die "closing file '$tmpname' failed - $!\n" unless close $fh;
|
||||
};
|
||||
my $err = $@;
|
||||
|
||||
$ccinfo->{version} = undef;
|
||||
|
||||
if ($err) {
|
||||
unlink $tmpname;
|
||||
die $err;
|
||||
}
|
||||
|
||||
if (!rename($tmpname, $realname)) {
|
||||
my $msg = "close (rename) atomic file '$filename' failed: $!\n";
|
||||
unlink $tmpname;
|
||||
die $msg;
|
||||
}
|
||||
|
||||
my $diff;
|
||||
if ($shadow && $full) {
|
||||
$diff = ccache_compute_diff ($filename, $shadow);
|
||||
}
|
||||
|
||||
if ($full) {
|
||||
return { data => $res, changes => $diff };
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub update_file {
|
||||
my ($fileid, $data, @args) = @_;
|
||||
|
||||
my ($ccinfo, $filename) = ccache_info($fileid);
|
||||
|
||||
my $update = $ccinfo->{update};
|
||||
|
||||
die "unable to update/merge data" if !$update;
|
||||
|
||||
my $lkfn = "$filename.lock";
|
||||
|
||||
my $timeout = 10;
|
||||
|
||||
my $fd;
|
||||
|
||||
my $code = sub {
|
||||
|
||||
$fd = IO::File->new ($filename, "r");
|
||||
|
||||
my $new = &$update($filename, $fd, $data, @args);
|
||||
|
||||
if (defined($new)) {
|
||||
PVE::Tools::file_set_contents($filename, $new, $ccinfo->{perm});
|
||||
} else {
|
||||
unlink $filename;
|
||||
}
|
||||
};
|
||||
|
||||
PVE::Tools::lock_file($lkfn, $timeout, $code);
|
||||
my $err = $@;
|
||||
|
||||
close($fd) if defined($fd);
|
||||
|
||||
die $err if $err;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub discard_changes {
|
||||
my ($fileid, $full) = @_;
|
||||
|
||||
my ($ccinfo, $filename) = ccache_info($fileid);
|
||||
|
||||
if (my $copy = $shadowfiles->{$filename}) {
|
||||
unlink $copy;
|
||||
}
|
||||
|
||||
return read_file ($filename, $full);
|
||||
}
|
||||
|
||||
sub read_file {
|
||||
my ($fileid, $full) = @_;
|
||||
|
||||
my $parser;
|
||||
|
||||
my ($ccinfo, $filename) = ccache_info($fileid);
|
||||
|
||||
$parser = $ccinfo->{parser};
|
||||
|
||||
my $fd;
|
||||
my $shadow;
|
||||
|
||||
poll() if $inotify; # read new inotify events
|
||||
|
||||
$versions->{$filename} = 0 if !defined ($versions->{$filename});
|
||||
|
||||
my $cver = $versions->{$filename};
|
||||
|
||||
if (my $copy = $shadowfiles->{$filename}) {
|
||||
if ($fd = IO::File->new ($copy, "r")) {
|
||||
$shadow = $copy;
|
||||
} else {
|
||||
$fd = IO::File->new ($filename, "r");
|
||||
}
|
||||
} else {
|
||||
$fd = IO::File->new ($filename, "r");
|
||||
}
|
||||
|
||||
my $acp = $ccinfo->{always_call_parser};
|
||||
|
||||
if (!$fd) {
|
||||
$ccinfo->{version} = undef;
|
||||
$ccinfo->{data} = undef;
|
||||
$ccinfo->{diff} = undef;
|
||||
return undef if !$acp;
|
||||
}
|
||||
|
||||
my $noclone = $ccinfo->{noclone};
|
||||
|
||||
# file unchanged?
|
||||
if (!$ccinfo->{nocache} &&
|
||||
$inotify && $versions->{$filename} &&
|
||||
defined ($ccinfo->{data}) &&
|
||||
defined ($ccinfo->{version}) &&
|
||||
($ccinfo->{readonce} ||
|
||||
($ccinfo->{version} == $versions->{$filename}))) {
|
||||
|
||||
my $ret;
|
||||
if (!$noclone && ref ($ccinfo->{data})) {
|
||||
$ret->{data} = dclone ($ccinfo->{data});
|
||||
} else {
|
||||
$ret->{data} = $ccinfo->{data};
|
||||
}
|
||||
$ret->{changes} = $ccinfo->{diff};
|
||||
|
||||
return $full ? $ret : $ret->{data};
|
||||
}
|
||||
|
||||
my $diff;
|
||||
|
||||
if ($shadow) {
|
||||
$diff = ccache_compute_diff ($filename, $shadow);
|
||||
}
|
||||
|
||||
my $res = &$parser($filename, $fd);
|
||||
|
||||
if (!$ccinfo->{nocache}) {
|
||||
$ccinfo->{version} = $cver;
|
||||
}
|
||||
|
||||
# we cache data with references, so we always need to
|
||||
# dclone this data. Else the original data may get
|
||||
# modified.
|
||||
$ccinfo->{data} = $res;
|
||||
|
||||
# also store diff
|
||||
$ccinfo->{diff} = $diff;
|
||||
|
||||
my $ret;
|
||||
if (!$noclone && ref ($ccinfo->{data})) {
|
||||
$ret->{data} = dclone ($ccinfo->{data});
|
||||
} else {
|
||||
$ret->{data} = $ccinfo->{data};
|
||||
}
|
||||
$ret->{changes} = $ccinfo->{diff};
|
||||
|
||||
return $full ? $ret : $ret->{data};
|
||||
}
|
||||
|
||||
sub parse_ccache_options {
|
||||
my ($ccinfo, %options) = @_;
|
||||
|
||||
foreach my $opt (keys %options) {
|
||||
my $v = $options{$opt};
|
||||
if ($opt eq 'readonce') {
|
||||
$ccinfo->{$opt} = $v;
|
||||
} elsif ($opt eq 'nocache') {
|
||||
$ccinfo->{$opt} = $v;
|
||||
} elsif ($opt eq 'shadow') {
|
||||
$ccinfo->{$opt} = $v;
|
||||
} elsif ($opt eq 'perm') {
|
||||
$ccinfo->{$opt} = $v;
|
||||
} elsif ($opt eq 'noclone') {
|
||||
# noclone flag for large read-only data chunks like aplinfo
|
||||
$ccinfo->{$opt} = $v;
|
||||
} elsif ($opt eq 'always_call_parser') {
|
||||
# when set, we call parser even when the file does not exists.
|
||||
# this allows the parser to return some default
|
||||
$ccinfo->{$opt} = $v;
|
||||
} else {
|
||||
die "internal error - unsupported option '$opt'";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub register_file {
|
||||
my ($id, $filename, $parser, $writer, $update, %options) = @_;
|
||||
|
||||
die "can't register file after initify_init" if $inotify;
|
||||
|
||||
die "file '$filename' already added :ERROR" if defined ($ccache->{$filename});
|
||||
die "ID '$id' already used :ERROR" if defined ($ccachemap->{$id});
|
||||
|
||||
my $ccinfo = {};
|
||||
|
||||
$ccinfo->{id} = $id;
|
||||
$ccinfo->{parser} = $parser || \&ccache_default_parser;
|
||||
$ccinfo->{writer} = $writer || \&ccache_default_writer;
|
||||
$ccinfo->{update} = $update;
|
||||
|
||||
parse_ccache_options($ccinfo, %options);
|
||||
|
||||
if ($options{shadow}) {
|
||||
$shadowfiles->{$filename} = $options{shadow};
|
||||
}
|
||||
|
||||
$ccachemap->{$id} = $filename;
|
||||
$ccache->{$filename} = $ccinfo;
|
||||
}
|
||||
|
||||
sub register_regex {
|
||||
my ($dir, $regex, $parser, $writer, $update, %options) = @_;
|
||||
|
||||
die "can't register regex after initify_init" if $inotify;
|
||||
|
||||
my $uid = "$dir/$regex";
|
||||
die "regular expression '$uid' already added :ERROR" if defined ($ccacheregex->{$uid});
|
||||
|
||||
my $ccinfo = {};
|
||||
|
||||
$ccinfo->{dir} = $dir;
|
||||
$ccinfo->{regex} = $regex;
|
||||
$ccinfo->{parser} = $parser || \&ccache_default_parser;
|
||||
$ccinfo->{writer} = $writer || \&ccache_default_writer;
|
||||
$ccinfo->{update} = $update;
|
||||
|
||||
parse_ccache_options($ccinfo, %options);
|
||||
|
||||
$ccacheregex->{$uid} = $ccinfo;
|
||||
}
|
||||
|
||||
sub poll {
|
||||
return if !$inotify;
|
||||
|
||||
if ($inotify_pid != $$) {
|
||||
syslog ('err', "got inotify poll request in wrong process - disabling inotify");
|
||||
$inotify = undef;
|
||||
} else {
|
||||
1 while $inotify && $inotify->poll;
|
||||
}
|
||||
}
|
||||
|
||||
sub flushcache {
|
||||
foreach my $filename (keys %$ccache) {
|
||||
$ccache->{$filename}->{version} = undef;
|
||||
$ccache->{$filename}->{data} = undef;
|
||||
$ccache->{$filename}->{diff} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
sub inotify_close {
|
||||
$inotify = undef;
|
||||
}
|
||||
|
||||
sub inotify_init {
|
||||
|
||||
die "only one inotify instance allowed" if $inotify;
|
||||
|
||||
$inotify = Linux::Inotify2->new()
|
||||
|| die "Unable to create new inotify object: $!";
|
||||
|
||||
$inotify->blocking (0);
|
||||
|
||||
$versions = {};
|
||||
|
||||
my $dirhash = {};
|
||||
foreach my $fn (keys %$ccache) {
|
||||
my $dir = dirname ($fn);
|
||||
my $base = basename ($fn);
|
||||
|
||||
$dirhash->{$dir}->{$base} = $fn;
|
||||
|
||||
if (my $sf = $shadowfiles->{$fn}) {
|
||||
$base = basename ($sf);
|
||||
$dir = dirname ($sf);
|
||||
$dirhash->{$dir}->{$base} = $fn; # change version of original file!
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $uid (keys %$ccacheregex) {
|
||||
my $ccinfo = $ccacheregex->{$uid};
|
||||
$dirhash->{$ccinfo->{dir}}->{_regex} = 1;
|
||||
}
|
||||
|
||||
$inotify_pid = $$;
|
||||
|
||||
foreach my $dir (keys %$dirhash) {
|
||||
|
||||
my $evlist = IN_MODIFY|IN_ATTRIB|IN_MOVED_FROM|IN_MOVED_TO|IN_DELETE|IN_CREATE;
|
||||
$inotify->watch ($dir, $evlist, sub {
|
||||
my $e = shift;
|
||||
my $name = $e->name;
|
||||
|
||||
if ($inotify_pid != $$) {
|
||||
syslog ('err', "got inotify event in wrong process");
|
||||
}
|
||||
|
||||
if ($e->IN_ISDIR || !$name) {
|
||||
return;
|
||||
}
|
||||
|
||||
if ($e->IN_Q_OVERFLOW) {
|
||||
syslog ('info', "got inotify overflow - flushing cache");
|
||||
flushcache();
|
||||
return;
|
||||
}
|
||||
|
||||
if ($e->IN_UNMOUNT) {
|
||||
syslog ('err', "got 'unmount' event on '$name' - disabling inotify");
|
||||
$inotify = undef;
|
||||
}
|
||||
if ($e->IN_IGNORED) {
|
||||
syslog ('err', "got 'ignored' event on '$name' - disabling inotify");
|
||||
$inotify = undef;
|
||||
}
|
||||
|
||||
if ($dirhash->{$dir}->{_regex}) {
|
||||
foreach my $uid (keys %$ccacheregex) {
|
||||
my $ccinfo = $ccacheregex->{$uid};
|
||||
next if $dir ne $ccinfo->{dir};
|
||||
my $regex = $ccinfo->{regex};
|
||||
if ($regex && ($name =~ m|^$regex$|)) {
|
||||
|
||||
my $fn = "$dir/$name";
|
||||
$versions->{$fn}++;
|
||||
#print "VERSION:$fn:$versions->{$fn}\n";
|
||||
}
|
||||
}
|
||||
} elsif (my $fn = $dirhash->{$dir}->{$name}) {
|
||||
|
||||
$versions->{$fn}++;
|
||||
#print "VERSION:$fn:$versions->{$fn}\n";
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
foreach my $dir (keys %$dirhash) {
|
||||
foreach my $name (keys %{$dirhash->{$dir}}) {
|
||||
if ($name eq '_regex') {
|
||||
foreach my $uid (keys %$ccacheregex) {
|
||||
my $ccinfo = $ccacheregex->{$uid};
|
||||
next if $dir ne $ccinfo->{dir};
|
||||
my $re = $ccinfo->{regex};
|
||||
if (my $fd = IO::Dir->new ($dir)) {
|
||||
while (defined(my $de = $fd->read)) {
|
||||
if ($de =~ m/^$re$/) {
|
||||
my $fn = "$dir/$de";
|
||||
$versions->{$fn}++; # init with version
|
||||
#print "init:$fn:$versions->{$fn}\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $fn = $dirhash->{$dir}->{$name};
|
||||
$versions->{$fn}++; # init with version
|
||||
#print "init:$fn:$versions->{$fn}\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $cached_nodename;
|
||||
|
||||
sub nodename {
|
||||
|
||||
return $cached_nodename if $cached_nodename;
|
||||
|
||||
my ($sysname, $nodename) = POSIX::uname();
|
||||
|
||||
$nodename =~ s/\..*$//; # strip domain part, if any
|
||||
|
||||
die "unable to read node name\n" if !$nodename;
|
||||
|
||||
$cached_nodename = $nodename;
|
||||
|
||||
return $cached_nodename;
|
||||
}
|
||||
|
||||
sub read_etc_hostname {
|
||||
my ($filename, $fd) = @_;
|
||||
|
||||
my $hostname = <$fd>;
|
||||
|
||||
chomp $hostname;
|
||||
|
||||
$hostname =~ s/\..*$//; # strip domain part, if any
|
||||
|
||||
return $hostname;
|
||||
}
|
||||
|
||||
sub write_etc_hostname {
|
||||
my ($filename, $fh, $hostname) = @_;
|
||||
|
||||
die "write failed: $!" unless print $fh "$hostname\n";
|
||||
|
||||
return $hostname;
|
||||
}
|
||||
|
||||
register_file('hostname', "/etc/hostname",
|
||||
\&read_etc_hostname,
|
||||
\&write_etc_hostname);
|
||||
|
||||
sub read_etc_resolv_conf {
|
||||
my ($filename, $fh) = @_;
|
||||
|
||||
my $res = {};
|
||||
|
||||
my $nscount = 0;
|
||||
while (my $line = <$fh>) {
|
||||
chomp $line;
|
||||
if ($line =~ m/^(search|domain)\s+(\S+)\s*/) {
|
||||
$res->{search} = $2;
|
||||
} elsif ($line =~ m/^nameserver\s+(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})\s*/) {
|
||||
$nscount++;
|
||||
if ($nscount <= 3) {
|
||||
$res->{"dns$nscount"} = $1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub update_etc_resolv_conf {
|
||||
my ($filename, $fh, $resolv, @args) = @_;
|
||||
|
||||
my $data = "";
|
||||
|
||||
$data = "search $resolv->{search}\n"
|
||||
if $resolv->{search};
|
||||
|
||||
my $written = {};
|
||||
foreach my $k ("dns1", "dns2", "dns3") {
|
||||
my $ns = $resolv->{$k};
|
||||
if ($ns && $ns ne '0.0.0.0' && !$written->{$ns}) {
|
||||
$written->{$ns} = 1;
|
||||
$data .= "nameserver $ns\n";
|
||||
}
|
||||
}
|
||||
|
||||
while (my $line = <$fh>) {
|
||||
next if $line =~ m/^(search|domain|nameserver)\s+/;
|
||||
$data .= $line
|
||||
}
|
||||
|
||||
return $data;
|
||||
}
|
||||
|
||||
register_file('resolvconf', "/etc/resolv.conf",
|
||||
\&read_etc_resolv_conf, undef,
|
||||
\&update_etc_resolv_conf);
|
||||
|
||||
sub read_etc_timezone {
|
||||
my ($filename, $fd) = @_;
|
||||
|
||||
my $timezone = <$fd>;
|
||||
|
||||
chomp $timezone;
|
||||
|
||||
return $timezone;
|
||||
}
|
||||
|
||||
sub write_etc_timezone {
|
||||
my ($filename, $fh, $timezone) = @_;
|
||||
|
||||
my $tzinfo = "/usr/share/zoneinfo/$timezone";
|
||||
|
||||
raise_param_exc({ 'timezone' => "No such timezone" })
|
||||
if (! -f $tzinfo);
|
||||
|
||||
($timezone) = $timezone =~ m/^(.*)$/; # untaint
|
||||
|
||||
print $fh "$timezone\n";
|
||||
|
||||
unlink ("/etc/localtime");
|
||||
symlink ("/usr/share/zoneinfo/$timezone", "/etc/localtime");
|
||||
|
||||
}
|
||||
|
||||
register_file('timezone', "/etc/timezone",
|
||||
\&read_etc_timezone,
|
||||
\&write_etc_timezone);
|
||||
|
||||
sub read_active_workers {
|
||||
my ($filename, $fh) = @_;
|
||||
|
||||
return [] if !$fh;
|
||||
|
||||
my $res = [];
|
||||
while (defined (my $line = <$fh>)) {
|
||||
if ($line =~ m/^(\S+)\s(0|1)(\s([0-9A-Za-z]{8})(\s(\S.*))?)?$/) {
|
||||
my $upid = $1;
|
||||
my $saved = $2;
|
||||
my $endtime = $4;
|
||||
my $status = $6;
|
||||
if ((my $task = PVE::Tools::upid_decode($upid, 1))) {
|
||||
$task->{upid} = $upid;
|
||||
$task->{saved} = $saved;
|
||||
$task->{endtime} = hex($endtime) if $endtime;
|
||||
$task->{status} = $status if $status;
|
||||
push @$res, $task;
|
||||
}
|
||||
} else {
|
||||
warn "unable to parse line: $line";
|
||||
}
|
||||
}
|
||||
|
||||
return $res;
|
||||
|
||||
}
|
||||
|
||||
sub write_active_workers {
|
||||
my ($filename, $fh, $tasklist) = @_;
|
||||
|
||||
my $raw = '';
|
||||
foreach my $task (@$tasklist) {
|
||||
my $upid = $task->{upid};
|
||||
my $saved = $task->{saved} ? 1 : 0;
|
||||
if ($task->{endtime}) {
|
||||
if ($task->{status}) {
|
||||
$raw .= sprintf("$upid $saved %08X $task->{status}\n", $task->{endtime});
|
||||
} else {
|
||||
$raw .= sprintf("$upid $saved %08X\n", $task->{endtime});
|
||||
}
|
||||
} else {
|
||||
$raw .= "$upid $saved\n";
|
||||
}
|
||||
}
|
||||
|
||||
PVE::Tools::safe_print($filename, $fh, $raw) if $raw;
|
||||
}
|
||||
|
||||
register_file('active', "/var/log/pve/tasks/active",
|
||||
\&read_active_workers,
|
||||
\&write_active_workers);
|
||||
|
||||
|
||||
my $bond_modes = { 'balance-rr' => 0,
|
||||
'active-backup' => 1,
|
||||
'balance-xor' => 2,
|
||||
'broadcast' => 3,
|
||||
'802.3ad' => 4,
|
||||
'balance-tlb' => 5,
|
||||
'balance-alb' => 6,
|
||||
};
|
||||
|
||||
#sub get_bond_modes {
|
||||
# return $bond_modes;
|
||||
#}
|
||||
|
||||
sub read_etc_network_interfaces {
|
||||
my ($filename, $fh) = @_;
|
||||
|
||||
my $ifaces = {};
|
||||
|
||||
my $line;
|
||||
|
||||
if (my $fd2 = IO::File->new("/proc/net/dev", "r")) {
|
||||
while (defined ($line = <$fd2>)) {
|
||||
if ($line =~ m/^\s*(eth[0-9]):.*/) {
|
||||
$ifaces->{$1}->{exists} = 1;
|
||||
}
|
||||
}
|
||||
close($fd2);
|
||||
}
|
||||
|
||||
# always add the vmbr0 bridge device
|
||||
$ifaces->{vmbr0}->{exists} = 1;
|
||||
|
||||
if (my $fd2 = IO::File->new("/proc/net/if_inet6", "r")) {
|
||||
while (defined ($line = <$fd2>)) {
|
||||
if ($line =~ m/^[a-f0-9]{32}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+[a-f0-9]{2}\s+(lo|eth\d+|vmbr\d+|bond\d+)$/) {
|
||||
$ifaces->{$1}->{active} = 1;
|
||||
}
|
||||
}
|
||||
close ($fd2);
|
||||
}
|
||||
|
||||
my $gateway = 0;
|
||||
|
||||
while (defined ($line = <$fh>)) {
|
||||
chomp ($line);
|
||||
next if $line =~ m/^#/;
|
||||
|
||||
if ($line =~ m/^auto\s+(.*)$/) {
|
||||
my @aa = split (/\s+/, $1);
|
||||
|
||||
foreach my $a (@aa) {
|
||||
$ifaces->{$a}->{autostart} = 1;
|
||||
}
|
||||
|
||||
} elsif ($line =~ m/^iface\s+(\S+)\s+inet\s+(\S+)\s*$/) {
|
||||
my $i = $1;
|
||||
$ifaces->{$i}->{method} = $2;
|
||||
|
||||
my $d = $ifaces->{$i};
|
||||
while (defined ($line = <$fh>) && ($line =~ m/^\s+((\S+)\s+(.+))$/)) {
|
||||
my $option = $1;
|
||||
my ($id, $value) = ($2, $3);
|
||||
if (($id eq 'address') || ($id eq 'netmask') || ($id eq 'broadcast')) {
|
||||
$d->{$id} = $value;
|
||||
} elsif ($id eq 'gateway') {
|
||||
$d->{$id} = $value;
|
||||
$gateway = 1;
|
||||
} elsif ($id eq 'slaves' || $id eq 'bridge_ports') {
|
||||
my $devs = {};
|
||||
foreach my $p (split (/\s+/, $value)) {
|
||||
next if $p eq 'none';
|
||||
$devs->{$p} = 1;
|
||||
}
|
||||
my $str = join (' ', sort keys %{$devs});
|
||||
$d->{$id} = $str || '';
|
||||
} elsif ($id eq 'bridge_stp') {
|
||||
if ($value =~ m/^\s*(on|yes)\s*$/i) {
|
||||
$d->{$id} = 'on';
|
||||
} else {
|
||||
$d->{$id} = 'off';
|
||||
}
|
||||
} elsif ($id eq 'bridge_fd') {
|
||||
$d->{$id} = $value;
|
||||
} elsif ($id eq 'bond_miimon') {
|
||||
$d->{$id} = $value;
|
||||
} elsif ($id eq 'bond_mode') {
|
||||
# always use names
|
||||
foreach my $bm (keys %$bond_modes) {
|
||||
my $id = $bond_modes->{$bm};
|
||||
if ($id eq $value) {
|
||||
$value = $bm;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$d->{$id} = $value;
|
||||
} else {
|
||||
push @{$d->{options}}, $option;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (!$gateway) {
|
||||
$ifaces->{vmbr0}->{gateway} = '';
|
||||
}
|
||||
|
||||
if (!$ifaces->{lo}) {
|
||||
$ifaces->{lo}->{method} = 'loopback';
|
||||
$ifaces->{lo}->{type} = 'loopback';
|
||||
$ifaces->{lo}->{autostart} = 1;
|
||||
}
|
||||
|
||||
foreach my $iface (keys %$ifaces) {
|
||||
my $d = $ifaces->{$iface};
|
||||
if ($iface =~ m/^bond\d+$/) {
|
||||
$d->{type} = 'bond';
|
||||
} elsif ($iface =~ m/^vmbr\d+$/) {
|
||||
$d->{type} = 'bridge';
|
||||
if (!defined ($d->{bridge_fd})) {
|
||||
$d->{bridge_fd} = 0;
|
||||
}
|
||||
if (!defined ($d->{bridge_stp})) {
|
||||
$d->{bridge_stp} = 'off';
|
||||
}
|
||||
} elsif ($iface =~ m/^(\S+):\d+$/) {
|
||||
$d->{type} = 'alias';
|
||||
if (defined ($ifaces->{$1})) {
|
||||
$d->{exists} = $ifaces->{$1}->{exists};
|
||||
} else {
|
||||
$ifaces->{$1}->{exists} = 0;
|
||||
$d->{exists} = 0;
|
||||
}
|
||||
} elsif ($iface =~ m/^eth[0-9]$/) {
|
||||
$d->{type} = 'eth';
|
||||
} elsif ($iface =~ m/^lo$/) {
|
||||
$d->{type} = 'loopback';
|
||||
} else {
|
||||
$d->{type} = 'unknown';
|
||||
}
|
||||
|
||||
$d->{method} = 'manual' if !$d->{method};
|
||||
}
|
||||
|
||||
return $ifaces;
|
||||
}
|
||||
|
||||
sub __interface_to_string {
|
||||
my ($iface, $d) = @_;
|
||||
|
||||
return '' if !($d && $d->{method});
|
||||
|
||||
my $raw = '';
|
||||
|
||||
if ($d->{autostart}) {
|
||||
$raw .= "auto $iface\n";
|
||||
}
|
||||
$raw .= "iface $iface inet $d->{method}\n";
|
||||
$raw .= "\taddress $d->{address}\n" if $d->{address};
|
||||
$raw .= "\tnetmask $d->{netmask}\n" if $d->{netmask};
|
||||
$raw .= "\tgateway $d->{gateway}\n" if $d->{gateway};
|
||||
$raw .= "\tbroadcast $d->{broadcast}\n" if $d->{broadcast};
|
||||
|
||||
if ($d->{bridge_ports} || ($iface =~ m/^vmbr\d+$/)) {
|
||||
my $ports = $d->{bridge_ports} || 'none';
|
||||
$raw .= "\tbridge_ports $ports\n";
|
||||
}
|
||||
|
||||
if ($d->{bridge_stp} || ($iface =~ m/^vmbr\d+$/)) {
|
||||
my $v = $d->{bridge_stp};
|
||||
$v = defined ($v) ? $v : 'off';
|
||||
$raw .= "\tbridge_stp $v\n";
|
||||
}
|
||||
|
||||
if (defined ($d->{bridge_fd}) || ($iface =~ m/^vmbr\d+$/)) {
|
||||
my $v = $d->{bridge_fd};
|
||||
$v = defined ($v) ? $v : 0;
|
||||
$raw .= "\tbridge_fd $v\n";
|
||||
}
|
||||
|
||||
if ($d->{slaves} || ($iface =~ m/^bond\d+$/)) {
|
||||
my $slaves = $d->{slaves} || 'none';
|
||||
$raw .= "\tslaves $slaves\n";
|
||||
}
|
||||
|
||||
if (defined ($d->{'bond_miimon'}) || ($iface =~ m/^bond\d+$/)) {
|
||||
my $v = $d->{'bond_miimon'};
|
||||
$v = defined ($v) ? $v : 100;
|
||||
$raw .= "\tbond_miimon $v\n";
|
||||
}
|
||||
|
||||
if (defined ($d->{'bond_mode'}) || ($iface =~ m/^bond\d+$/)) {
|
||||
my $v = $d->{'bond_mode'};
|
||||
$v = defined ($v) ? $v : 'balance-rr';
|
||||
$raw .= "\tbond_mode $v\n";
|
||||
}
|
||||
|
||||
foreach my $option (@{$d->{options}}) {
|
||||
$raw .= "\t$option\n";
|
||||
}
|
||||
|
||||
$raw .= "\n";
|
||||
|
||||
return $raw;
|
||||
}
|
||||
|
||||
sub write_etc_network_interfaces {
|
||||
my ($filename, $fh, $ifaces) = @_;
|
||||
|
||||
my $raw = "# network interface settings\n";
|
||||
|
||||
my $printed = {};
|
||||
|
||||
foreach my $t (('lo', 'eth', '')) {
|
||||
foreach my $iface (sort keys %$ifaces) {
|
||||
my $d = $ifaces->{$iface};
|
||||
|
||||
next if $printed->{$iface};
|
||||
next if $iface !~ m/^$t/;
|
||||
|
||||
$printed->{$iface} = 1;
|
||||
$raw .= __interface_to_string($iface, $d);
|
||||
}
|
||||
}
|
||||
|
||||
PVE::Tools::safe_print($filename, $fh, $raw);
|
||||
}
|
||||
|
||||
register_file('interfaces', "/etc/network/interfaces",
|
||||
\&read_etc_network_interfaces,
|
||||
\&write_etc_network_interfaces);
|
||||
|
||||
1;
|
||||
973
data/PVE/JSONSchema.pm
Normal file
973
data/PVE/JSONSchema.pm
Normal file
@ -0,0 +1,973 @@
|
||||
package PVE::JSONSchema;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Storable; # for dclone
|
||||
use Getopt::Long;
|
||||
use Devel::Cycle -quiet; # todo: remove?
|
||||
use PVE::Tools qw(split_list);
|
||||
use PVE::Exception qw(raise);
|
||||
use HTTP::Status qw(:constants);
|
||||
|
||||
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\n" if !$std;
|
||||
|
||||
my $res = $base || {};
|
||||
|
||||
foreach my $opt (keys %$std) {
|
||||
next if $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,
|
||||
});
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
# register some common type for pve
|
||||
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 cofiguration ID '$id'\n";
|
||||
}
|
||||
return $id;
|
||||
}
|
||||
|
||||
register_format('pve-vmid', \&pve_verify_vmid);
|
||||
sub pve_verify_vmid {
|
||||
my ($vmid, $noerr) = @_;
|
||||
|
||||
if ($vmid !~ m/^[1-9][0-9]+$/) {
|
||||
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) = @_;
|
||||
|
||||
# todo: use better regex ?
|
||||
if ($node !~ m/^[A-Za-z][[:alnum:]\-]*[[:alnum:]]+$/) {
|
||||
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/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ||
|
||||
!(($1 > 0) && ($1 < 255) &&
|
||||
($2 <= 255) && ($3 <= 255) &&
|
||||
($4 > 0) && ($4 < 255))) {
|
||||
return undef if $noerr;
|
||||
die "value does not look like a valid IP address\n";
|
||||
}
|
||||
return $ipv4;
|
||||
}
|
||||
register_format('ipv4mask', \&pve_verify_ipv4mask);
|
||||
sub pve_verify_ipv4mask {
|
||||
my ($mask, $noerr) = @_;
|
||||
|
||||
if ($mask !~ m/^255\.255\.(\d{1,3})\.(\d{1,3})$/ ||
|
||||
!(($1 <= 255) && ($2 <= 255))) {
|
||||
return undef if $noerr;
|
||||
die "value does not look like a valid IP netmask\n";
|
||||
}
|
||||
return $mask;
|
||||
}
|
||||
|
||||
register_format('email', \&pve_verify_email);
|
||||
sub pve_verify_email {
|
||||
my ($email, $noerr) = @_;
|
||||
|
||||
# we use same regex as extjs Ext.form.VTypes.email
|
||||
if ($email !~ /^(\w+)([\-+.][\w]+)*@(\w[\-\w]*\.){1,5}([A-Za-z]){2,6}$/) {
|
||||
return undef if $noerr;
|
||||
die "value does not look like a valid email address\n";
|
||||
}
|
||||
return $email;
|
||||
}
|
||||
|
||||
# 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;
|
||||
}
|
||||
|
||||
sub check_format {
|
||||
my ($format, $value) = @_;
|
||||
|
||||
return if $format eq 'regex';
|
||||
|
||||
if ($format =~ m/^(.*)-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;
|
||||
|
||||
&$code($value);
|
||||
}
|
||||
}
|
||||
|
||||
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;
|
||||
} 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 0;
|
||||
} 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' requiers 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_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}) {
|
||||
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); };
|
||||
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).",
|
||||
},
|
||||
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",
|
||||
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 => {
|
||||
type => "any",
|
||||
optional => 1,
|
||||
description => "This indicates the default for the instance property."
|
||||
},
|
||||
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, than 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,
|
||||
},
|
||||
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,
|
||||
},
|
||||
permissions => {
|
||||
type => 'object',
|
||||
description => "Required access permissions. By default only 'root' is allowed to access this method.",
|
||||
optional => 1,
|
||||
additionalProperties => 0,
|
||||
properties => {
|
||||
user => {
|
||||
description => "A simply way to allow access for 'all' users. The special value 'arg' allows access for the user specified in the 'username' parameter. This is useful to allow access to things owned by a user, like changing the user password. Value 'world' is used to allow access without credentials.",
|
||||
type => 'string',
|
||||
enum => ['all', 'arg', 'world'],
|
||||
optional => 1,
|
||||
},
|
||||
path => { type => 'string', optional => 1, requires => 'privs' },
|
||||
privs => { type => 'array', optional => 1, requires => 'path' },
|
||||
},
|
||||
},
|
||||
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, $uri_param, $pwcallback) = @_;
|
||||
|
||||
if (!$schema || !$schema->{properties}) {
|
||||
raise("too many arguments\n", code => HTTP_BAD_REQUEST)
|
||||
if scalar(@$args) != 0;
|
||||
return {};
|
||||
}
|
||||
|
||||
my @getopt = ();
|
||||
foreach my $prop (keys %{$schema->{properties}}) {
|
||||
my $pd = $schema->{properties}->{$prop};
|
||||
next if defined($uri_param->{$prop});
|
||||
|
||||
if ($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 {
|
||||
push @getopt, "$prop=s";
|
||||
}
|
||||
}
|
||||
|
||||
my $opts = {};
|
||||
raise("unable to parse option\n", code => HTTP_BAD_REQUEST)
|
||||
if !Getopt::Long::GetOptionsFromArray($args, $opts, @getopt);
|
||||
|
||||
raise("too many arguments\n", code => HTTP_BAD_REQUEST)
|
||||
if scalar(@$args) != 0;
|
||||
|
||||
if (my $pd = $schema->{properties}->{password}) {
|
||||
if ($pd->{type} ne 'boolean' && $pwcallback) {
|
||||
if ($opts->{password} || !$pd->{optional}) {
|
||||
$opts->{password} = &$pwcallback();
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $p (keys %$opts) {
|
||||
if (my $pd = $schema->{properties}->{$p}) {
|
||||
if ($pd->{type} eq 'boolean') {
|
||||
if ($opts->{$p} eq '') {
|
||||
$opts->{$p} = 1;
|
||||
} elsif ($opts->{$p} =~ m/^(1|true|yes|on)$/i) {
|
||||
$opts->{$p} = 1;
|
||||
} elsif ($opts->{$p} =~ m/^(0|false|no|off)$/i) {
|
||||
$opts->{$p} = 0;
|
||||
} else {
|
||||
raise("unable to parse boolean option\n", code => HTTP_BAD_REQUEST);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $p (keys %$uri_param) {
|
||||
$opts->{$p} = $uri_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 && $raw =~ s/^(.*?)(\n|$)//) {
|
||||
my $line = $1;
|
||||
|
||||
next if $line =~ m/^\#/; # skip comment lines
|
||||
next if $line =~ m/^\s*$/; # skip empty lines
|
||||
|
||||
if ($line =~ m/^(\S+):\s*(\S+)\s*$/) {
|
||||
my $key = $1;
|
||||
my $value = $2;
|
||||
if ($schema->{properties}->{$key} &&
|
||||
$schema->{properties}->{$key}->{type} eq 'boolean') {
|
||||
|
||||
$value = 1 if $value =~ m/^(1|on|yes|true)$/i;
|
||||
$value = 0 if $value =~ m/^(0|off|no|false)$/i;
|
||||
}
|
||||
$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;
|
||||
}
|
||||
|
||||
1;
|
||||
105
data/PVE/PodParser.pm
Normal file
105
data/PVE/PodParser.pm
Normal file
@ -0,0 +1,105 @@
|
||||
package PVE::PodParser;
|
||||
|
||||
use strict;
|
||||
use Pod::Parser;
|
||||
use base qw(Pod::Parser);
|
||||
|
||||
my $stdinclude = {
|
||||
pve_copyright => <<EODATA,
|
||||
\=head1 COPYRIGHT AND DISCLAIMER
|
||||
|
||||
Copyright (C) 2007-2011 Proxmox Server Solutions GmbH
|
||||
|
||||
This program is free software: you can redistribute it and\/or modify
|
||||
it under the terms of the GNU Affero General Public License as
|
||||
published by the Free Software Foundation, either version 3 of the
|
||||
License, or (at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Affero General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Affero General Public License
|
||||
along with this program. If not, see L<http://www.gnu.org/licenses/>.
|
||||
EODATA
|
||||
};
|
||||
|
||||
sub command {
|
||||
my ($self, $cmd, $text, $line_num, $pod_para) = @_;
|
||||
|
||||
if (($cmd eq 'include' && $text =~ m/^\s*(\S+)\s/)) {
|
||||
my $incl = $1;
|
||||
my $data = $stdinclude->{$incl} ? $stdinclude->{$incl} :
|
||||
$self->{include}->{$incl};
|
||||
chomp $data;
|
||||
$self->textblock("$data\n\n", $line_num, $pod_para);
|
||||
} else {
|
||||
$self->textblock($pod_para->raw_text(), $line_num, $pod_para);
|
||||
}
|
||||
}
|
||||
|
||||
# helpers used to generate our manual pages
|
||||
|
||||
sub schema_get_type_text {
|
||||
my ($phash) = @_;
|
||||
|
||||
if ($phash->{typetext}) {
|
||||
return $phash->{typetext};
|
||||
} elsif ($phash->{enum}) {
|
||||
return "(" . join(' | ', sort @{$phash->{enum}}) . ")";
|
||||
} elsif ($phash->{pattern}) {
|
||||
return $phash->{pattern};
|
||||
} elsif ($phash->{type} eq 'integer' || $phash->{type} eq 'number') {
|
||||
if (defined($phash->{minimum}) && defined($phash->{maximum})) {
|
||||
return "$phash->{type} ($phash->{minimum} - $phash->{maximum})";
|
||||
} elsif (defined($phash->{minimum})) {
|
||||
return "$phash->{type} ($phash->{minimum} - N)";
|
||||
} elsif (defined($phash->{maximum})) {
|
||||
return "$phash->{type} (-N - $phash->{maximum})";
|
||||
}
|
||||
}
|
||||
|
||||
my $type = $phash->{type} || 'string';
|
||||
|
||||
return $type;
|
||||
}
|
||||
|
||||
# generta epop from JSON schema properties
|
||||
sub dump_properties {
|
||||
my ($properties) = @_;
|
||||
|
||||
my $data = "=over 1\n\n";
|
||||
|
||||
my $idx_param = {}; # -vlan\d+ -scsi\d+
|
||||
|
||||
foreach my $key (sort keys %$properties) {
|
||||
my $d = $properties->{$key};
|
||||
my $base = $key;
|
||||
if ($key =~ m/^([a-z]+)(\d+)$/) {
|
||||
my $name = $1;
|
||||
next if $idx_param->{$name};
|
||||
$idx_param->{$name} = 1;
|
||||
$base = "${name}[n]";
|
||||
}
|
||||
|
||||
my $descr = $d->{description} || 'No description avalable.';
|
||||
chomp $descr;
|
||||
|
||||
if (defined(my $dv = $d->{default})) {
|
||||
my $multi = $descr =~ m/\n\n/; # multi paragraph ?
|
||||
$descr .= $multi ? "\n\n" : " ";
|
||||
$descr .= "Default value is '$dv'.";
|
||||
}
|
||||
|
||||
my $typetext = schema_get_type_text($d);
|
||||
$data .= "=item $base: $typetext\n\n";
|
||||
$data .= "$descr\n\n";
|
||||
}
|
||||
|
||||
$data .= "=back";
|
||||
|
||||
return $data;
|
||||
}
|
||||
|
||||
1;
|
||||
220
data/PVE/ProcFSTools.pm
Normal file
220
data/PVE/ProcFSTools.pm
Normal file
@ -0,0 +1,220 @@
|
||||
package PVE::ProcFSTools;
|
||||
|
||||
use strict;
|
||||
use POSIX;
|
||||
use Time::HiRes qw (gettimeofday);
|
||||
use IO::File;
|
||||
use PVE::Tools;
|
||||
|
||||
my $clock_ticks = POSIX::sysconf(&POSIX::_SC_CLK_TCK);
|
||||
|
||||
my $cpuinfo;
|
||||
|
||||
# cycles_per_jiffy = frequency_of_your_cpu/jiffies_per_second
|
||||
# jiffies_per_second = 1000
|
||||
|
||||
# frequency_of_your_cpu can be read from /proc/cpuinfo, as:
|
||||
# cpu MHz : <frequency_of_your_cpu>
|
||||
|
||||
sub read_cpuinfo {
|
||||
my $fn = '/proc/cpuinfo';
|
||||
|
||||
return $cpuinfo if $cpuinfo;
|
||||
|
||||
my $res = {
|
||||
model => 'unknown',
|
||||
mhz => 0,
|
||||
cpus => 1,
|
||||
cpu_cycles_per_jiffy => 0,
|
||||
};
|
||||
|
||||
my $fh = IO::File->new ($fn, "r");
|
||||
return $res if !$fh;
|
||||
|
||||
my $count = 0;
|
||||
while (defined(my $line = <$fh>)) {
|
||||
if ($line =~ m/^processor\s*:\s*\d+\s*$/i) {
|
||||
$count++;
|
||||
} elsif ($line =~ m/^model\s+name\s*:\s*(.*)\s*$/i) {
|
||||
$res->{model} = $1 if $res->{model} eq 'unknown';
|
||||
} elsif ($line =~ m/^cpu\s+MHz\s*:\s*(\d+\.\d+)\s*$/i) {
|
||||
$res->{mhz} = $1 if !$res->{mhz};
|
||||
$res->{cpu_cycles_per_jiffy} += $1 * 1000;
|
||||
} elsif ($line =~ m/^flags\s*:.*(vmx|svm)/) {
|
||||
$res->{hvm} = 1; # Hardware Virtual Machine (Intel VT / AMD-V)
|
||||
}
|
||||
}
|
||||
|
||||
$res->{cpus} = $count;
|
||||
|
||||
$fh->close;
|
||||
|
||||
$cpuinfo = $res;
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub read_proc_uptime {
|
||||
my $ticks = shift;
|
||||
|
||||
my $line = PVE::Tools::file_read_firstline("/proc/uptime");
|
||||
if ($line && $line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s*$|) {
|
||||
if ($ticks) {
|
||||
return (int($1*100), int($2*100));
|
||||
} else {
|
||||
return (int($1), int($2));
|
||||
}
|
||||
}
|
||||
|
||||
return (0, 0);
|
||||
}
|
||||
|
||||
sub read_loadavg {
|
||||
|
||||
my $line = PVE::Tools::file_read_firstline('/proc/loadavg');
|
||||
|
||||
if ($line =~ m|^(\d+\.\d+)\s+(\d+\.\d+)\s+(\d+\.\d+)\s+\d+/\d+\s+\d+\s*$|) {
|
||||
return wantarray ? ($1, $2, $3) : $1;
|
||||
}
|
||||
|
||||
return wantarray ? (0, 0, 0) : 0;
|
||||
}
|
||||
|
||||
my $last_proc_stat;
|
||||
|
||||
sub read_proc_stat {
|
||||
my $res = { user => 0, nice => 0, system => 0, idle => 0 , sum => 0};
|
||||
|
||||
my $cpucount = 0;
|
||||
|
||||
if (my $fh = IO::File->new ("/proc/stat", "r")) {
|
||||
while (defined (my $line = <$fh>)) {
|
||||
if ($line =~ m|^cpu\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s|) {
|
||||
$res->{user} = $1;
|
||||
$res->{nice} = $2;
|
||||
$res->{system} = $3;
|
||||
$res->{idle} = $4;
|
||||
$res->{used} = $1+$2+$3;
|
||||
$res->{iowait} = $5;
|
||||
} elsif ($line =~ m|^cpu\d+\s|) {
|
||||
$cpucount++;
|
||||
}
|
||||
}
|
||||
$fh->close;
|
||||
}
|
||||
|
||||
$cpucount = 1 if !$cpucount;
|
||||
|
||||
my $ctime = gettimeofday; # floating point time in seconds
|
||||
|
||||
$res->{ctime} = $ctime;
|
||||
$res->{cpu} = 0;
|
||||
$res->{wait} = 0;
|
||||
|
||||
$last_proc_stat = $res if !$last_proc_stat;
|
||||
|
||||
my $diff = ($ctime - $last_proc_stat->{ctime}) * $clock_ticks * $cpucount;
|
||||
|
||||
if ($diff > 1000) { # don't update too often
|
||||
my $useddiff = $res->{used} - $last_proc_stat->{used};
|
||||
$useddiff = $diff if $useddiff > $diff;
|
||||
$res->{cpu} = $useddiff/$diff;
|
||||
my $waitdiff = $res->{iowait} - $last_proc_stat->{iowait};
|
||||
$waitdiff = $diff if $waitdiff > $diff;
|
||||
$res->{wait} = $waitdiff/$diff;
|
||||
$last_proc_stat = $res;
|
||||
} else {
|
||||
$res->{cpu} = $last_proc_stat->{cpu};
|
||||
$res->{wait} = $last_proc_stat->{wait};
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub read_proc_starttime {
|
||||
my $pid = shift;
|
||||
|
||||
my $statstr = PVE::Tools::file_read_firstline("/proc/$pid/stat");
|
||||
|
||||
if ($statstr && $statstr =~ m/^$pid \(.*\) \S (-?\d+) -?\d+ -?\d+ -?\d+ -?\d+ \d+ \d+ \d+ \d+ \d+ (\d+) (\d+) (-?\d+) (-?\d+) -?\d+ -?\d+ -?\d+ 0 (\d+) (\d+) (-?\d+) \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ \d+ -?\d+ -?\d+ \d+ \d+ \d+/) {
|
||||
my $starttime = $6;
|
||||
|
||||
return $starttime;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub read_meminfo {
|
||||
|
||||
my $res = {
|
||||
memtotal => 0,
|
||||
memfree => 0,
|
||||
memused => 0,
|
||||
swaptotal => 0,
|
||||
swapfree => 0,
|
||||
swapused => 0,
|
||||
};
|
||||
|
||||
my $fh = IO::File->new ("/proc/meminfo", "r");
|
||||
return $res if !$fh;
|
||||
|
||||
my $d = {};
|
||||
while (my $line = <$fh>) {
|
||||
if ($line =~ m/^(\S+):\s+(\d+)\s*kB/i) {
|
||||
$d->{lc ($1)} = $2 * 1024;
|
||||
}
|
||||
}
|
||||
close($fh);
|
||||
|
||||
$res->{memtotal} = $d->{memtotal};
|
||||
$res->{memfree} = $d->{memfree} + $d->{buffers} + $d->{cached};
|
||||
$res->{memused} = $res->{memtotal} - $res->{memfree};
|
||||
|
||||
$res->{swaptotal} = $d->{swaptotal};
|
||||
$res->{swapfree} = $d->{swapfree};
|
||||
$res->{swapused} = $res->{swaptotal} - $res->{swapfree};
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
# memory usage of current process
|
||||
sub read_memory_usage {
|
||||
|
||||
my $res = { size => 0, resident => 0, shared => 0 };
|
||||
|
||||
my $ps = 4096;
|
||||
|
||||
my $line = PVE::Tools::file_read_firstline("/proc/$$/statm");
|
||||
|
||||
if ($line =~ m/^(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+/) {
|
||||
$res->{size} = $1*$ps;
|
||||
$res->{resident} = $2*$ps;
|
||||
$res->{shared} = $3*$ps;
|
||||
}
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub read_proc_net_dev {
|
||||
|
||||
my $res = {};
|
||||
|
||||
my $fh = IO::File->new ("/proc/net/dev", "r");
|
||||
return $res if !$fh;
|
||||
|
||||
while (defined (my $line = <$fh>)) {
|
||||
if ($line =~ m/^\s*(.*):\s*(\d+)\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+\d+\s+(\d+)\s+/) {
|
||||
$res->{$1} = {
|
||||
receive => $2,
|
||||
transmit => $3,
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
close($fh);
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
1;
|
||||
515
data/PVE/RESTHandler.pm
Normal file
515
data/PVE/RESTHandler.pm
Normal file
@ -0,0 +1,515 @@
|
||||
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::PodParser;
|
||||
use HTTP::Status qw(:constants :is status_message);
|
||||
use Text::Wrap;
|
||||
use Storable qw(dclone);
|
||||
|
||||
my $method_registry = {};
|
||||
my $method_by_name = {};
|
||||
|
||||
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) ? dclone($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+)$/) {
|
||||
if ($2 == 0) {
|
||||
$p = "$1\[n\]";
|
||||
} else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
$res->{$k}->{$p} = ref($pd) ? dclone($pd) : $pd;
|
||||
}
|
||||
}
|
||||
|
||||
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) ? dclone($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;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
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 = [];
|
||||
|
||||
foreach my $comp (split(/\/+/, $info->{path})) {
|
||||
die "path compoment has zero length" if $comp eq '';
|
||||
if ($comp =~ m/^\{(\w+)(:(.*))?\}$/) {
|
||||
my $name = $1;
|
||||
push @$match_re, $3 ? $3 : '\S+';
|
||||
push @$match_name, $1;
|
||||
} else {
|
||||
push @$match_re, $comp;
|
||||
push @$match_name, undef;
|
||||
}
|
||||
}
|
||||
|
||||
$info->{match_re} = $match_re;
|
||||
$info->{match_name} = $match_name;
|
||||
|
||||
$method_by_name->{$self} = {} if !defined($method_by_name->{$self});
|
||||
|
||||
if ($info->{name}) {
|
||||
die "method '${self}::$info->{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 AUTOLOAD {
|
||||
my ($this) = @_;
|
||||
|
||||
# also see "man perldiag"
|
||||
|
||||
my $sub = $AUTOLOAD;
|
||||
(my $method = $sub) =~ s/.*:://;
|
||||
|
||||
$method =~ 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_method {
|
||||
my ($self, $stack, $method, $uri_param) = @_;
|
||||
|
||||
my $ma = $method_registry->{$self};
|
||||
|
||||
my $stacklen = scalar(@$stack);
|
||||
|
||||
#syslog ('info', "MAPTEST:$method:$self: " . join ('/', @$stack));
|
||||
|
||||
foreach my $info (@$ma) {
|
||||
#syslog ('info', "TEST0 " . Dumper($info));
|
||||
next if !($info->{subclass} || ($info->{method} eq $method));
|
||||
my $regexlen = scalar(@{$info->{match_re}});
|
||||
if ($info->{subclass}) {
|
||||
next if $stacklen < $regexlen;
|
||||
} else {
|
||||
next if $stacklen != $regexlen;
|
||||
}
|
||||
|
||||
#syslog ('info', "TEST1 " . Dumper($info));
|
||||
|
||||
my $param = {};
|
||||
my $i = 0;
|
||||
for (; $i < $regexlen; $i++) {
|
||||
my $comp = $stack->[$i];
|
||||
my $re = $info->{match_re}->[$i];
|
||||
#print "COMPARE $comp $info->{match_re}->[$i]\n";
|
||||
my ($match) = $stack->[$i] =~ m/^($re)$/;
|
||||
last if !defined($match);
|
||||
if (my $name = $info->{match_name}->[$i]) {
|
||||
$param->{$name} = $match;
|
||||
}
|
||||
}
|
||||
|
||||
next if $i != $regexlen;
|
||||
|
||||
#print "MATCH $info->{name}\n";
|
||||
|
||||
foreach my $p (keys %$param) {
|
||||
$uri_param->{$p} = $param->{$p};
|
||||
}
|
||||
|
||||
return $info;
|
||||
}
|
||||
}
|
||||
|
||||
sub __find_handler_full {
|
||||
my ($class, $method, $stack, $uri_param, $pathmatchref) = @_;
|
||||
|
||||
my $info;
|
||||
eval {
|
||||
$info = $class->map_method($stack, $method, $uri_param);
|
||||
};
|
||||
syslog('err', $@) if $@;
|
||||
|
||||
return undef if !$info;
|
||||
|
||||
$$pathmatchref .= '/' . $info->{path};
|
||||
|
||||
if (my $subh = $info->{subclass}) {
|
||||
|
||||
my $matchlen = scalar(@{$info->{match_re}});
|
||||
|
||||
for (my $i = 0; $i < $matchlen; $i++) {
|
||||
shift @$stack; # pop from stack
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
return $subh->__find_handler_full($method, $stack, $uri_param, $pathmatchref);
|
||||
}
|
||||
|
||||
return ($class, $info, $$pathmatchref);
|
||||
};
|
||||
|
||||
sub find_handler {
|
||||
my ($class, $method, $path, $uri_param) = @_;
|
||||
|
||||
my $stack = [ grep { length($_) > 0 } split('\/+' , $path)]; # skip empty fragments
|
||||
|
||||
my $pathmatch = '';
|
||||
return $class->__find_handler_full($method, $stack, $uri_param, \$pathmatch);
|
||||
}
|
||||
|
||||
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)
|
||||
while (my ($key, $val) = each %$param) {
|
||||
($param->{$key}) = $val =~ /^(.*)$/s;
|
||||
}
|
||||
}
|
||||
|
||||
my $result = &$func($param);
|
||||
|
||||
# todo: this is only to be safe - disable?
|
||||
if (my $schema = $info->{returns}) {
|
||||
PVE::JSONSchema::validate($result, $schema, "Result verification vailed\n");
|
||||
}
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
# 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
|
||||
# $fixed_param ... do not generate and info about those parameters
|
||||
# $format:
|
||||
# 'long' ... default (list all options)
|
||||
# 'short' ... command line only (one line)
|
||||
# 'full' ... also include description
|
||||
# $hidepw ... hide password option (use this if you provide a read passwork callback)
|
||||
sub usage_str {
|
||||
my ($self, $name, $prefix, $arg_param, $fixed_param, $format, $hidepw) = @_;
|
||||
|
||||
$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 = '';
|
||||
foreach my $p (@$arg_param) {
|
||||
next if !$prop->{$p}; # just to be sure
|
||||
|
||||
$arg_hash->{$p} = 1;
|
||||
$args .= " " if $args;
|
||||
$args .= $prop->{$p} && $prop->{$p}->{optional} ? "[<$p>]" : "<$p>";
|
||||
}
|
||||
|
||||
my $get_prop_descr = sub {
|
||||
my ($k, $display_name) = @_;
|
||||
|
||||
my $phash = $prop->{$k};
|
||||
|
||||
my $res = '';
|
||||
|
||||
my $descr = $phash->{description} || "no description available";
|
||||
chomp $descr;
|
||||
|
||||
my $type = PVE::PodParser::schema_get_type_text($phash);
|
||||
|
||||
if ($hidepw && $k eq 'password') {
|
||||
$type = '';
|
||||
}
|
||||
|
||||
my $defaulttxt = '';
|
||||
if (defined(my $dv = $phash->{default})) {
|
||||
$defaulttxt = " (default=$dv)";
|
||||
}
|
||||
my $tmp = sprintf " %-10s %s$defaulttxt\n", $display_name, "$type";
|
||||
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";
|
||||
}
|
||||
|
||||
return $res;
|
||||
};
|
||||
|
||||
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_prop_descr($k, "<$k>");
|
||||
}
|
||||
|
||||
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 = $prop->{$k}->{type} || 'string';
|
||||
|
||||
next if $hidepw && ($k eq 'password') && !$prop->{$k}->{optional};
|
||||
|
||||
my $base = $k;
|
||||
if ($k =~ m/^([a-z]+)(\d+)$/) {
|
||||
my $name = $1;
|
||||
next if $idx_param->{$name};
|
||||
$idx_param->{$name} = 1;
|
||||
$base = "${name}[n]";
|
||||
}
|
||||
|
||||
$opts .= &$get_prop_descr($k, "-$base");
|
||||
|
||||
if (!$prop->{$k}->{optional}) {
|
||||
$args .= " " if $args;
|
||||
$args .= "-$base <$type>"
|
||||
}
|
||||
}
|
||||
|
||||
$out .= "USAGE: " if $format ne 'short';
|
||||
|
||||
$out .= "$prefix $args";
|
||||
|
||||
$out .= $opts ? " [OPTIONS]\n" : "\n";
|
||||
|
||||
return $out if $format eq 'short';
|
||||
|
||||
if ($info->{description} && $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;
|
||||
}
|
||||
|
||||
sub cli_handler {
|
||||
my ($self, $prefix, $name, $args, $arg_param, $fixed_param, $pwcallback) = @_;
|
||||
|
||||
my $info = $self->map_method_by_name($name);
|
||||
|
||||
my $param;
|
||||
foreach my $p (keys %$fixed_param) {
|
||||
$param->{$p} = $fixed_param->{$p};
|
||||
}
|
||||
|
||||
foreach my $p (@$arg_param) {
|
||||
$param->{$p} = shift @$args if $args->[0] && $args->[0] !~ m/^-/;
|
||||
}
|
||||
|
||||
my $res;
|
||||
eval {
|
||||
my $param = PVE::JSONSchema::get_options($info->{parameters}, $args, $param, $pwcallback);
|
||||
|
||||
$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', $pwcallback);
|
||||
|
||||
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;
|
||||
51
data/PVE/SafeSyslog.pm
Executable file
51
data/PVE/SafeSyslog.pm
Executable file
@ -0,0 +1,51 @@
|
||||
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;
|
||||
639
data/PVE/Tools.pm
Normal file
639
data/PVE/Tools.pm
Normal file
@ -0,0 +1,639 @@
|
||||
package PVE::Tools;
|
||||
|
||||
use strict;
|
||||
use POSIX;
|
||||
use IO::Socket::INET;
|
||||
use IO::Select;
|
||||
use File::Basename;
|
||||
use File::Path qw(make_path);
|
||||
use IO::File;
|
||||
use IPC::Open3;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use base 'Exporter';
|
||||
use URI::Escape;
|
||||
use Encode;
|
||||
|
||||
our @EXPORT_OK = qw(
|
||||
lock_file
|
||||
run_command
|
||||
file_set_contents
|
||||
file_get_contents
|
||||
file_read_firstline
|
||||
split_list
|
||||
template_replace
|
||||
safe_print
|
||||
trim
|
||||
extract_param
|
||||
);
|
||||
|
||||
my $pvelogdir = "/var/log/pve";
|
||||
my $pvetaskdir = "$pvelogdir/tasks";
|
||||
|
||||
mkdir $pvelogdir;
|
||||
mkdir $pvetaskdir;
|
||||
|
||||
# flock: we use one file handle per process, so lock file
|
||||
# can be called multiple times and succeeds for the same process.
|
||||
|
||||
my $lock_handles = {};
|
||||
|
||||
sub lock_file {
|
||||
my ($filename, $timeout, $code, @param) = @_;
|
||||
|
||||
my $res;
|
||||
|
||||
$timeout = 10 if !$timeout;
|
||||
|
||||
eval {
|
||||
|
||||
local $SIG{ALRM} = sub { die "got timeout (can't lock '$filename')\n"; };
|
||||
|
||||
alarm ($timeout);
|
||||
|
||||
if (!$lock_handles->{$$}->{$filename}) {
|
||||
$lock_handles->{$$}->{$filename} = new IO::File (">>$filename") ||
|
||||
die "can't open lock file '$filename' - $!\n";
|
||||
}
|
||||
|
||||
if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX|LOCK_NB)) {
|
||||
print STDERR "trying to aquire lock...";
|
||||
if (!flock ($lock_handles->{$$}->{$filename}, LOCK_EX)) {
|
||||
print STDERR " failed\n";
|
||||
die "can't aquire lock for '$filename' - $!\n";
|
||||
}
|
||||
print STDERR " OK\n";
|
||||
}
|
||||
alarm (0);
|
||||
|
||||
$res = &$code(@param);
|
||||
};
|
||||
|
||||
my $err = $@;
|
||||
|
||||
alarm (0);
|
||||
|
||||
if ($lock_handles->{$$}->{$filename}) {
|
||||
my $fh = $lock_handles->{$$}->{$filename};
|
||||
$lock_handles->{$$}->{$filename} = undef;
|
||||
close ($fh);
|
||||
}
|
||||
|
||||
if ($err) {
|
||||
$@ = $err;
|
||||
return undef;
|
||||
}
|
||||
|
||||
$@ = undef;
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub file_set_contents {
|
||||
my ($filename, $data, $perm) = @_;
|
||||
|
||||
$perm = 0644 if !defined($perm);
|
||||
|
||||
my $tmpname = "$filename.tmp.$$";
|
||||
|
||||
eval {
|
||||
my $fh = IO::File->new($tmpname, O_WRONLY|O_CREAT, $perm);
|
||||
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);
|
||||
|
||||
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;
|
||||
$fh->close;
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub safe_read_from {
|
||||
my ($fh, $max, $oneline) = @_;
|
||||
|
||||
$max = 32768 if !$max;
|
||||
|
||||
my $br = 0;
|
||||
my $input = '';
|
||||
my $count;
|
||||
while ($count = sysread($fh, $input, 8192, $br)) {
|
||||
$br += $count;
|
||||
die "input too long - aborting\n" if $br > $max;
|
||||
if ($oneline && $input =~ m/^(.*)\n/) {
|
||||
$input = $1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
die "unable to read input - $!\n" if !defined($count);
|
||||
|
||||
return $input;
|
||||
}
|
||||
|
||||
sub run_command {
|
||||
my ($cmd, %param) = @_;
|
||||
|
||||
my $old_umask;
|
||||
|
||||
$cmd = [ $cmd ] if !ref($cmd);
|
||||
|
||||
my $cmdstr = join (' ', @$cmd);
|
||||
|
||||
my $errmsg;
|
||||
my $laststderr;
|
||||
my $timeout;
|
||||
my $oldtimeout;
|
||||
my $pid;
|
||||
|
||||
eval {
|
||||
my $reader = IO::File->new();
|
||||
my $writer = IO::File->new();
|
||||
my $error = IO::File->new();
|
||||
|
||||
my $input;
|
||||
my $outfunc;
|
||||
my $errfunc;
|
||||
|
||||
foreach my $p (keys %param) {
|
||||
if ($p eq 'timeout') {
|
||||
$timeout = $param{$p};
|
||||
} elsif ($p eq 'umask') {
|
||||
umask($param{$p});
|
||||
} elsif ($p eq 'errmsg') {
|
||||
$errmsg = $param{$p};
|
||||
$errfunc = sub {
|
||||
print STDERR "$laststderr\n" if $laststderr;
|
||||
$laststderr = shift;
|
||||
};
|
||||
} elsif ($p eq 'input') {
|
||||
$input = $param{$p};
|
||||
} elsif ($p eq 'outfunc') {
|
||||
$outfunc = $param{$p};
|
||||
} elsif ($p eq 'errfunc') {
|
||||
$errfunc = $param{$p};
|
||||
} else {
|
||||
die "got unknown parameter '$p' for run_command\n";
|
||||
}
|
||||
}
|
||||
|
||||
# try to avoid locale related issues/warnings
|
||||
my $lang = $param{lang} || 'C';
|
||||
|
||||
my $orig_pid = $$;
|
||||
|
||||
eval {
|
||||
local $ENV{LANG} = $lang;
|
||||
|
||||
# suppress LVM warnings like: "File descriptor 3 left open";
|
||||
local $ENV{LVM_SUPPRESS_FD_WARNINGS} = "1";
|
||||
|
||||
$pid = open3($writer, $reader, $error, @$cmd) || die $!;
|
||||
};
|
||||
|
||||
my $err = $@;
|
||||
|
||||
# catch exec errors
|
||||
if ($orig_pid != $$) {
|
||||
warn "ERROR: $err";
|
||||
POSIX::_exit (1);
|
||||
kill ('KILL', $$);
|
||||
}
|
||||
|
||||
die $err if $err;
|
||||
|
||||
local $SIG{ALRM} = sub { die "got timeout\n"; } if $timeout;
|
||||
$oldtimeout = alarm($timeout) if $timeout;
|
||||
|
||||
print $writer $input if defined $input;
|
||||
close $writer;
|
||||
|
||||
my $select = new IO::Select;
|
||||
$select->add($reader);
|
||||
$select->add($error);
|
||||
|
||||
my $outlog = '';
|
||||
my $errlog = '';
|
||||
|
||||
my $starttime = time();
|
||||
|
||||
while ($select->count) {
|
||||
my @handles = $select->can_read(1);
|
||||
|
||||
foreach my $h (@handles) {
|
||||
my $buf = '';
|
||||
my $count = sysread ($h, $buf, 4096);
|
||||
if (!defined ($count)) {
|
||||
my $err = $!;
|
||||
kill (9, $pid);
|
||||
waitpid ($pid, 0);
|
||||
die $err;
|
||||
}
|
||||
$select->remove ($h) if !$count;
|
||||
if ($h eq $reader) {
|
||||
if ($outfunc) {
|
||||
eval {
|
||||
$outlog .= $buf;
|
||||
while ($outlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
|
||||
my $line = $1;
|
||||
&$outfunc($line);
|
||||
}
|
||||
};
|
||||
my $err = $@;
|
||||
if ($err) {
|
||||
kill (9, $pid);
|
||||
waitpid ($pid, 0);
|
||||
die $err;
|
||||
}
|
||||
} else {
|
||||
print $buf;
|
||||
*STDOUT->flush();
|
||||
}
|
||||
} elsif ($h eq $error) {
|
||||
if ($errfunc) {
|
||||
eval {
|
||||
$errlog .= $buf;
|
||||
while ($errlog =~ s/^([^\010\r\n]*)(\r|\n|(\010)+|\r\n)//s) {
|
||||
my $line = $1;
|
||||
&$errfunc($line);
|
||||
}
|
||||
};
|
||||
my $err = $@;
|
||||
if ($err) {
|
||||
kill (9, $pid);
|
||||
waitpid ($pid, 0);
|
||||
die $err;
|
||||
}
|
||||
} else {
|
||||
print STDERR $buf;
|
||||
*STDERR->flush();
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
&$outfunc($outlog) if $outfunc && $outlog;
|
||||
&$errfunc($errlog) if $errfunc && $errlog;
|
||||
|
||||
waitpid ($pid, 0);
|
||||
|
||||
if ($? == -1) {
|
||||
die "failed to execute\n";
|
||||
} elsif (my $sig = ($? & 127)) {
|
||||
die "got signal $sig\n";
|
||||
} elsif (my $ec = ($? >> 8)) {
|
||||
if ($errmsg && $laststderr) {
|
||||
my $lerr = $laststderr;
|
||||
$laststderr = undef;
|
||||
die "$lerr\n";
|
||||
}
|
||||
die "exit code $ec\n";
|
||||
}
|
||||
|
||||
alarm(0);
|
||||
};
|
||||
|
||||
my $err = $@;
|
||||
|
||||
alarm(0);
|
||||
|
||||
print STDERR "$laststderr\n" if $laststderr;
|
||||
|
||||
umask ($old_umask) if defined($old_umask);
|
||||
|
||||
alarm($oldtimeout) if $oldtimeout;
|
||||
|
||||
if ($err) {
|
||||
if ($pid && ($err eq "got timeout\n")) {
|
||||
kill (9, $pid);
|
||||
waitpid ($pid, 0);
|
||||
die "command '$cmdstr' failed: $err";
|
||||
}
|
||||
|
||||
if ($errmsg) {
|
||||
die "$errmsg: $err";
|
||||
} else {
|
||||
die "command '$cmdstr' failed: $err";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub split_list {
|
||||
my $listtxt = shift || '';
|
||||
|
||||
$listtxt =~ s/[,;\0]/ /g;
|
||||
$listtxt =~ s/^\s+//;
|
||||
|
||||
my @data = split (/\s+/, $listtxt);
|
||||
|
||||
return @data;
|
||||
}
|
||||
|
||||
sub trim {
|
||||
my $txt = shift;
|
||||
|
||||
return $txt if !defined($txt);
|
||||
|
||||
$txt =~ s/^\s+//;
|
||||
$txt =~ s/\s+$//;
|
||||
|
||||
return $txt;
|
||||
}
|
||||
|
||||
# simple uri templates like "/vms/{vmid}"
|
||||
sub template_replace {
|
||||
my ($tmpl, $data) = @_;
|
||||
|
||||
my $res = '';
|
||||
while ($tmpl =~ m/([^{]+)?({([^}]+)})?/g) {
|
||||
$res .= $1 if $1;
|
||||
$res .= ($data->{$3} || '-') if $2;
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub safe_print {
|
||||
my ($filename, $fh, $data) = @_;
|
||||
|
||||
return if !$data;
|
||||
|
||||
my $res = print $fh $data;
|
||||
|
||||
die "write to '$filename' failed\n" if !$res;
|
||||
}
|
||||
|
||||
sub debmirrors {
|
||||
|
||||
return {
|
||||
'at' => 'ftp.at.debian.org',
|
||||
'au' => 'ftp.au.debian.org',
|
||||
'be' => 'ftp.be.debian.org',
|
||||
'bg' => 'ftp.bg.debian.org',
|
||||
'br' => 'ftp.br.debian.org',
|
||||
'ca' => 'ftp.ca.debian.org',
|
||||
'ch' => 'ftp.ch.debian.org',
|
||||
'cl' => 'ftp.cl.debian.org',
|
||||
'cz' => 'ftp.cz.debian.org',
|
||||
'de' => 'ftp.de.debian.org',
|
||||
'dk' => 'ftp.dk.debian.org',
|
||||
'ee' => 'ftp.ee.debian.org',
|
||||
'es' => 'ftp.es.debian.org',
|
||||
'fi' => 'ftp.fi.debian.org',
|
||||
'fr' => 'ftp.fr.debian.org',
|
||||
'gr' => 'ftp.gr.debian.org',
|
||||
'hk' => 'ftp.hk.debian.org',
|
||||
'hr' => 'ftp.hr.debian.org',
|
||||
'hu' => 'ftp.hu.debian.org',
|
||||
'ie' => 'ftp.ie.debian.org',
|
||||
'is' => 'ftp.is.debian.org',
|
||||
'it' => 'ftp.it.debian.org',
|
||||
'jp' => 'ftp.jp.debian.org',
|
||||
'kr' => 'ftp.kr.debian.org',
|
||||
'mx' => 'ftp.mx.debian.org',
|
||||
'nl' => 'ftp.nl.debian.org',
|
||||
'no' => 'ftp.no.debian.org',
|
||||
'nz' => 'ftp.nz.debian.org',
|
||||
'pl' => 'ftp.pl.debian.org',
|
||||
'pt' => 'ftp.pt.debian.org',
|
||||
'ro' => 'ftp.ro.debian.org',
|
||||
'ru' => 'ftp.ru.debian.org',
|
||||
'se' => 'ftp.se.debian.org',
|
||||
'si' => 'ftp.si.debian.org',
|
||||
'sk' => 'ftp.sk.debian.org',
|
||||
'tr' => 'ftp.tr.debian.org',
|
||||
'tw' => 'ftp.tw.debian.org',
|
||||
'gb' => 'ftp.uk.debian.org',
|
||||
'us' => 'ftp.us.debian.org',
|
||||
};
|
||||
}
|
||||
|
||||
sub kvmkeymaps {
|
||||
return {
|
||||
'dk' => ['Danish', 'da', 'qwerty/dk-latin1.kmap.gz', 'dk', 'nodeadkeys'],
|
||||
'de' => ['German', 'de', 'qwertz/de-latin1-nodeadkeys.kmap.gz', 'de', 'nodeadkeys' ],
|
||||
'de-ch' => ['Swiss-German', 'de-ch', 'qwertz/sg-latin1.kmap.gz', 'ch', 'de_nodeadkeys' ],
|
||||
'en-gb' => ['United Kingdom', 'en-gb', 'qwerty/uk.kmap.gz' , 'gb', 'intl' ],
|
||||
'en-us' => ['U.S. English', 'en-us', 'qwerty/us-latin1.kmap.gz', 'us', 'intl' ],
|
||||
'es' => ['Spanish', 'es', 'qwerty/es.kmap.gz', 'es', 'nodeadkeys'],
|
||||
#'et' => [], # Ethopia or Estonia ??
|
||||
'fi' => ['Finnish', 'fi', 'qwerty/fi-latin1.kmap.gz', 'fi', 'nodeadkeys'],
|
||||
#'fo' => ['Faroe Islands', 'fo', ???, 'fo', 'nodeadkeys'],
|
||||
'fr' => ['French', 'fr', 'azerty/fr-latin1.kmap.gz', 'fr', 'nodeadkeys'],
|
||||
'fr-be' => ['Belgium-French', 'fr-be', 'azerty/be2-latin1.kmap.gz', 'be', 'nodeadkeys'],
|
||||
'fr-ca' => ['Canada-French', 'fr-ca', 'qwerty/cf.kmap.gz', 'ca', 'fr-legacy'],
|
||||
'fr-ch' => ['Swiss-French', 'fr-ch', 'qwertz/fr_CH-latin1.kmap.gz', 'ch', 'fr_nodeadkeys'],
|
||||
#'hr' => ['Croatia', 'hr', 'qwertz/croat.kmap.gz', 'hr', ??], # latin2?
|
||||
'hu' => ['Hungarian', 'hu', 'qwertz/hu.kmap.gz', 'hu', undef],
|
||||
'is' => ['Icelandic', 'is', 'qwerty/is-latin1.kmap.gz', 'is', 'nodeadkeys'],
|
||||
'it' => ['Italian', 'it', 'qwerty/it2.kmap.gz', 'it', 'nodeadkeys'],
|
||||
'jp' => ['Japanese', 'ja', 'qwerty/jp106.kmap.gz', 'jp', undef],
|
||||
'lt' => ['Lithuanian', 'lt', 'qwerty/lt.kmap.gz', 'lt', 'std'],
|
||||
#'lv' => ['Latvian', 'lv', 'qwerty/lv-latin4.kmap.gz', 'lv', ??], # latin4 or latin7?
|
||||
'mk' => ['Macedonian', 'mk', 'qwerty/mk.kmap.gz', 'mk', 'nodeadkeys'],
|
||||
'nl' => ['Dutch', 'nl', 'qwerty/nl.kmap.gz', 'nl', undef],
|
||||
#'nl-be' => ['Belgium-Dutch', 'nl-be', ?, ?, ?],
|
||||
'no' => ['Norwegian', 'no', 'qwerty/no-latin1.kmap.gz', 'no', 'nodeadkeys'],
|
||||
'pl' => ['Polish', 'pl', 'qwerty/pl.kmap.gz', 'pl', undef],
|
||||
'pt' => ['Portuguese', 'pt', 'qwerty/pt-latin1.kmap.gz', 'pt', 'nodeadkeys'],
|
||||
'pt-br' => ['Brazil-Portuguese', 'pt-br', 'qwerty/br-latin1.kmap.gz', 'br', 'nodeadkeys'],
|
||||
#'ru' => ['Russian', 'ru', 'qwerty/ru.kmap.gz', 'ru', undef], # dont know?
|
||||
'si' => ['Slovenian', 'sl', 'qwertz/slovene.kmap.gz', 'si', undef],
|
||||
#'sv' => [], Swedish ?
|
||||
#'th' => [],
|
||||
#'tr' => [],
|
||||
};
|
||||
}
|
||||
|
||||
sub extract_param {
|
||||
my ($param, $key) = @_;
|
||||
|
||||
my $res = $param->{$key};
|
||||
delete $param->{$key};
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub next_vnc_port {
|
||||
|
||||
for (my $p = 5900; $p < 6000; $p++) {
|
||||
|
||||
my $sock = IO::Socket::INET->new (Listen => 5,
|
||||
LocalAddr => 'localhost',
|
||||
LocalPort => $p,
|
||||
ReuseAddr => 1,
|
||||
Proto => 0);
|
||||
|
||||
if ($sock) {
|
||||
close ($sock);
|
||||
return $p;
|
||||
}
|
||||
}
|
||||
|
||||
die "unable to find free vnc port";
|
||||
};
|
||||
|
||||
# NOTE: NFS syscall can't be interrupted, so alarm does
|
||||
# not work to provide timeouts.
|
||||
# from 'man nfs': "Only SIGKILL can interrupt a pending NFS operation"
|
||||
# So the spawn external 'df' process instead of using
|
||||
# Filesys::Df (which uses statfs syscall)
|
||||
sub df {
|
||||
my ($path, $timeout) = @_;
|
||||
|
||||
my $cmd = [ 'df', '-P', '-B', '1', $path];
|
||||
|
||||
my $res = {
|
||||
total => 0,
|
||||
used => 0,
|
||||
avail => 0,
|
||||
};
|
||||
|
||||
my $parser = sub {
|
||||
my $line = shift;
|
||||
if (my ($fsid, $total, $used, $avail) = $line =~
|
||||
m/^(\S+.*)\s+(\d+)\s+(\d+)\s+(\d+)\s+\d+%\s.*$/) {
|
||||
$res = {
|
||||
total => $total,
|
||||
used => $used,
|
||||
avail => $avail,
|
||||
};
|
||||
}
|
||||
};
|
||||
eval { run_command($cmd, timeout => $timeout, outfunc => $parser); };
|
||||
warn $@ if $@;
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
# UPID helper
|
||||
# We use this to uniquely identify a process.
|
||||
# An 'Unique Process ID' has the following format:
|
||||
# "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
|
||||
|
||||
sub upid_encode {
|
||||
my $d = shift;
|
||||
|
||||
return sprintf("UPID:%s:%08X:%08X:%08X:%s:%s:%s:", $d->{node}, $d->{pid},
|
||||
$d->{pstart}, $d->{starttime}, $d->{type}, $d->{id},
|
||||
$d->{user});
|
||||
}
|
||||
|
||||
sub upid_decode {
|
||||
my ($upid, $noerr) = @_;
|
||||
|
||||
my $res;
|
||||
my $filename;
|
||||
|
||||
# "UPID:$node:$pid:$pstart:$startime:$dtype:$id:$user"
|
||||
if ($upid =~ m/^UPID:([A-Za-z][[:alnum:]\-]*[[:alnum:]]+):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([0-9A-Fa-f]{8}):([^:\s]+):([^:\s]*):([^:\s]+):$/) {
|
||||
$res->{node} = $1;
|
||||
$res->{pid} = hex($2);
|
||||
$res->{pstart} = hex($3);
|
||||
$res->{starttime} = hex($4);
|
||||
$res->{type} = $5;
|
||||
$res->{id} = $6;
|
||||
$res->{user} = $7;
|
||||
|
||||
my $subdir = substr($4, 7, 8);
|
||||
$filename = "$pvetaskdir/$subdir/$upid";
|
||||
|
||||
} else {
|
||||
return undef if $noerr;
|
||||
die "unable to parse worker upid '$upid'\n";
|
||||
}
|
||||
|
||||
return wantarray ? ($res, $filename) : $res;
|
||||
}
|
||||
|
||||
sub upid_open {
|
||||
my ($upid) = @_;
|
||||
|
||||
my ($task, $filename) = upid_decode($upid);
|
||||
|
||||
my $dirname = dirname($filename);
|
||||
make_path($dirname);
|
||||
|
||||
my $wwwid = getpwnam('www-data') ||
|
||||
die "getpwnam failed";
|
||||
|
||||
my $perm = 0640;
|
||||
|
||||
my $outfh = IO::File->new ($filename, O_WRONLY|O_CREAT|O_EXCL, $perm) ||
|
||||
die "unable to create output file '$filename' - $!\n";
|
||||
chown $wwwid, $outfh;
|
||||
|
||||
return $outfh;
|
||||
};
|
||||
|
||||
sub upid_read_status {
|
||||
my ($upid) = @_;
|
||||
|
||||
my ($task, $filename) = upid_decode($upid);
|
||||
my $fh = IO::File->new($filename, "r");
|
||||
return "unable to open file - $!" if !$fh;
|
||||
my $maxlen = 1024;
|
||||
sysseek($fh, -$maxlen, 2);
|
||||
my $readbuf = '';
|
||||
my $br = sysread($fh, $readbuf, $maxlen);
|
||||
close($fh);
|
||||
if ($br) {
|
||||
return "unable to extract last line"
|
||||
if $readbuf !~ m/\n?(.+)$/;
|
||||
my $line = $1;
|
||||
if ($line =~ m/^TASK OK$/) {
|
||||
return 'OK';
|
||||
} elsif ($line =~ m/^TASK ERROR: (.+)$/) {
|
||||
return $1;
|
||||
} else {
|
||||
return "unexpected status";
|
||||
}
|
||||
}
|
||||
return "unable to read tail (got $br bytes)";
|
||||
}
|
||||
|
||||
# useful functions to store comments in config files
|
||||
sub encode_text {
|
||||
my ($text) = @_;
|
||||
|
||||
# all control and hi-bit characters, and ':'
|
||||
my $unsafe = "^\x20-\x39\x3b-\x7e";
|
||||
return uri_escape(Encode::encode("utf8", $text), $unsafe);
|
||||
}
|
||||
|
||||
sub decode_text {
|
||||
my ($data) = @_;
|
||||
|
||||
return Encode::decode("utf8", uri_unescape($data));
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
30
debian/changelog
vendored
Normal file
30
debian/changelog
vendored
Normal file
@ -0,0 +1,30 @@
|
||||
libpve-common-perl (1.0-5) unstable; urgency=low
|
||||
|
||||
* cleanups (prepare for beta release)
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Thu, 11 Aug 2011 07:23:00 +0200
|
||||
|
||||
libpve-common-perl (1.0-4) unstable; urgency=low
|
||||
|
||||
* CLIHandler.pm: new command 'printmanpod' to generate manual pages.
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Wed, 10 Aug 2011 10:17:55 +0200
|
||||
|
||||
libpve-common-perl (1.0-3) unstable; urgency=low
|
||||
|
||||
* fix CLIHandler.pm
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Fri, 05 Aug 2011 12:40:17 +0200
|
||||
|
||||
libpve-common-perl (1.0-2) unstable; urgency=low
|
||||
|
||||
* depend on liburi-perl
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Thu, 14 Jul 2011 12:03:37 +0200
|
||||
|
||||
libpve-common-perl (1.0-1) unstable; urgency=low
|
||||
|
||||
* initial package
|
||||
|
||||
-- Proxmox Support Team <support@proxmox.com> Mon, 09 Aug 2010 14:54:24 +0200
|
||||
|
||||
1
debian/compat
vendored
Normal file
1
debian/compat
vendored
Normal file
@ -0,0 +1 @@
|
||||
7
|
||||
12
debian/control
vendored
Normal file
12
debian/control
vendored
Normal file
@ -0,0 +1,12 @@
|
||||
Source: libpve-common-perl
|
||||
Section: perl
|
||||
Priority: extra
|
||||
Maintainer: Proxmox Support Team <support@proxmox.com>
|
||||
Build-Depends: debhelper (>= 7.0.50~)
|
||||
Standards-Version: 3.8.4
|
||||
|
||||
Package: libpve-common-perl
|
||||
Architecture: all
|
||||
Depends: ${perl:Depends} ${misc:Depends}, libdevel-cycle-perl, libwww-perl, libjson-perl, liblinux-inotify2-perl, libio-stringy-perl, liburi-perl
|
||||
Description: Proxmox VE base library
|
||||
This package contains the base library used by other Proxmox VE components.
|
||||
16
debian/copyright
vendored
Normal file
16
debian/copyright
vendored
Normal file
@ -0,0 +1,16 @@
|
||||
Copyright (C) 2010 Proxmox Server Solutions GmbH
|
||||
|
||||
This software is written by Proxmox Server Solutions GmbH <support@proxmox.com>
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Affero General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Affero General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Affero General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
13
debian/rules
vendored
Executable file
13
debian/rules
vendored
Executable file
@ -0,0 +1,13 @@
|
||||
#!/usr/bin/make -f
|
||||
# -*- makefile -*-
|
||||
# Sample debian/rules that uses debhelper.
|
||||
# This file was originally written by Joey Hess and Craig Small.
|
||||
# As a special exception, when this file is copied by dh-make into a
|
||||
# dh-make output file, you may use that output file without restriction.
|
||||
# This special exception was added by Craig Small in version 0.37 of dh-make.
|
||||
|
||||
# Uncomment this to turn on verbose mode.
|
||||
#export DH_VERBOSE=1
|
||||
|
||||
%:
|
||||
dh $@
|
||||
Loading…
Reference in New Issue
Block a user