File Coverage

blib/lib/CLI/Startup.pm

Criterion	Covered	Total	%
statement	457	472	96.8
branch	167	212	78.7
condition	51	69	73.9
subroutine	62	62	100.0
pod	20	20	100.0
total	757	835	90.6

package CLI::Startup;

use English qw( -no_match_vars );

use warnings;
use strict;

use Carp;
use Symbol;
use Pod::Text;
use Text::CSV;
use Class::Std;
use Config::Any;
use Data::Dumper;
use File::HomeDir;
use File::Basename;
use Clone qw{ clone };
use Hash::Merge qw{ merge };
use List::Util qw{ max reduce };
use Getopt::Long qw{
    GetOptionsFromArray :config posix_default bundling require_order no_ignore_case
};

use Exporter 'import';
our @EXPORT_OK = qw/startup/;

our $VERSION = '0.29';    # Don't forget to update the manpage version, too!

use Readonly;
Readonly my $V_FOR_VERBOSE => 'ALIAS OF VERBOSE';
Readonly my $V_OPTSPEC     => 'v+';

# Simple command-line processing with transparent
# support for config files.
sub startup
{
    my $optspec = shift;

    my $app = CLI::Startup->new($optspec);
    $app->init;

    return $app->get_options;
}

#<<< Leave this alone, perltidy
# Attributes of our inside-out objects.
my %config_of           : ATTR();
my %initialized_of      : ATTR( :get );
my %options_of          : ATTR();
my %optspec_of          : ATTR( :initarg );
my %raw_options_of      : ATTR();
my %rcfile_of           : ATTR( :get       :initarg );
my %usage_of            : ATTR( :get        :initarg );
my %write_rcfile_of     : ATTR( :get :initarg );
my %default_settings_of :
    ATTR( :get :initarg );
#>>>

# Returns a clone of the config object.
sub get_config
{
    my $self = shift;
    $self->die('get_config() called before init()')
        unless $self->get_initialized;
    return clone( $config_of{ ident $self} );
}

# Set defaults for the command-line options. Can be done as much as
# desired until the app is initialized.
sub set_default_settings
{
    my ( $self, $settings ) = @_;

    $self->die('set_default_settings() requires a hashref')
        unless defined $settings and ref $settings eq 'HASH';
    $self->die('set_default_settings() called after init()')
        if $self->get_initialized;

    $default_settings_of{ ident $self} = clone($settings);

    return;    # Needed so we don't leak a reference to the data!
}

# Get the options provided on the command line. This, unlike most of
# the others, can ONLY be called after the app is initialized.
sub get_options
{
    my $self = shift;
    $self->die('get_options() called before init()')
        unless $self->get_initialized;
    return clone( $options_of{ ident $self} );
}

# Returns the current specifications for the command-line options.
sub get_optspec
{
    my $self = shift;
    return clone( $optspec_of{ ident $self} );
}

# Set the specifications of the current command-line options.
sub set_optspec
{
    my $self = shift;
    my $spec = shift;

    $self->die('set_optspec() requires a hashref')
        unless ref $spec eq 'HASH';
    $self->die('set_optspec() called after init()')
        if $self->get_initialized;

    $optspec_of{ ident $self} = clone( $self->_validate_optspec($spec) );

    return;    # Needed so we don't leak a reference to the data!
}

# Returns a clone of the actual command-line options.
sub get_raw_options
{
    my $self = shift;
    $self->die('get_raw_options() called before init()')
        unless $self->get_initialized;
    return clone( $raw_options_of{ ident $self} );
}

# Set the filename of the rcfile for the app.
sub set_rcfile
{
    my ( $self, $rcfile ) = @_;

    $self->die('set_rcfile() called after init()')
        if $self->get_initialized;
    $rcfile_of{ ident $self} = "$rcfile";

    return;
}

# Set the usage string for the app. Only needed if there are
# arguments other than command-line options.
sub set_usage
{
    my ( $self, $usage ) = @_;

    $self->die('set_usage() called after init()')
        if $self->get_initialized;
    $usage_of{ ident $self} = "$usage";

    return;
}

# Set a file writer for the rc file.
sub set_write_rcfile
{
    my $self   = shift;
    my $writer = shift || 0;

    $self->die('set_write_rcfile() called after init()')
        if $self->get_initialized;
    $self->die('set_write_rcfile() requires a coderef or false')
        if $writer && ref($writer) ne 'CODE';

    my $optspec = $optspec_of{ ident $self};    # Need a reference, not a copy

    # Toggle the various rcfile options if writing is turned on or off
    if ($writer)
    {
        my $options = $self->_get_default_optspec;
        my $aliases = $self->_option_aliases($options);

        for my $alias (qw{ rcfile write-rcfile rcfile-format })
        {
            $optspec->{$alias} ||= $options->{ $aliases->{$alias} };
        }
    }
    else
    {
        for my $alias (qw{ rcfile write-rcfile rcfile-format })
        {
            delete $optspec->{$alias};
        }
    }

    # Save the writer
    $write_rcfile_of{ ident $self} = $writer;

    return;    # Needed so we don't leak a reference to the data!
}

# Die with a standardized message format.
sub die        ## no critic ( Subroutines::RequireFinalReturn )
{
    my ( undef, $msg ) = @_;

    my $name = basename($PROGRAM_NAME);
    CORE::die "$name: FATAL: $msg\n";
}

# Die with a usage summary.
sub die_usage
{
    my $self = shift;
    my $msg  = shift;

    print { \*STDERR } $self->_usage_message($msg);
    exit 1;
}

# Return a usage message
sub _usage_message
{
    my $self    = shift;
    my $msg     = shift;
    my $optspec = $self->get_optspec;
    my $name    = basename($PROGRAM_NAME);

    # The message to be returned
    my $message = '';

    # This happens if options aren't defined in the constructor
    # and then die_usage() is called directly or indirectly.
    $self->die('_usage_message() called without defining any options')
        unless keys %{$optspec};

    #<<< Leave this alone, perltidy

    # In the usage text, show the option names, not the aliases.
    my %options =
        map { ( $_->{names}[0], $_ ) }
        map { $self->_parse_spec( $_, $optspec->{$_} ) }
        keys %{$optspec};

    #>>> End perltidy-free zone

    # Automatically suppress 'v' if it's an alias of 'verbose'
    delete $options{v} if $optspec->{$V_OPTSPEC} // '' eq $V_FOR_VERBOSE;

    # Note the length of the longest option
    my $length = max map { length() } keys %options;

    # Print the requested message, if any
    if ( defined $msg )
    {
        $message .= sprintf "\%s: FATAL: \%s\n", $name, $msg;
    }

    # Now print the help message.
    $message
        .= 'usage: '
        . basename($PROGRAM_NAME) . ' '
        . $self->get_usage . "\n"
        . "Options:\n";

    # Print the options, sorted in dictionary order.
    for my $option ( sort keys %options )
    {
        ## no critic (ValuesAndExpressions::ProhibitMagicNumbers)
        my $indent = $length + 8;
        my $spec   = $options{$option};

        # Print the basic help option
        if ( length($option) == 1 )
        {
            $message .= sprintf "    -%-${length}s  - %s\n", $option,
                $spec->{desc};
        }
        else
        {
            $message .= sprintf "    --%-${length}s - %s\n", $option,
                $spec->{desc};
        }

        my @aliases = @{ $spec->{names} };
        shift @aliases;

        # Insert 'v' as an alias of 'verbose' if it is
        push @aliases, 'v'
            if $option eq 'verbose'
            && $optspec->{$V_OPTSPEC} // '' eq $V_FOR_VERBOSE;

        # Print aliases, if any
        if ( @aliases > 0 )
        {

            # Add in the dashes
            @aliases = map { length() == 1 ? "-$_" : "--$_" } @aliases;
            $message .= sprintf "%${indent}s Aliases: %s\n", '',
                join( ', ', @aliases );
        }

        # Print negation, if any
        if ( $spec->{boolean} )
        {
            $message .= sprintf "%${indent}s Negate this with --no-%s\n", '',
                $option;
        }
    }

    return $message;
}

# Returns the "default" optspec, consisting of options
# that CLI::Startup normally creates automatically.
sub _get_default_optspec
{
    return {
        'help|h'          => 'Print this help message',
        'rcfile:s'        => 'Config file to load',
        'write-rcfile'    => 'Write the current options to config file',
        'rcfile-format=s' => 'Format to write the config file',
        'version|V'       => 'Print version information and exit',
        'verbose:1' =>
            'Print verbose messages',    # Supports --verbose or --verbose=9
        $V_OPTSPEC => $V_FOR_VERBOSE,    # 'v+' Supports -vvv
        'manpage|H' => 'Print the manpage for this script',
    };
}

# Parse the optspecs, returning a complete description of each.
sub _parse_optspecs
{
    my ( $self, $optspecs ) = @_;
    my $parsed = { options => {}, aliases => {} };

    # Step through each option
    for my $optspec ( keys %{$optspecs} )
    {

        # Parse the spec completely
        $parsed->{options}{$optspec}
            = $self->_parse_spec( $optspec, $optspecs->{$optspec} );

        # Make a reverse-lookup by option name/alias
        for my $alias ( @{ $parsed->{options}{$optspec}{names} } )
        {

            # It's a fatal error to use the same alias twice
            $self->die("--$alias option defined twice")
                if defined $parsed->{aliases}{$alias};

            $parsed->{aliases}{$alias} = $optspec;
        }
    }

    return $parsed;
}

# Parses the option specs, identifying array and hash data types
sub _option_data_types
{
    my $self     = shift;
    my $optspecs = $self->get_optspec;
    my %types;

    # Build a list of the array and hash configs, so we can
    # unflatten them from the config file if necessary.
    for my $option ( keys %{$optspecs} )
    {
        my $spec = $self->_parse_spec( $option, $optspecs->{$option} );

        for my $type (qw{ array hash boolean count flag })
        {
            next unless $spec->{$type};
            $types{$_} = uc($type) for @{ $spec->{names} };
        }
    }

    return \%types;
}

# Breaks an option spec down into its components.
sub _parse_spec
{
    my ( $self, $spec, $help_text ) = @_;

    ## no critic ( Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes )
    ## no critic ( Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture )

    # We really want the "name(s)" portion
    $spec =~ m{
        (?:
            (?&start)
            (?            (?&word_list)      )
            (?:
                  (?: # Boolean
                      (?     (?&bang) (?&end) ) )
                | (?: # Counter
                      (? (?&optional)?    )
                      (?     (?&plus) (?&end) ) )
                | (?: # Scalar types - number, integer, string
                      (? (?&arg)          )
                      (?  (?&scalar_type)  )
                      (?     (?&non_scalar)?  ) )
                | (?: # Int with default argument
                      (? (?&optional)     )
                      (?  (?&integer)      ) )
                | (?: # Flag
                      (?&end)                       ) # Nothing to capture
            )?
            (? (?&unmatched)? )

            # This ensures that every token is defined, even if only
            # to the empty string.
            (?  (?())  )
            (?     (?())     )
            (?  (?())  )
            (? (?()) )
        )
        (?(DEFINE)
            (?       ^        )
            (?   (?: (?&word) (?: (?&separator) (?&alias) )* ) )
            (?        \w[-\w]* )
            (?       (?: [?] | (?&word) ) )
            (?   [|]      )
            (? (?: [fions] ) )
            (?     (?: -? \d+ ) )
            (?         [:=]     )
            (?    [:]      )
            (?   [=]      )
            (?  [@%]     )
            (?        [%]      )
            (?       [@]      )
            (?        [!]      )
            (?        [+]      )
            (?         (?! . )  )
            (?   (?: .* $ ) )    # This will be the last thing in an invalid spec
        )
    }xms;

    # Capture the pieces of the optspec that we found
    my %attrs = %LAST_PAREN_MATCH;

    # If there's anything left that we failed to match, it's a fatal error
    $self->die("Invalid optspec: $spec") if $attrs{garbage};

    ## no critic ( ValuesAndExpressions::ProhibitNoisyQuotes Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers)
    #<< Leave this alone, perltidy

    # Note: doesn't identify string, int, float options
    return {
        spec     => $spec,
        names    => [ split /[|]/xms, $attrs{names} ],
        desc     => $help_text,
        default  => $attrs{default},
        required => ( $attrs{argument} eq '=' ? 1 : 0 ),
        type     => (
              $attrs{subtype} eq ''  ? 'i'
            : $attrs{subtype} eq 'n' ? 'i'
            :                          $attrs{subtype}
        ),
        array   => ( $attrs{type} eq '@'                          ? 1 : 0 ),
        hash    => ( $attrs{type} eq '%'                          ? 1 : 0 ),
        scalar  => ( $attrs{type} !~ m{[@%]}xms                   ? 1 : 0 ),
        boolean => ( $attrs{type} eq '!'                          ? 1 : 0 ),
        count   => ( $attrs{type} eq '+'                          ? 1 : 0 ),
        flag    => ( $attrs{type} eq '' && $attrs{argument} eq '' ? 1 : 0 ),
    };

    #>> End perltidy free zone
}

# Returns a hash of option aliases and specifications from the
# supplied hash. Also converts undef to 0 in $optspec.
sub _option_aliases
{
    my ( $self, $optspec ) = @_;
    my %option_aliases;

    # Make sure that there are no duplicated option names,
    # and that options with undefined help text are defined
    # to false.
    for my $option ( keys %{$optspec} )
    {
        $optspec->{$option} ||= 0;
        $option = $self->_parse_spec( $option, $optspec->{$option} );

        # The spec can define aliases
        for my $name ( @{ $option->{names} } )
        {
            $self->die("--$name option defined twice")
                if exists $option_aliases{$name};
            $option_aliases{$name} = $option->{spec};
        }
    }

    return \%option_aliases;
}

# Returns an options spec hashref, with automatic options
# added in.
sub _validate_optspec
{

   # no critic ( Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity )
    my ( $self, $user_optspecs ) = @_;
    my $default_optspecs = $self->_get_default_optspec;

    my $parsed;

    # Parse the user optspecs
    $parsed = $self->_parse_optspecs($user_optspecs);
    my $user_options = $parsed->{options};
    my $user_aliases = $parsed->{aliases};

    # Parse the default optspecs
    $parsed = $self->_parse_optspecs($default_optspecs);
    my $default_options = $parsed->{options};
    my $default_aliases = $parsed->{aliases};

    # While we're here, remember the "help" option settings for later.
    # If a tricksy user deletes it, we'll put it back.
    my $default_help_optspec = $default_aliases->{'help'};
    my $default_help_parsed  = $default_options->{$default_help_optspec};

    # At this point we also know that there are no conflicting aliases
    # in either the user or default optspecs. So the only thing to check
    # is whether the user invokes any of the default optspecs.

    # Step through each user alias. Check for collisions, and also delete
    # any default options for which this was requested.
    for my $alias ( keys %{$user_aliases} )
    {

        # Only look at options that collide with default options.
        next unless defined $default_aliases->{$alias};

        # If the option specifications are identical, then we can
        # skip this option.
        my $user_optspec    = $user_aliases->{$alias};
        my $default_optspec = $default_aliases->{$alias};

        # If the option evaluates to true, it MAY be changing something,
        # which is an error.
        if ( $user_optspecs->{$user_optspec} || 0 )
        {
            if ( $user_optspec ne $default_optspec )
            {
                $self->die("Multiple definitions for --$alias option");
            }
        }

        # OK, this option is being deleted.

        # If the alias was not the primary name of the default option,
        # then we delete only the specific alias requested.
        my $default_name = $default_options->{$default_optspec}{names}[0];
        if ( $alias ne $default_name )
        {
            delete $default_aliases->{$alias};
            next;
        }

        # Completely delete the default options corresponding to this alias.
        for my $name ( @{ $default_options->{$default_optspec}{names} } )
        {
            delete $default_aliases->{$name};
        }
        delete $default_options->{$default_optspec};

        # Special case: we use two options to cover 'verbose'
        if (    $alias eq 'verbose'
            and $default_optspecs->{$V_OPTSPEC} eq $V_FOR_VERBOSE )
        {
            delete $default_options->{ $default_aliases->{v} };
            delete $default_aliases->{v};
        }
    }

    # Remove any disabled user options. Options are disabled by
    # setting them to anything that evaluates to false.
    for my $optspec ( keys %{$user_options} )
    {
        next if $user_options->{$optspec}{desc} || 0;

        for my $alias ( @{ $user_options->{$optspec}{names} } )
        {
            delete $user_aliases->{$alias};
        }
        delete $user_options->{$optspec};
    }

    # Now we just check for ordinary collisions. Since we've performed any
    # requested deletions, any collisions between user and default aliases
    # means that an alias is defined twice.
    for my $name ( keys %{$user_aliases} )
    {
        next unless defined $default_aliases->{$name};

        $self->die("Multiple definitions for --$name option");
    }

    # The --help option is NOT optional, so we override it if it evaluates
    # to false. It must be present, because if we didn't find it above we
    # would have inserted it.
    if ( not defined $user_aliases->{'help'} )
    {
        $user_options->{$default_help_optspec} = $default_help_parsed;
    }

    # If the --rcfile option is disabled, then we must also delete the
    # --rcfile-format and --write-rcfile options, since they make no
    # sense in scripts that don't support config files.
    if ( not defined $user_aliases->{rcfile} )
    {
        for my $option (qw{ rcfile rcfile-format write-rcfile })
        {
            if ( defined $user_aliases->{$option} )
            {
                delete $user_options->{ $user_aliases->{$option} };
                delete $user_aliases->{$option};
            }
        }
    }

    # If rcfile writing is disabled, then we must delete the --rcfile-format
    # option, which is meaningless when we don't write config files.
    if ( not defined $user_aliases->{'write-rcfile'} )
    {
        if ( defined $user_aliases->{'rcfile-format'} )
        {
            delete $user_options->{ $user_aliases->{'rcfile-format'} };
            delete $user_aliases->{'rcfile-format'};
        }
    }

    # Create a new optspec which includes both the user and default options.
    my $optspecs = {};

    for my $optspec ( keys %{$default_options} )
    {
        $optspecs->{$optspec} = $default_options->{$optspec}{desc};
    }

    for my $optspec ( keys %{$user_options} )
    {
        $optspecs->{$optspec} = $user_options->{$optspec}{desc};
    }

    return $optspecs;
}

# This is the core method of the whole module: it actually does the
# command-line processing, config-file reading, etc.. Once it
# completes, most of the write accesors are disabled, and this
# object becomes a reference for looking up configuration info.
sub init
{
    my $self = shift;

    $self->die('init() method takes no arguments') if @_;
    $self->die('init() called a second time')
        if $self->get_initialized;

    # It's a fatal error to call init() without defining any
    # command-line options
    $self->die('init() called without defining any command-line options')
        unless $self->get_optspec || 0;

    # Parse command-line options, then read the config file if any.
    my $options = $self->_process_command_line;
    my $config  = $self->_read_config_file;
    my $default = $self->get_default_settings;

    # Save the unprocessed command-line options
    $raw_options_of{ ident $self} = clone($options);

    # Now, combine the command options, the config-file defaults,
    # and the wired-in app defaults, in that order of precedence.
    $options = reduce { merge( $a, $b ) }
    ( $options, $config->{default}, $default );

    # Add a 'verbose' option that evaluates to false if there isn't
    # already one in $options.
    $options->{verbose} //= 0;

    # Consolidate the 'v' and 'verbose' options if the default
    # options are in play here.
    if ( $self->_get_default_optspec->{$V_OPTSPEC} eq $V_FOR_VERBOSE )
    {
        if ( defined $options->{v} )
        {
            $options->{verbose} += delete $options->{v};
        }
    }

    # Save the fully-processed options
    $options_of{ ident $self} = clone($options);

    # Mark the object as initialized
    $initialized_of{ ident $self} = 1;

    #
    # Automatically processed options:
    #

    # Print the version information, if requested
    $self->print_version if $options->{version};

    # Print the POD manpage from the script, if requested
    $self->print_manpage if $options->{manpage};

    # Write back the config if requested
    $self->write_rcfile() if $options->{'write-rcfile'};

    return;
}

sub _process_command_line
{
    my $self    = shift;
    my $optspec = $self->get_optspec;
    my %options;

    # Parse the command line and die if anything is wrong.
    my $opts_ok = GetOptionsFromArray( \@ARGV, \%options, keys %{$optspec} );

    if ( $options{help} )
    {
        print $self->_usage_message();
        exit 0;
    }
    elsif ( !$opts_ok )
    {
        $self->die_usage();
    }

    # Treat array and hash options as CSV records, so we can
    # cope with quoting and values containing commas.
    my $csv = Text::CSV->new( { allow_loose_quotes => 1 } );

    # Further process the array and hash options
    for my $option ( keys %options )
    {
        if ( ref $options{$option} eq 'ARRAY' )
        {
            my @values;
            for my $value ( @{ $options{$option} } )
            {
                $csv->parse($value)
                    or $self->die_usage(
                    "Can't parse --$option option \"$value\": "
                        . $csv->error_diag );
                push @values, $csv->fields;
            }

            $options{$option} = \@values;
        }
        elsif ( ref $options{$option} eq 'HASH' )
        {
            my $hash = $options{$option};
            for my $key ( keys %{$hash} )
            {
                # Extract each value and tech for embedded name/value
                # pairs. We only go one level deep.
                my $value = $hash->{$key};
                $csv->parse($value)
                    or $self->die_usage(
                    "Can't parse --$option option \"$value\": "
                        . $csv->error_diag );

                # If there's only one field, nothing to do
                next if ( $csv->fields == 1 );

                # Pick off the first value
                my @values = $csv->fields;
                $hash->{$key} = shift @values;

                # Now parse the rest
                for my $value (@values)
                {
                    my ( $k, $v ) = $value =~ m/^ ([^=]+) = (.*) $/xmsg;

                    # Check for collision
                    carp "Redefined option value: $k"
                        if defined $hash->{$k};

                    # Set the value
                    $hash->{$k} = $v;
                }
            }
        }
    }

    # Process the rcfile option immediately, to override any settings
    # hard-wired in the app, as well as this module's defaults. If the
    # rcfile has already been set to a false value, however, then this
    # option is disallowed.
    $self->set_rcfile( $options{rcfile} ) if defined $options{rcfile};

    # That's it!
    return \%options;
}

sub _read_config_file
{
    my $self    = shift;
    my $types   = $self->_option_data_types;
    my $rcfile  = $self->get_rcfile || '';
    my $options = {
        files         => [$rcfile],
        use_ext       => 0,
        force_plugins => [ qw{
                Config::Any::INI Config::Any::XML Config::Any::YAML
                Config::Any::JSON Config::Any::Perl
                }
        ],
    };

    my $raw_config;

    # Attempt to parse the file, if any
    if ( $rcfile && -r $rcfile )
    {

        # Defend against badly configured parsers. I'm looking
        # at YOU, XML::SAX!
        local $SIG{__WARN__} = sub {
            my @args = @_;

            for my $arg (@args)
            {
                next if ref $arg;
                return if $arg =~ /Unable to recognise encoding/ms;
                return if $arg =~ /ParserDetails[.]ini/xms;
            }

            CORE::warn(@args);
        };

        # OK, NOW load the files.
        my $files = Config::Any->load_files($options);
        $files      = shift @{$files}   || {};
        $raw_config = $files->{$rcfile} || {};
    }
    else
    {
        $raw_config = {};
    }

    # Initialize an empty config
    my $config = { default => {} };

    # Copy in the default section, if there is one.
    if ( defined $raw_config->{default} )
    {
        if ( ref $raw_config->{default} ne 'HASH' )
        {
            $self->die('Config file\'s "default" setting isn\'t a hash!');
        }
        else
        {
            $config->{default} = delete $raw_config->{default};
        }
    }

    # Now parse strings if they're supposed to be hashes or arrays.
    # This is basically a fix for file formats like INI, that can't
    # encode data structures.

    # Step through the config, moving any scalars we see into the
    # default section.
    for my $key ( keys %{$raw_config} )
    {

        # We expect a hash, with a "default" section, but if there
        # isn't one, or there are naked options, then we treat them
        # as defaults.
        if ( not ref $raw_config->{$key} )
        {
            $config->{default}{$key} = delete $raw_config->{$key};
            next;
        }
        else
        {
            $config->{$key} = delete $raw_config->{$key};
        }
    }

    # Now step through the default section, turning scalars into
    # arrays and hashes as necessary.
    for my $option ( keys %{ $config->{default} } )
    {
        my $value = $config->{default}{$option};
        $value = $self->_parse_setting( $value, $option, $types );

        $config->{default}{$option} = $value;
    }

    # Save the cleaned-up config for reference
    $config_of{ ident $self} = $config;

    return $config;
}

# Convert string values into an arrayref or hashref as needed
sub _parse_setting
{
    my ( $self, $value, $option, $types ) = @_;

    # If the data is the right type, or we have no spec, nothing to do.
    my $type = $types->{$option} || 'NONE';
    return $value if ref $value eq $type or $type eq 'NONE';

    # All other data types we support are scalars.
    $self->die("Bad data type for \"$option\" option in config file.")
        if ref $value;

    # Boolean or flags are converted to boolean. Booleans are just
    # negatable flags.
    if ( $type eq 'BOOLEAN' or $type eq 'FLAG' )
    {
        return $value // 0 ? 1 : 0;
    }

    # Counters are integer-valued
    if ( $type eq 'COUNT' )
    {

        # All other data types we support are scalars.
        $self->die(
            "Invalid value \"$value\" for option \"$option\" in config file.")
            if $value !~ /^ \d+ $/xms;

        return $value;
    }

    # The only fix we implement is to parse CSV and primitive name/value
    # pairs.
    my $csv = Text::CSV->new( {
        allow_loose_quotes => 1,
        allow_whitespace   => 1,
    } );

    # Start by turning the string to an array
    $csv->parse($value);
    $value = [ $csv->fields ];
    return $value if $type eq 'ARRAY';

    my %hash;

    # Now it has to be a hash, so we need to split the values
    # on equal signs or colons.

    for ( @{$value} )
    {
        my ( $key, $val ) = m/^([^=:]+)(?:\s*[:=]\s*)?(.*)$/xms;
        $hash{$key} = $val;
    }

    return \%hash;
}

# Constructor for this object.
sub BUILD
{
    my ( $self, undef, $argref ) = @_;

    # Shorthand: { options => \%options } can be
    # abbreviated \%options.
    if ( not exists $argref->{options} )
    {
        $argref = { options => $argref };
    }
    $self->set_optspec( $argref->{options} || {} );

    # Caller can specify default settings for all options.
    $self->set_default_settings( $argref->{default_settings} )
        if exists $argref->{default_settings};

    ## no critic ( ValuesAndExpressions::ProhibitNoisyQuotes )

    # Setting rcfile to undef in the constructor disables rcfile reading
    # for the script.
    $self->set_rcfile(
        exists $argref->{rcfile}
        ? $argref->{rcfile}
        : File::HomeDir->my_home . '/.' . basename($PROGRAM_NAME) . 'rc'
    );

    # Caller can forbid writing of rcfiles by setting
    # the write_rcfile option to undef, or can supply
    # a coderef to do the writing.
    if ( exists $argref->{write_rcfile} )
    {
        $self->set_write_rcfile( $argref->{write_rcfile} );
    }

    # Set an optional usage message for the script.
    $self->set_usage(
        exists $argref->{usage}
        ? $argref->{usage}
        : '[options]'
    );

    return;
}

# Destructor. Nothing much to do, but without it we get
# a warning about CLI::Startup::DEMOLISH only being used
# once by Class::Std.
sub DEMOLISH
{
}

# Prints out the POD contained in the script file, if any.
sub print_manpage
{
    my $self   = shift;
    my $parser = Pod::Text->new;

    # Print SOMETHING...
    $parser->output_fh(*STDOUT);
    $parser->parse_file($PROGRAM_NAME);
    print $self->_usage_message() unless $parser->content_seen;

    exit 0;
}

# Prints the version of the script.
sub print_version
{
    my $version = $::VERSION || 'UNKNOWN';
    my $name    = basename($PROGRAM_NAME);

    print { \*STDERR } <<"EOF";
This is $name, version $version
    path: $PROGRAM_NAME
    perl: $PERL_VERSION
EOF
    exit 0;
}

# Print a nicely-formatted warning message.
sub warn    ## no critic ( Subroutines::RequireFinalReturn )
{
    my ( undef, $msg ) = @_;

    my $name = basename($PROGRAM_NAME);
    CORE::warn "$name: WARNING: $msg\n";
}

# Writes the config file in the specified format.
sub write_rcfile
{
    my $self = shift;
    my $file = shift || $self->get_rcfile;

    # It's a fatal error to call write_rcfile() before init()
    $self->die('write_rcfile() called before init()')
        unless $self->get_initialized;

    # If there's no file to write, abort.
    $self->die('can\'t write rcfile: no file specified') unless $file;

    # Check whether a writer has been set
    my $writer = $self->_choose_rcfile_writer;

    # If there's a writer, call it.
    if ( ref $writer eq 'CODE' )
    {
        $writer->( $self, $file );
    }
    else
    {
        $self->die('write_rcfile() disabled, but called anyway');
    }

    exit 0;
}

# Returns a hashref that looks like a config file's contents, with
# the defaults overwritten by the options used for the current
# invocation of the script.
sub get_options_as_defaults
{
    my $self = shift;

    # Collate the settings for writing
    my $settings = $self->get_config;
    my $options  = $self->get_raw_options;
    my $default  = $self->get_default_settings;
    my $default_aliases
        = $self->_option_aliases( $self->_get_default_optspec );

    # Copy the current options back into the "default" group
    $settings->{default} = reduce { merge( $a, $b ) }
    ( $options, $settings->{default}, $default );

    # Delete settings for the automatically-generated options; none of them
    # belong in the rcfile.
    for my $option ( keys %{$default_aliases} )
    {
        delete $settings->{default}{$option};
    }

    return $settings;
}

# Choose the correct built-in config writer based on the current
# value of --rcfile-format.
sub _choose_rcfile_writer
{
    my $self = shift;

    # If a writer was specified by the user, we don't have to think.
    # If it evaluates to false, or isn't a coderef, write_rcfile()
    # will abort with an error.
    if ( exists $write_rcfile_of{ ident $self} )
    {
        return $write_rcfile_of{ ident $self};
    }

    my $writer = {
        INI  => \&_write_rcfile_ini,
        XML  => \&_write_rcfile_xml,
        JSON => \&_write_rcfile_json,
        YAML => \&_write_rcfile_yaml,
        PERL => \&_write_rcfile_perl,
    };

    # Decide what the default should be: INI falling back on Perl
    eval 'use Config::INI::Writer';
    my $default = $EVAL_ERROR ? 'PERL' : 'INI';

    # Check whether a file format was specified; if not, use the default.
    my $options = $self->get_options;
    my $format  = uc( $options->{'rcfile-format'} || $default );

    $self->die("Unknown --rcfile-format option specified: \"$format\"")
        unless defined $writer->{$format};

    return $writer->{$format};
}

# Write the current settings to an INI file. Serialize hash and array
# values for known command-line options. Leave everything else alone.
sub _write_rcfile_ini
{
    my ( $self, $file ) = @_;

    # Installing the INI module is optional
    eval 'use Config::INI::Writer';
    $self->die('Can\'t write rcfile: Config::INI::Writer is not installed.')
        if $EVAL_ERROR;

    # Get out current settings, and then fix the formats of array and
    # hash values.
    my $settings = $self->get_options_as_defaults;
    my $types    = $self->_option_data_types;

    for my $setting ( keys %{ $settings->{default} } )
    {
        my $value = $settings->{default}{$setting};

        # String data doesn't need anything done to it.
        next unless ref $value;

        # We produce compliant CSV; no options needed.
        my $csv = Text::CSV->new( {} );

        # Serialize the two structures we know about.
        if ( ref $value eq 'ARRAY' )
        {

            # Just stringify. Deep structure will be silently lost.
            $csv->combine( map {"$_"} @{$value} );
            $value = $csv->string;

            # Warn if the type is wrong, but proceed anyway.
            $self->warn("Option \"$setting\" is unexpectedly an array")
                if ( $types->{$setting} || '' ) ne 'ARRAY';
        }
        elsif ( ref $value eq 'HASH' )
        {

            # Just stringify. Deep structure will be silently lost.
            $csv->combine( map {"$_=$value->{$_}"} keys %{$value} );
            $value = $csv->string;

            # Warn if the type is wrong, but proceed anyway.
            $self->warn("Option \"$setting\" is unexpectedly a hash")
                if ( $types->{$setting} || '' ) ne 'HASH';
        }
        else
        {
            # Just stringify. We know this is wrong, but the user
            # shouldn't be using an INI file for structured data.
            $value = "$value";

            # Don't know what to do; can't do anything about it.
            $self->warn("Option \"$setting\" will be corrupt in config file");
        }

        $settings->{default}{$setting} = $value;
    }

    # Write settings to the file.
    Config::INI::Writer->write_file( $settings, $file );

    return 1;
}

# Write the current settings to an XML file.
sub _write_rcfile_xml
{
    my ( $self, $file ) = @_;

    # Installing a XML module is optional.
    eval 'use XML::Simple';
    $self->die('Can\'t write rcfile: XML::Simple is not installed.')
        if $EVAL_ERROR;

    open my $RCFILE, '>', $file
        or $self->die("Couldn't open file \"$file\": $OS_ERROR");
    print {$RCFILE} XMLout( $self->get_options_as_defaults )
        or $self->die("Couldn't write to file \"$file\": $OS_ERROR");
    close $RCFILE
        or $self->die("Couldn't close file \"$file\": $OS_ERROR");

    return 1;
}

# Write the current settings to a JSON file.
sub _write_rcfile_json
{
    my ( $self, $file ) = @_;

    # Installing a JSON module is optional.
    eval 'use JSON::MaybeXS';
    $self->die('Can\'t write rcfile: JSON::MaybeXS is not installed.')
        if $EVAL_ERROR;

    my $json = JSON::MaybeXS->new();

    open my $RCFILE, '>', $file
        or $self->die("Couldn't open file \"$file\": $OS_ERROR");
    print {$RCFILE} $json->encode( $self->get_options_as_defaults )
        or $self->die("Couldn't write to file \"$file\": $OS_ERROR");
    close $RCFILE
        or $self->die("Couldn't close file \"$file\": $OS_ERROR");

    return 1;
}

# Write the current settings to a YAML file.
sub _write_rcfile_yaml
{
    my ( $self, $file ) = @_;

    # Installing a YAML module is optional.
    eval 'use YAML::Any qw{DumpFile}';
    $self->die('Can\'t write rcfile: YAML::Any is not installed.')
        if $EVAL_ERROR;

    DumpFile( $file, $self->get_options_as_defaults );

    return 1;
}

# Write the current settings to a Perl file.
sub _write_rcfile_perl
{
    my ( $self, $file ) = @_;

    local $Data::Dumper::Terse = 1;

    open my $RCFILE, '>', $file
        or $self->die("Couldn't open file \"$file\": $OS_ERROR");
    print {$RCFILE} Dumper( $self->get_options_as_defaults )
        or $self->die("Couldn't write to file \"$file\": $OS_ERROR");
    close $RCFILE
        or $self->die("Couldn't close file \"$file\": $OS_ERROR");

    return 1;
}

1;    # End of CLI::Startup

__END__