File Coverage

lib/OpenVZ/Vzctl.pm

Criterion	Covered	Total	%
statement	127	130	97.6
branch	36	52	69.2
condition	11	15	73.3
subroutine	28	30	93.3
pod	7	7	100.0
total	209	234	89.3

package OpenVZ::Vzctl;

# ABSTRACT: Call OpenVZ vzctl command from your program

#XXX: Do we need to load and parse the VZ system config file?
#XXX: Need to abstract out the common code into a top level OpenVZ module.
#XXX: Need to handle version call
#XXX: Need to use 'on_fail' option for validate_with for smoother error
#     handling.


use 5.006;

use strict;
use warnings;

use namespace::autoclean;

use Carp;
use List::MoreUtils qw( any );
use OpenVZ ':all';
use Params::Validate ':all';
use Regexp::Common qw( URI net );
use Scalar::Util 'blessed';
use Sub::Exporter;

use parent 'OpenVZ';

our $VERSION = '0.01'; # VERSION

our $AUTOLOAD;

############################################################################
# Base structure describing the subcommands and their arguments.


# Every subcommand requires ctid and has the optional flag of C or C.  Though these flags are mutually exclusive,
# C will accept both at the same time.  Results are undefined when using both flag at the same time.  However, this code is
# setup to accept only one or the other.

# Surrounding a paremeter with square brackets ( [parm] ) will make the parm optional in C.

{  # Quick, hide in here! And don't make a *sound*!

    my @vzctl_exports;

    push @vzctl_exports, 'execute';  # imported from OpenVZ

    my %vzctl = (

        destroy   => [],
        mount     => [],
        quotainit => [],
        quotaoff  => [],
        quotaon   => [],
        restart   => [],
        status    => [],
        stop      => [],
        umount    => [],
        exec      => [qw( command )],
        exec2     => [qw( command )],
        runscript => [qw( script )],
        start     => [qw( [force] [wait] )],
        enter     => [qw( [exec] )],
        chkpnt    => [qw( [create_dumpfile] )],
        restore   => [qw( [restore_dumpfile] )],
        create    => [qw( [config] [hostname] [ipadd] [ostemplate] [private] [root] )],

        set => [ qw(

                [applyconfig] [applyconfig_map] [avnumproc] [bootorder] [capability]
                [cpulimit] [cpumask] [cpus] [cpuunits] [dcachesize] [devices] [devnodes]
                [dgramrcvbuf] [disabled] [diskinodes] [diskspace] [features] [force]
                [hostname] [ioprio] [ipadd] [ipdel] [iptables] [kmemsize] [lockedpages]
                [name] [nameserver] [netif_add] [netif_del] [noatime] [numfile]
                [numflock] [numiptent] [numothersock] [numproc] [numpty] [numsiginfo]
                [numtcpsock] [onboot] [oomguarpages] [othersockbuf] [pci_add] [pci_del]
                [physpages] [privvmpages] [quotatime] [quotaugidlimit] [save]
                [searchdomain] [setmode] [shmpages] [swappages] [tcprcvbuf] [tcpsndbuf]
                [userpasswd] [vmguarpages]

                ),
        ],

    );

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


    push @vzctl_exports, 'known_commands';

    sub known_commands { return keys %vzctl }

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


    push @vzctl_exports, 'known_options';

    my $commands_rx = join q{|}, keys %vzctl;

    sub known_options { ## no critic qw( Subroutines::RequireArgUnpacking )

        #my @spec; $spec[0] = { type => SCALAR, regex => qr/^$commands_rx$/ };
        my @spec = ( { type => SCALAR, regex => qr/^$commands_rx$/ } );

        my @arg = validate_with( params => \@_, spec => \@spec );

        my @options = ( 'flag', 'ctid', @{ $vzctl{ $arg[0] } } );

        return wantarray ? @options : \@options;

    }

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


    my @capabilities = qw(

        chown dac_override dac_read_search fowner fsetid ipc_lock ipc_owner kill
        lease linux_immutable mknod net_admin net_bind_service net_broadcast
        net_raw setgid setpcap setuid setveid sys_admin sys_boot sys_chroot
        sys_module sys_nice sys_pacct sys_ptrace sys_rawio sys_resource sys_time
        sys_tty_config ve_admin

    );

    push @vzctl_exports, 'capabilities';

    sub capabilities { return wantarray ? @capabilities : \@capabilities }

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


    my @iptables_modules = qw(

        ip_conntrack ip_conntrack_ftp ip_conntrack_irc ip_nat_ftp ip_nat_irc
        iptable_filter iptable_mangle iptable_nat ipt_conntrack ipt_helper
        ipt_length ipt_limit ipt_LOG ipt_multiport ipt_owner ipt_recent
        ipt_REDIRECT ipt_REJECT ipt_state ipt_tcpmss ipt_TCPMSS ipt_tos ipt_TOS
        ipt_ttl xt_mac

    );

    push @vzctl_exports, 'iptables_modules';

    sub iptables_modules { return wantarray ? @iptables_modules : \@iptables_modules }

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


    my @features = qw( sysfs nfs sit ipip ppp ipgre bridge nfsd );

    push @vzctl_exports, 'features';

    sub features { return wantarray ? @features : \@features }

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

    my %validate = do {

        my $capability_names = join q{|}, @capabilities;
        my $iptables_names   = join q{|}, @iptables_modules;
        my $features_names   = join q{|}, @features;

        my %hash = (

            # XXX: Annoying.  Need to submit a bug for this.
            ## no critic qw( Variables::ProhibitPunctuationVars )
            avnumproc  => { type => SCALAR, regex     => qr{^\d+[gmkp]?(?::\d+[gmkp]?)?$}i },
            bootorder  => { type => SCALAR, regex     => qr{^\d+$} },
            capability => { type => SCALAR, regex     => qr{^(?:$capability_names):(?:on|off)$}i },
            cpumask    => { type => SCALAR, regex     => qr{^\d+(?:[,-]\d+)*|all$}i },
            ctid       => { type => SCALAR, callbacks => { 'validate ctid' => \&_validate_ctid } },
            devices    => { type => SCALAR, regex     => qr{^(?:(?:[bc]:\d+:\d+)|all:(?:r?w?))|none$}i },
            features   => { type => SCALAR, regex     => qr{^(?:$features_names):(?:on|off)$}i },
            flag       => { type => SCALAR, regex     => qr{^quiet|verbose$}i },
            force      => { type => UNDEF },
            ioprio     => { type => SCALAR, regex => qr{^[0-7]$} },
            onboot     => { type => SCALAR, regex => qr{^yes|no$}i },
            setmode    => { type => SCALAR, regex => qr{^restart|ignore$}i },
            userpasswd => { type => SCALAR, regex => qr{^(?:\w+):(?:\w+)$} },
            ## use critic

            applyconfig => { type => SCALAR, callbacks => { 'do not want empty strings' => sub { return $_[0] ne '' }, }, },

            command => {
                type      => SCALAR | ARRAYREF,
                callbacks => {
                    'do not want empty values' => sub {

                        return ref $_[0] eq ''
                            ? do { $_[0] ne '' }
                            : do { defined $_[0]->[0] && $_[0]->[0] ne '' };

                    },
                },
            },

            ipadd => {
                type      => SCALAR | ARRAYREF,
                callbacks => {
                    'do these look like valid ip(s)?' => sub {

                        my @ips = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : $_[0];
                        return unless @ips;

                        # I'd rather not do
                        no warnings 'uninitialized'; ## no critic qw( TestingAndDebugging::ProhibitNoWarnings )

                        # but
                        # my @bad_ips = grep { defined    && ! /^$RE{net}{IPv4}$/ } @ips;
                        # my @bad_ips = grep { defined $_ && ! /^$RE{net}{IPv4}$/ } @ips;
                        # don't work and I'm not sure what else to try.
                        my @bad_ips = grep { ! /^$RE{net}{IPv4}$/ } @ips;
                        return ! @bad_ips;  # return 1 if there are no bad ips, undef otherwise.

                        #NOTE: I can't find a way to modify the incoming data, and it may not
                        #      be a good idea to do that in any case. Unless, and until, I can
                        #      figure out how to do this the right way this will be an atomic
                        #      operation. It's either all good, or it's not.

                    },
                },
            },

            ipdel => {
                type      => SCALAR | ARRAYREF,
                callbacks => {
                    'do these look like valid ip(s)?' => sub {

                        my @ips = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : $_[0];
                        return unless @ips;

                        # see notes for ipadd
                        no warnings 'uninitialized'; ## no critic qw( TestingAndDebugging::ProhibitNoWarnings )
                        my @bad_ips = grep { ! /^$RE{net}{IPv4}$/ } @ips;
                        return 1 if any { $_ eq 'all' } @bad_ips;
                        return ! @bad_ips;

                        #NOTE: See ipadd note.

                    },
                },
            },

            iptables => {
                type      => SCALAR | ARRAYREF,
                callbacks => {
                    'see manpage for list of valid iptables names' => sub {

                        my @names;

                        if ( ref $_[0] eq 'ARRAY' ) {

                            @names = @{ $_[0] };
                            return if @names == 0;

                        } else {

                            return if ! defined $_[0] || $_[0] eq '';
                            my $names = shift;
                            @names = split /\s+/, $names;

                        }

                        # see notes for ipadd
                        no warnings 'uninitialized'; ## no critic qw( TestingAndDebugging::ProhibitNoWarnings )
                        my @bad_names = grep { ! /^(?:$iptables_names):o(?:n|ff)$/ } @names;
                        return ! @bad_names;

                        #NOTE: See ipadd note.

                    },
                },
            },

            create_dumpfile => {
                type      => SCALAR,
                callbacks => {
                    'does it look like a valid filename?' => sub {
                        return if $_[0] eq '';
                        my $file = sprintf 'file://localhost/%s', +shift;
                        $file =~ /^$RE{URI}{file}$/;
                    },
                },
            },

            restore_dumpfile => { type => SCALAR, callbacks => { 'does file exist?' => sub { -e ( +shift ) }, }, },

            devnodes => {
                type      => SCALAR,
                callbacks => {
                    'setting access to devnode' => sub {

                        return if ! defined $_[0] || $_[0] eq '';
                        return 1 if $_[0] eq 'none';
                        ( my $device = $_[0] ) =~ s/^(.*?):r?w?q?$/$1/;
                        $device = "/dev/$device";
                        return -e $device;

                    },
                },
            },

        );

        my %same = (

            # SCALAR checks
            applyconfig => [ qw(

                    applyconfig_map config hostname name netif_add netif_del ostemplate
                    pci_add pci_del private root searchdomain

                    ),
            ],

            #XXX: Need to make 'config', 'ostemplate', 'private' and 'root' more
            #     robust.  We can pull the data from the global config file to help
            #     validate this info.

            # SCALAR | ARRAYREF checks
            command => [qw( exec script )],

            # UNDEF checks
            force => [qw( save wait )],

            # INT checks
            bootorder => [qw( cpulimit cpus cpuunits quotatime quotaugidlimit )],

            # yes or no checks
            onboot => [qw( disabled noatime )],

            # ip checks
            ipadd => [qw( nameserver )],

            # hard|soft limits
            avnumproc => [ qw(

                    dcachesize dgramrcvbuf diskinodes diskspace kmemsize lockedpages numfile
                    numflock numiptent numothersock numproc numpty numsiginfo numtcpsock
                    oomguarpages othersockbuf physpages privvmpages shmpages swappages
                    tcprcvbuf tcpsndbuf vmguarpages

                    ),
            ],
        );

        for my $key ( keys %same ) {

            $hash{ $_ } = $hash{ $key } for @{ $same{ $key } };

        }

        %hash;

    };

    ############################################################################
    # Public functions

    #XXX: Some of these should be extracted out into common module (OpenVZ.pm?)

    my %global;
    my $spec = subcommand_specs( qw( flag ctid ) );
    my $subcommands = join q{|}, sort( known_commands() );
    $spec->{ subcommand } = { regex => qr/^$subcommands$/ }; ## no critic qw( ValuesAndExpressions::ProhibitAccessOfPrivateData )

    my %hash = ( command => 'vzctl' );

    push @vzctl_exports, 'vzctl';

    sub vzctl { ## no critic qw( Subroutines::RequireArgUnpacking )

        shift if blessed $_[0];

        my %arg = validate_with( params => @_, spec => $spec, allow_extra => 1, );

        my @params;

        push @params, ( sprintf '--%s', delete $arg{ flag } )
            if exists $arg{ flag };

        push @params, delete $arg{ subcommand };

        delete $arg{ ctid };
        push @params, $global{ ctid };

        for my $p ( keys %arg ) {

            # XXX: Need better way to determine if this is a bare option
            #      maybe '!option' to indicate this option should be bare?

            my $arg_name = $p =~ /^command|script$/ ? '' : "--$p";
            my $ref = ref $arg{ $p };

            if ( $ref eq 'ARRAY' ) {

                push @params, ( $arg_name, $_ ) for @{ $arg{ $p } };

            } elsif ( $ref eq '' ) {

                push @params, $arg_name;

                # coverage: I don't see a way to test for ! defined $arg{$p}
                # ... so we'll have to accept a 67% coverage for this one.

                push @params, $arg{ $p }
                    if defined $arg{ $p } && $arg{ $p } ne '';

            } else {

                croak "Don't know how to handle ref type $ref for $p";

            }
        } ## end for my $p ( keys %arg)

        @params = grep { $_ ne '' } @params;

        $hash{ params } = \@params;

        return execute( \%hash );

    } ## end sub vzctl

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

    push @vzctl_exports, 'subcommand_specs';

    sub subcommand_specs { ## no critic qw( Subroutines::RequireArgUnpacking )

        shift if blessed $_[0];

        my @args = validate_with( params => \@_, spec => [ { type => SCALAR } ], allow_extra => 1, );

        my %spec_hash;

        if ( defined $subcommands && $args[0] =~ /^$subcommands$/ ) {

            # then build predefined specification hash

            my @specs = @{ $vzctl{ +shift @args } };

            # Every subcommand has these two at a minimum.
            unshift @specs, '[flag]', 'ctid';

            for my $spec ( @specs ) {

                my $optional = $spec =~ s/^\[(.*)\]$/$1/;

                croak "Unknown spec $spec"
                    unless exists $validate{ $spec };

                next if any { /^-$spec$/ } @args;

                $spec_hash{ $spec } = $validate{ $spec };

                $spec_hash{ $spec }{ optional } = 1
                    if $optional;

            }
        } ## end if ( defined $subcommands...)

        # build custom specification hash if any args are left

        for my $spec ( @args ) {

            next if $spec =~ /^-/;
            next if exists $spec_hash{ $spec };

            croak "Unknown spec $spec"
                unless exists $validate{ $spec };

            $spec_hash{ $spec } = $validate{ $spec };

        }

        return \%spec_hash;

    } ## end sub subcommand_specs

############################################################################
    # Internal Functions

    #XXX: Should be extracted out into common module (OpenVZ.pm?)

    # Is the provided ctid a valid container identifier?

    sub _validate_ctid { ## no critic qw( Subroutines::RequireArgUnpacking )

        shift if blessed $_[0];

        #my ( $ctid, $params ) = @_;
        my $check_ctid = shift;

        {
            no warnings qw( numeric uninitialized ); ## no critic qw( TestingAndDebugging::ProhibitNoWarnings )

            # coverage: we can't check against ! exists, so we'll have to live
            # with a 71% coverage on this one.

            return 1
                if ( exists $global{ ctid } && $global{ ctid } == $check_ctid )
                || ( exists $global{ name } && $global{ name } eq $check_ctid );
        }

        # XXX: Need to modify this when vzlist is handled so we keep things
        # uncluttered.

        my ( $stdout, $stderr, $syserr ) = execute( { command => 'vzlist', params => [ '-Ho', 'ctid,name', $check_ctid ], } );

        ## no critic qw( ErrorHandling::RequireUseOfExceptions ValuesAndExpressions::ProhibitMagicNumbers )
        croak 'vzlist did not execute'
            if $syserr == -1;

        $syserr >>= 8;

        croak "Invalid or unknown container ($check_ctid): $stderr"
            if $syserr == 1;
        ## use critic

        $stdout =~ s/^\s*(.*?)\s*$/$1/;
        my ( $ctid, $name ) = split /\s+/, $stdout;

        $global{ ctid } = $ctid;
        $global{ name } = $name;

        return 1;

    } ## end sub _validate_ctid

    # Generate the code for each of the subcommands
    # https://metacpan.org/module/Sub::Exporter#Export-Configuration

    sub _generate_subcommand { ## no critic qw( Subroutines::RequireArgUnpacking )

        shift if blessed $_[0];

        #XXX: Need to handle case of calling class using something like
        #
        # use OpenVZ::vzctl set => { -as => 'setip', arg => 'ipadd' };
        #
        # and creating a sub that only accepts the ipadd parameter.

        #my ( $class, $name, $arg, $collection ) = @_;
        my ( undef, $subcommand ) = @_;
        my $subcommand_spec = subcommand_specs( $subcommand );

        my %sub_spec;

        $sub_spec{ spec } = $subcommand_spec;

        return sub {

            shift if blessed $_[0];

            $sub_spec{ params } = \@_;

            my %arg = validate_with( %sub_spec );
            $arg{ subcommand } = $subcommand;
            vzctl( \%arg );

        };
    } ## end sub _generate_subcommand

    # for oop stuff

    # XXX: Do we need/want to support methods for the various options (what is returned from subcommand_specs)?

    sub AUTOLOAD { ## no critic qw( Subroutines::RequireArgUnpacking ClassHierarchies::ProhibitAutoloading )

        carp "$_[0] is not an object"
            unless blessed $_[0];

        ( my $subcommand = $AUTOLOAD ) =~ s/^.*:://;

        carp "$subcommand is not a valid method"
            unless exists $vzctl{ $subcommand };

        ## no critic qw( TestingAndDebugging::ProhibitNoStrict References::ProhibitDoubleSigils )
        no strict 'refs';
        *$AUTOLOAD = _generate_subcommand( undef, $subcommand );

        goto &$AUTOLOAD;
        ## use critic

    } ## end sub AUTOLOAD

    # AUTOLOAD assumes DESTROY exists
    DESTROY { }

    push @vzctl_exports, ( $_ => \&_generate_subcommand ) for keys %vzctl;

############################################################################
    # Setup exporter

    my $config = {

        exports    => \@vzctl_exports,
        groups     => {},
        collectors => [],

    };

    Sub::Exporter::setup_exporter( $config );

}  # Ok, they're gone.  You can come out now.  Guys?  Hello?

1;

__END__