File Coverage

blib/lib/Paranoid/Args.pm

Criterion	Covered	Total	%
statement	261	325	80.3
branch	114	164	69.5
condition	56	87	64.3
subroutine	25	25	100.0
pod	3	3	100.0
total	459	604	75.9

# Paranoid::Args -- Command-line argument parsing functions
#
# $Id: lib/Paranoid/Args.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Args;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Paranoid::Debug qw(:all);

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT      = qw(parseArgs);
@EXPORT_OK   = ( @EXPORT, qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION) );
%EXPORT_TAGS = (
    all      => [@EXPORT_OK],
    template => [qw(PA_DEBUG PA_VERBOSE PA_HELP PA_VERSION)],
    );

# I know, this really doesn't protect the contents...
use constant PA_DEBUG => {
    Short      => 'D',
    Long       => 'debug',
    CountShort => 1,
    };
use constant PA_VERBOSE => {
    Short      => 'v',
    Long       => 'verbose',
    CountShort => 1,
    };
use constant PA_HELP => {
    Short => 'h',
    Long  => 'help',
    };
use constant PA_VERSION => {
    Short => 'V',
    Long  => 'version',
    };

#####################################################################
#
# Module code follows
#
#####################################################################

{

    # Internal boolean flag for noOptions
    my $noOptions = 0;

    sub _NOOPTIONS : lvalue {

        # Purpose:  Gets/sets value of boolean flag $noOptions
        # Returns:  Value of $noOptions
        # Usage:    $flag = _NOOPTIONS;
        # Usage:    _NOOPTIONS = 1;

        $noOptions;
    }

    # Internal errors array
    my @errors;

    sub _resetErrors {

        # Purpose:  Empties @errors
        # Returns:  True (1)
        # Usage:    resetErrors();

        @errors = ();
        return 1;
    }

    sub _pushErrors {

        # Purpose:  Pushes a new string onto the @errors array
        # Returns:  Same argument as called with
        # Usage:    _pushErrors($message);

        my $message = shift;
        push @errors, $message;
        return $message;
    }

    sub listErrors {

        # Purpose:  Gets the contents of @errors
        # Returns:  Contents of @errors
        # Usage:    @errors = listErrors();

        my ( %messages, $n, @indices );

        # Filter out redundant messages
        $n = 0;
        foreach (@errors) {
            $messages{$_}++;
            push @indices, $n if $messages{$_} > 1;
            $n++;
        }
        foreach ( sort { $b <=> $a } @indices ) {
            splice @errors, $_, 1;
        }

        return @errors;
    }

    # Internal options hash
    my %options;

    sub _getOption {

        # Purpose:  Gets the template associated with passed option
        # Returns:  Reference to template hash or undef should the
        #           requested option not be defined
        # Usage:    $tref = _getOption($option);

        my $option = shift;

        return exists $options{$option} ? $options{$option} : undef;
    }

    sub _setOption {

        # Purpose:  Associates the passed option to the passed template in
        #           %options
        # Returns:  True (1)
        # Usage:    _setOption($option, $tref);

        my $option = shift;
        my $tref   = shift;

        $options{$option} = $tref;

        return 1;
    }

    sub _optionsKeys {

        # Purpose:  Returns a list of keys from %options
        # Returns:  keys %options
        # Usage:    @keys = _optionsKeys();

        return keys %options;
    }

    sub _resetOptions {

        # Purpose:  Empties the %options
        # Returns:  True (1)
        # Usage:    _resetOptions();

        %options = ();

        return 1;
    }

    # Internal arguments list
    my @arguments;

    sub _getArgRef {

        # Purpose:  Gets a reference the argument array
        # Returns:  Array reference
        # Usage:    $argRef = _getArgRef();

        return \@arguments;
    }

    sub clearMemory {

        # Purpose:  Empties all internal data structures
        # Returns:  True (1)
        # Usage:    clearMemory();

        _NOOPTIONS = 0;
        _resetErrors();
        _resetOptions();
        @{ _getArgRef() } = ();

        return 1;
    }
}

sub _tLint {

    # Purpose:  Performs basic checks on a given option template for
    #           correctness
    # Returns:  True (1) if all checks pass, False (0) otherwise
    # Usage:    $rv = _tLint($templateRef);

    my $tref = shift;    # Reference to option template hash
    my $rv   = 1;
    my ( $oname, @at );

    subPreamble( PDLEVEL2, '$', $tref );

    # Get the option name for reporting purposes (should have been populated
    # within parseArgs below)
    $oname = $$tref{Name};

    # Make sure a short or long option is declared
    if ( !defined $oname ) {
        _pushErrors('No short or long option name declared');
        $rv = 0;
    }

    # Make sure the argument template is defined
    if ($rv) {
        unless ( defined $$tref{Template} ) {
            _pushErrors("$oname option declared without a template");
            $rv = 0;
        }
    }

    # Make sure the template contains only supported characters
    if ($rv) {
        unless ( defined $$tref{Template}
            && $$tref{Template} =~ /^[\$\@]*$/s ) {
            _pushErrors( "$oname option declared with an invalid template"
                    . "($$tref{Template})" );
            $rv = 0;
        }
    }

    # Make sure option names are sane
    if ($rv) {
        if ( defined $$tref{Short} ) {
            unless ( $$tref{Short} =~ /^[a-zA-Z0-9]$/s ) {
                _pushErrors(
                    "Invalid name for the short option ($$tref{Short})");
                $rv = 0;
            }
        }
        if ( defined $$tref{Long} ) {
            unless ( $$tref{Long} =~ /^[a-zA-Z0-9-]{2,}$/s ) {
                _pushErrors(
                    "Invalid name for the long option ($$tref{Long})");
                $rv = 0;
            }
        }
    }

    # Make sure '@' is only used once, if at all, and the option isn't
    # set to allow bundling
    if ($rv) {
        if ( $$tref{Template} =~ /\@/sm ) {
            @at = ( $$tref{Template} =~ m#(\@)#sg );
            if ( @at > 1 ) {
                _pushErrors( 'The \'@\' symbol can only be used once in the '
                        . "template for $oname: $_" );
                $rv = 0;
            }
            if ( $$tref{CanBundle} and defined $$tref{Short} ) {
                _pushErrors(
                    "Option $$tref{Short} must have CanBundle set to false "
                        . 'if the template contains \'@\'' );
                $rv = 0;
            }
        }
    }

    # Make sure all values in our lists are defined
    if ($rv) {
        unless ( ref( $$tref{ExclusiveOf} ) eq 'ARRAY' ) {
            _pushErrors( "Option ${oname}'s parameter ExclusiveOf must be an "
                    . 'array reference' );
            $rv = 0;
        }
        unless ( ref( $$tref{AccompaniedBy} ) eq 'ARRAY' ) {
            _pushErrors(
                      "Option ${oname}'s parameter AccompaniedBy must be an "
                    . 'array reference' );
            $rv = 0;
        }
        if ($rv) {
            if ( grep { !defined } @{ $$tref{ExclusiveOf} } ) {
                _pushErrors(
                    "Option $oname has undefined values in ExclusiveOf");
                $rv = 0;
            }
            if ( grep { !defined } @{ $$tref{AccompaniedBy} } ) {
                _pushErrors(
                    "Option $oname has undefined values in ExclusiveOf");
                $rv = 0;
            }
        }
    }

    # Make sure CountShort is enabled only for those with a template of ''
    # or '$'
    if ($rv) {

        if ( $$tref{CountShort} ) {
            unless ( $$tref{Template} =~ /^\$?$/sm ) {
                _pushErrors( "Option $oname has CountShort set but with an "
                        . 'incompatible template' );
                $rv = 0;
            }
        }
    }

    subPostamble( PDLEVEL2, '$', $rv );

    return $rv;
}

sub _getArgs ($$\@) {

    # Purpose:  Takes passed argument template and extracts the requisite
    #           arguments to satisfy it from the argument list.  The
    #           results are stored in the passed option list.
    # Results:  True (1) if successful, False (0) if not
    # Usage:    $rv = _getArgs($option, $argTemplate, @optionArgs);

    my $option      = shift;         # Option name
    my $argTemplate = shift;         # Option argument template
    my $lref        = shift;         # Array reference for retrieved arguments
    my $rv          = 1;
    my $argRef      = _getArgRef();
    my @tmp;

    subPreamble( PDLEVEL2, '$$$', $option, $argTemplate, $lref );

    # Empty the array
    @$lref = ();

    pdebug( 'contents of args: %s', PDLEVEL4, @$argRef );

    # Start checking the contents of $argTemplate
    if ( $argTemplate eq '' ) {

        # Template is '' (boolean option)
        @$lref = (1);

    } elsif ( $argTemplate =~ /\@/s ) {

        # Template has a '@' in it -- we'll need to
        # grab as many of the next arguments as possible.

        # Check the noOptions flags
        if (_NOOPTIONS) {

            # True: gobble up everything left
            push @$lref, @$argRef;
            @$argRef = ();

        } else {

            # False: gobble up to the next option-looking thing
            while ( @$argRef and $$argRef[0] !~ /^--?(?:\w+.*)?$/s ) {
                push @$lref, shift @$argRef;
            }

            # Now, we check to see if the first remaining argument is '--'.
            # If it is then we must set noOptions to true and gobble the
            # rest.
            if ( @$argRef and $$argRef[0] eq '--' ) {
                _NOOPTIONS = 1;
                shift @$argRef;
                push @$lref, @$argRef;
                @$argRef = ();
            }
        }

    } else {

       # The template is not empty and has no '@', so we'll just grab the next
       # n arguments, n being the length of the template

        # Check the noOptions flag
        if (_NOOPTIONS) {

            # True:  grab everything we need
            while ( @$argRef and @$lref < length $argTemplate ) {
                push @$lref, shift @$argRef;
            }

        } else {

            # False:  grab as many non-option-looking things as we can
            while ( @$argRef
                and $$argRef[0] !~ /^--?(?:\w+.*)$/s
                and @$lref < length $argTemplate ) {
                push @$lref, shift @$argRef;
            }

            # Now, we check to see if we still need more arguments and if
            # the first remaining argument is '--'.  If it is then we must
            # set noOptions to true and gobble what we need.
            if (    @$lref < length $argTemplate
                and @$argRef
                and $$argRef[0] eq '--' ) {
                _NOOPTIONS = 1;
                shift @$argRef;
                while ( @$argRef and @$lref < length $argTemplate ) {
                    push @$lref, shift @$argRef;
                }
            }
        }
    }

    # Final check:  did we get minimum requisite number of arguments?
    if ( @$lref < length $argTemplate ) {
        _pushErrors(
            pdebug(
                'Missing the minimum number of arguments for %s', PDLEVEL1,
                $option
                ) );
        $rv = 0;
    } else {
        pdebug( 'extracted the following arguments: %s', PDLEVEL3, @$lref );
    }

    # sublist '@' portions of multicharacter templates
    if ( $rv and $argTemplate =~ /\@/sm and length $argTemplate > 1 ) {
        @tmp = ( [], [], [] );

        # First, shift off all preceding '$'s
        if ( $argTemplate =~ /^(\$+)/s ) {
            @{ $tmp[0] } = splice @$lref, 0, length $1;
        }

        # Next, pop off all trailing '$'
        if ( $argTemplate =~ /(\$+)\$/s ) {
            @{ $tmp[2] } = splice @$lref, -1 * length $1;
        }

        # Everything left belongs to the '@'
        @{ $tmp[1] } = @$lref;

        # Let's put it all together...
        @$lref = ();
        push @$lref, @{ $tmp[0] } if @{ $tmp[0] };
        push @$lref, $tmp[1];
        push @$lref, @{ $tmp[2] } if @{ $tmp[2] };

        pdebug( 'sublisted arguments into: %s', PDLEVEL3, @$lref );
    }

    subPostamble( PDLEVEL2, '$', $rv );

    return $rv;
}

sub _storeArgs ($$\@) {

    # Purpose:  Stores the passed option arguments in the passed option
    #           template's Value, but in accordance with parameters in the
    #           template
    # Returns:  True (1)
    # Usage:    _storeArgs($optionTemplate, $argTemplate, @optionArgs);

    my $tref        = shift;
    my $argTemplate = shift;
    my $lref        = shift;

    subPreamble( PDLEVEL2, '$$$', $tref, $argTemplate, $lref );

    pdebug( 'adding values to %s', PDLEVEL3, $$tref{Name} );

    # Increment our usage counter
    $$tref{Count}++;

    # Store arguments according to the template
    if ( $argTemplate eq '' ) {

        # Template is ''
        $$tref{Value} = 0 unless defined $$tref{Value};
        $$tref{Value}++;
        pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} );

    } elsif ( $argTemplate eq '$' ) {

        # Template is '$'
        if ( not $$tref{Multiple} or $$tref{CountShort} ) {

            # Store the value directly since we
            # can only be used once
            $$tref{Value} = $$lref[0];
            pdebug( 'Value is now %s', PDLEVEL3, $$tref{Value} );

        } else {

            # Store the value as part of a list since
            # we can be used multiple times
            $$tref{Value} = []
                unless defined $$tref{Value}
                    and ref $$tref{Value} eq 'ARRAY';
            push @{ $$tref{Value} }, $$lref[0];
            pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } );
        }

    } else {

        # Template is anything else
        if ( not $$tref{Multiple} ) {

            # Store the values directly in a an array
            # since we can only be used once
            $$tref{Value} = [@$lref];
            pdebug( 'Value is now %s', PDLEVEL3, @{ $$tref{Value} } );

        } else {

            # Store the values as an element of an
            # array since we can be used multiple times
            $$tref{Value} = []
                unless defined $$tref{Value}
                    and ref $$tref{Value} eq 'ARRAY';
            push @{ $$tref{Value} }, [@$lref];
            pdebug( 'Value now has %d sets',
                PDLEVEL3, scalar @{ $$tref{Value} } );
        }
    }

    subPostamble( PDLEVEL1, '$', 1 );

    return 1;
}

sub parseArgs (\@\%;\@) {

    # Purpose:  Extracts and validates all command-line arguments and options,
    #           storing them in an organized hash for easy retrieval
    # Returns:  True (1) if successful, False (0) if not
    # Usage:    $rv = parseArgs(@templates, %options);
    # Usage:    $rv = parseArgs(@templates, %options, @args);

    my $tlref = shift;    # Templates list ref
    my $oref  = shift;    # Options hash ref
    my $paref = shift;    # Program argument list ref
    my $rv    = 1;
    my ( $tref, $oname, $argRef, $arg, $argTemplate );
    my ( @tmp, @oargs, $regex );

    subPreamble( PDLEVEL1, '$$$', $tlref, $oref, $paref );

    # Validate arguments
    $paref = \@ARGV unless defined $paref;

    # Clear all internal data structures and reset flag
    clearMemory();

    # Empty the passed options hash
    %$oref = ();

    # Make a copy of the argument list
    $argRef  = _getArgRef();
    @$argRef = (@$paref);

    # Assemble %options and lint-check the templates
    foreach (@$tlref) {

        # Make sure the element is a hash reference
        unless ( ref $_ eq 'HASH' ) {
            _pushErrors('Illegal non-hash reference in templates array');
            $rv = 0;
            next;
        }

        # Establish a base template and copy the contents of the passed hash
        $tref = {
            Short         => undef,
            Long          => undef,
            Template      => '',
            Multiple      => 0,
            ExclusiveOf   => [],
            AccompaniedBy => [],
            CanBundle     => 0,
            CountShort    => 0,
            Value         => undef,
            %$_,
            };

        # Set AllOptions for error message reporting
        $$tref{Name} =
               defined $$tref{Short}
            && defined $$tref{Long} ? "-$$tref{Short}/--$$tref{Long}"
            : defined $$tref{Short} ? "-$$tref{Short}"
            : defined $$tref{Long}  ? "--$$tref{Long}"
            :                         undef;

        # Initialize our usage counter
        $$tref{Count} = 0;

        # Anything that has CountShort enabled implies Multiple/CanBundle
        # and a template of '$'
        if ( $$tref{CountShort} ) {
            $$tref{CanBundle} = $$tref{Multiple} = 1;
            $$tref{Template} = '$' if defined $$tref{Long};
        }

        # Anything that has a Short option and a template of '$' or ''
        # implies CanBundle
        $$tref{CanBundle} = 1
            if defined $$tref{Short} and $$tref{Template} eq '';

        # We'll associate both the long and short options to the same hash
        # to make sure that we count/collect everything appropriately.
        #
        # Store the short option
        if ( defined $$tref{Short} and length $$tref{Short} ) {

            # See if a template is already defined
            if ( defined _getOption( $$tref{Short} ) ) {

                # It is -- report the error
                Paranoid::ERROR = _pushErrors(
                    pdebug(
                        'the %s option has more than one template',
                        PDLEVEL1, $$tref{Short} ) );
                $rv = 0;

            } else {

                # It's not -- go ahead and store it
                _setOption( $$tref{Short}, $tref );
            }
        }

        # Store the long option
        if ( defined $$tref{Long} and length $$tref{Long} ) {

            # See if a template is already defined
            if ( defined _getOption( $$tref{Long} ) ) {

                # It is -- report the error
                Paranoid::ERROR = _pushErrors(
                    pdebug(
                        'the %s option has more than one template',
                        PDLEVEL1, $$tref{Long} ) );
                $rv = 0;

            } else {

                # It's not -- go ahead and store it
                _setOption( $$tref{Long}, $tref );
            }
        }

        # Do a basic lint-check on the template
        $rv = 0 unless _tLint($tref);
    }

    if ($rv) {

        while (@$argRef) {
            $arg = shift @$argRef;
            next unless defined $arg;

            # Start testing $arg
            if ( $arg eq '--' and not _NOOPTIONS ) {

                # $arg is '--', so set the no options flag
                _NOOPTIONS = 1;

            } elsif ( not _NOOPTIONS and $arg =~ /^--?/s ) {

                # '--' hasn't been passed yet and this looks
                # like an option...

                # Test types of options
                if ( $arg =~ /^-(\w.*)$/s ) {

                    # With a single '-' it should be a short option.  However,
                    # we'll split the option portion, in case there's more
                    # than one character
                    @tmp = split //s, $1;

                    # If there's more than one character for the option name
                    # it must be either a bunch of bundled options or an
                    # option with a concatenated argument.  In case of the
                    # latter (assuming that CanBundle is set to false (a
                    # prerequisite of argument concatenation) and it has a
                    # template of '$' (another prerequisite)) we'll unshift
                    # the rest of the characters back onto the argument list.
                    #
                    # Oh, but first we'll need to get the applicable
                    # option template and then start testing...
                    $tref = _getOption( $tmp[0] );
                    if (    $#tmp
                        and defined $tref
                        and $$tref{Template} eq '$'
                        and not $$tref{CanBundle} ) {
                        unshift @$argRef, join '', @tmp[ 1 .. $#tmp ];
                        splice @tmp, 1;
                    }

                    # Start processing all remaining short options in @tmp
                    foreach (@tmp) {

                        # Get the template
                        $tref = _getOption($_);

                        # Make sure the option is supported
                        if ( defined $tref ) {

                            # Make sure option allows bundling if bundled
                            if ($#tmp) {
                                unless ( $$tref{CanBundle} ) {
                                    _pushErrors(
                                              "Option $_ used bundled with "
                                            . 'other options' );
                                    $rv = 0;
                                    next;
                                }
                            }

                            # Get the argument template
                            $argTemplate = $$tref{Template};

                            # Override the template if CountShort is true
                            $argTemplate = ''
                                if $argTemplate eq '$'
                                    and $$tref{CountShort};

                            # Get any accompanying arguments
                            unless ( _getArgs( "-$_", $argTemplate, @oargs ) )
                            {
                                $rv = 0;
                                next;
                            }

                            # Check if we've call this more than once
                            if ( not $$tref{Multiple}
                                and $$tref{Count} > 0 ) {
                                _pushErrors(
                                    "Option $$tref{Name} is only allowed "
                                        . 'to be used once' );
                                $rv = 0;
                                next;
                            }

                            # Store the values
                            _storeArgs( $tref, $argTemplate, @oargs );

                        } else {

                            # Warn that this is an unknown option
                            _pushErrors("Unknown short option used: $_");
                            $rv = 0;
                        }
                    }

                } elsif ( $arg =~ /^--([\w-]+)(?:=(.+))?$/sm ) {

                    # Starts with '--', so must be a long option

                    # Save the extracted option/argument portion
                    @tmp = ($1);
                    push @tmp, $2 if defined $2 and length $2;

                    # If this option had an argument portion we need to
                    # unshift it back onto the argument list *provided* it was
                    # a legal argument, i.e., this option had a template of
                    # '$'.
                    $tref = _getOption( $tmp[0] );
                    if ( $#tmp and defined $tref ) {

                        # Test for various templates
                        if ( $$tref{Template} eq '$' ) {

                            # Legal invocation  -- unshift away
                            unshift @$argRef, $tmp[1];

                        } elsif ( $$tref{Template} eq '' ) {

                            # Illegal, no arguments expected
                            _pushErrors( "--$tmp[0] does not require any "
                                    . 'arguments' );
                            $rv = 0;
                            next;

                        } else {

                            # Illegal, can't use concatenated arguments in
                            # more complex templates
                            _pushErrors( "--$tmp[0] cannot be called like "
                                    . 'this when multiple arguments are '
                                    . 'required.' );
                        }
                    }

                    # Handle known options
                    if ( defined $tref ) {

                        # Get the argument template
                        $argTemplate = $$tref{Template};

                        # Snarf extra arguments
                        unless (
                            _getArgs( "--$tmp[0]", $argTemplate, @oargs ) ) {
                            $rv = 0;
                            next;
                        }

                        # Check if we've call this more than once
                        if ( not $$tref{Multiple} and $$tref{Count} > 0 ) {
                            _pushErrors(
                                "Option $$tref{Name} is only allowed to be used once"
                                );
                            $rv = 0;
                            next;
                        }

                        # Store the values
                        _storeArgs( $tref, $argTemplate, @oargs );

                    } else {

                        # Unknown long option
                        _pushErrors("Unknown option: --$tmp[0]");
                        $rv = 0;
                    }

                } else {

                    # Unknown option-looking thingy
                    _pushErrors("Unknown option thingy: $arg");
                    $rv = 0;
                }

            } else {

                # Everything else is payload
                $$oref{PAYLOAD} = [] unless exists $$oref{PAYLOAD};
                push @{ $$oref{PAYLOAD} }, $arg;
            }
        }
    }

    # Make a list of all the arguments that was used
    @tmp = ();
    foreach ( _optionsKeys() ) {
        push @tmp, $_ if ${ _getOption($_) }{Count};
    }

    # Final sanity check
    foreach ( sort @tmp ) {
        $tref = _getOption($_);

        # Make sure nothing was called that is exclusive of
        # other called options
        if ( @{ $$tref{ExclusiveOf} } ) {
            $regex = '(?:' . join( '|', @{ $$tref{ExclusiveOf} } ) . ')';
            if ( grep /^$regex$/sm, @tmp ) {
                _pushErrors(
                    "$$tref{Name} cannot be called with the following options: "
                        . join ', ',
                    @{ $$tref{ExclusiveOf} } );
                $rv = 0;
            }
        }

        # Make sure the option was called in conjunction with others
        foreach $regex ( @{ $$tref{AccompaniedBy} } ) {
            unless ( grep /^\Q$regex\E$/sm, @tmp ) {
                _pushErrors(
                    "$$tref{Name} must be called with the following options: "
                        . join ', ',
                    @{ $$tref{AccompaniedBy} } );
                $rv = 0;
            }
        }

        # Copy the values into %$oref
        $$oref{$_} = $$tref{Value};
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

1;

__END__