File Coverage

blib/lib/App/Sqitch/Command/config.pm

Criterion	Covered	Total	%
statement	150	150	100.0
branch	58	62	93.5
condition	35	39	89.7
subroutine	46	46	100.0
pod	15	15	100.0
total	304	312	97.4

package App::Sqitch::Command::config;

use 5.010;
use strict;
use warnings;
use utf8;
use Path::Class ();
use Try::Tiny;
use Locale::TextDomain qw(App-Sqitch);
use App::Sqitch::X qw(hurl);
use List::Util qw(first);
use Moo;
use App::Sqitch::Types qw(Str Dir Maybe);
use Type::Utils qw(enum);
use namespace::autoclean;
extends 'App::Sqitch::Command';

our $VERSION = 'v1.4.0'; # VERSION

has file => (
    is      => 'ro',
    lazy    => 1,
    default => sub {
        my $self = shift;
        my $meth = ( $self->context || 'local' ) . '_file';
        return $self->sqitch->config->$meth;
    }
);

has action => (
    is  => 'ro',
    isa => enum([qw(
        get
        get_all
        get_regex
        set
        unset
        list
        edit
        add
        replace_all
        unset_all
        rename_section
        remove_section
    )]),
);

has context => (
    is  => 'ro',
    isa => Maybe[enum([qw(
        local
        user
        system
    )])],
);

has type => ( is => 'ro', isa => enum( [qw(int num bool bool-or-int)] ) );

sub options {
    return qw(
        file|config-file|f=s
        local
        user|global
        system

        int
        bool
        bool-or-int
        num

        get
        get-all
        get-regex|get-regexp
        add
        replace-all
        unset
        unset-all
        rename-section
        remove-section
        list|l
        edit|e
    );
}

sub configure {
    my ( $class, $config, $opt ) = @_;

    # Make sure we are accessing only one file.
    my @file = grep { $opt->{$_} } qw(local user system file);
    $class->usage('Only one config file at a time.') if @file > 1;

    # Make sure we have only one type.
    my @type = grep { $opt->{$_} } qw(bool int num bool_or_int);
    $class->usage('Only one type at a time.') if @type > 1;

    # Make sure we are performing only one action.
    my @action = grep { $opt->{$_} } qw(
        get
        get_all
        get_regex
        unset
        list
        edit
        add
        replace_all
        unset_all
        rename_section
        remove_section
    );
    $class->usage('Only one action at a time.') if @action > 1;

    # Get the action and context.
    my $context = first { $opt->{$_} } qw(local user system);

    # Make it so.
    return {
        ( $action[0]   ? ( action  => $action[0] )   : () ),
        ( $type[0]     ? ( type    => $type[0] )     : () ),
        ( $context     ? ( context => $context )     : () ),
        ( $opt->{file} ? ( file    => $opt->{file} ) : () ),
    };
}

sub execute {
    my $self = shift;
    my $action = $self->action || ( @_ > 1 ? 'set' : 'get' );
    $action =~ s/-/_/g;
    my $meth = $self->can($action) or hurl config => __x(
        'Unknown config action: {action}',
        action => $action,
    );
    return $self->$meth(@_);
}

sub get {
    my ( $self, $key, $rx ) = @_;
    $self->usage('Wrong number of arguments.') if !defined $key || $key eq '';

    my $val = try {
        $self->sqitch->config->get(
            key    => $key,
            filter => $rx,
            as     => $self->type,
            human  => 1,
        );
    }
    catch {
        hurl config => __x(
            'More then one value for the key "{key}"',
            key => $key,
        ) if /^\QMultiple values/i;
        hurl config => $_;
    };

    hurl {
        ident   => 'config',
        message => '',
        exitval => 1,
    } unless defined $val;
    $self->emit($val);
    return $self;
}

sub get_all {
    my ( $self, $key, $rx ) = @_;
    $self->usage('Wrong number of arguments.') if !defined $key || $key eq '';

    my @vals = try {
        $self->sqitch->config->get_all(
            key    => $key,
            filter => $rx,
            as     => $self->type,
            human  => 1,
        );
    }
    catch {
        hurl config => $_;
    };
    hurl {
        ident   => 'config',
        message => '',
        exitval => 1,
    } unless @vals;
    $self->emit( join "\n", @vals );
    return $self;
}

sub get_regex {
    my ( $self, $key, $rx ) = @_;
    $self->usage('Wrong number of arguments.') if !defined $key || $key eq '';

    my $config = $self->sqitch->config;
    my %vals   = try {
        $config->get_regexp(
            key    => $key,
            filter => $rx,
            as     => $self->type,
            human  => 1,
        );
    }
    catch {
        hurl config => $_;
    };
    hurl {
        ident   => 'config',
        message => '',
        exitval => 1,
    } unless %vals;
    my @out;
    for my $key ( sort keys %vals ) {
        if ( defined $vals{$key} ) {
            if ( $config->is_multiple($key) ) {
                push @out => "$key=[" . join( ', ', @{ $vals{$key} } ) . ']';
            }
            else {
                push @out => "$key=$vals{$key}";
            }
        }
        else {
            push @out => $key;
        }
    }
    $self->emit( join "\n" => @out );

    return $self;
}

sub set {
    my ( $self, $key, $value, $rx ) = @_;
    $self->_set( $key, $value, $rx, multiple => 0 );
}

sub add {
    my ( $self, $key, $value ) = @_;
    $self->_set( $key, $value, undef, multiple => 1 );
}

sub replace_all {
    my ( $self, $key, $value, $rx ) = @_;
    $self->_set( $key, $value, $rx, multiple => 1, replace_all => 1 );
}

sub _set {
    my ( $self, $key, $value, $rx, @p ) = @_;
    $self->usage('Wrong number of arguments.')
        if !defined $key || $key eq '' || !defined $value;

    $self->_touch_dir;
    try {
        $self->sqitch->config->set(
            key      => $key,
            value    => $value,
            filename => $self->file,
            filter   => $rx,
            as       => $self->type,
            @p,
        );
    }
    catch {
        hurl config => __(
            'Cannot overwrite multiple values with a single value'
        ) if /^Multiple occurrences/i;
        hurl config => $_;
    };
    return $self;
}

sub _file_config {
    my $file = shift->file;
    return unless -e $file;
    my $config = App::Sqitch::Config->new;
    $config->load_file($file);
    return $config;
}

sub unset {
    my ( $self, $key, $rx ) = @_;
    $self->usage('Wrong number of arguments.') if !defined $key || $key eq '';
    $self->_touch_dir;

    try {
        $self->sqitch->config->set(
            key      => $key,
            filename => $self->file,
            filter   => $rx,
            multiple => 0,
        );
    }
    catch {
        hurl config => __(
            'Cannot unset key with multiple values'
        ) if /^Multiple occurrences/i;
        hurl config => $_;
    };
    return $self;
}

sub unset_all {
    my ( $self, $key, $rx ) = @_;
    $self->usage('Wrong number of arguments.') if !defined $key || $key eq '';

    $self->_touch_dir;
    $self->sqitch->config->set(
        key      => $key,
        filename => $self->file,
        filter   => $rx,
        multiple => 1,
    );
    return $self;
}

sub list {
    my $self = shift;
    my $config = $self->context
        ? $self->_file_config
        : $self->sqitch->config;
    $self->emit( scalar $config->dump ) if $config;
    return $self;
}

sub edit {
    my $self = shift;

    # Let the editor deal with locking.
    $self->shell(
        $self->sqitch->editor . ' ' . $self->quote_shell( $self->file )
    );
}

sub rename_section {
    my ( $self, $old_name, $new_name ) = @_;
    $self->usage('Wrong number of arguments.')
        unless defined $old_name && $old_name ne ''
            && defined $new_name && $new_name ne '';

    try {
        $self->sqitch->config->rename_section(
            from     => $old_name,
            to       => $new_name,
            filename => $self->file
        );
    }
    catch {
        hurl config => __ 'No such section!' if /\Qno such section/i;
        hurl config => $_;
    };
    return $self;
}

sub remove_section {
    my ( $self, $section ) = @_;
    $self->usage('Wrong number of arguments.')
        unless defined $section && $section ne '';
    try {
        $self->sqitch->config->remove_section(
            section  => $section,
            filename => $self->file
        );
    }
    catch {
        hurl config => __ 'No such section!' if /\Qno such section/i;
        hurl config => $_;
    };
    return $self;
}

sub _touch_dir {
    my $self = shift;
    unless ( -e $self->file ) {
        require File::Basename;
        my $dir = File::Basename::dirname( $self->file );
        unless ( -e $dir && -d _ ) {
            require File::Path;
            File::Path::make_path($dir);
        }
    }
}

1;

__END__

=head1 Name

App::Sqitch::Command::config - Get and set local, user, or system Sqitch options

=head1 Synopsis

  my $cmd = App::Sqitch::Command::config->new(\%params);
  $cmd->execute;

=head1 Description

You can query/set/replace/unset Sqitch options with this command. The name is
actually the section and the key separated by a dot, and the value will be
escaped.

=head1 Interface

=head2 Class Methods

=head3 C<options>

  my @opts = App::Sqitch::Command::config->options;

Returns a list of L<Getopt::Long> option specifications for the command-line
options for the C<config> command.

=head3 C<configure>

  my $params = App::Sqitch::Command::config->configure(
      $config,
      $options,
  );

Processes the configuration and command options and returns a hash suitable
for the constructor. Exits with an error on option specification errors.

=head2 Constructor

=head3 C<new>

  my $config = App::Sqitch::Command::config->new($params);

Creates and returns a new C<config> command object. The supported parameters
include:

=over

=item C<sqitch>

The core L<Sqitch|App::Sqitch> object.

=item C<file>

Configuration file to read from and write to.

=item C<action>

The action to be executed. May be one of:

=over

=item * C<get>

=item * C<get-all>

=item * C<get-regexp>

=item * C<set>

=item * C<add>

=item * C<replace-all>

=item * C<unset>

=item * C<unset-all>

=item * C<list>

=item * C<edit>

=item * C<rename-section>

=item * C<remove-section>

=back

If not specified, the action taken by C<execute()> will depend on the number
of arguments passed to it. If only one, the action will be C<get>. If two or
more, the action will be C<set>.

=item C<context>

The configuration file context. Must be one of:

=over

=item * C<local>

=item * C<user>

=item * C<system>

=back

=item C<type>

The type to cast a value to be set to or fetched as. May be one of:

=over

=item * C<bool>

=item * C<int>

=item * C<num>

=item * C<bool-or-int>

=back

If not specified or C<undef>, no casting will be performed.

=back

=head2 Instance Methods

These methods are mainly provided as utilities for the command subclasses to
use.

=head3 C<execute>

  $config->execute($property, $value);

Executes the config command. Pass the name of the property and the value to
be assigned to it, if applicable.

=head3 C<get>

  $config->get($key);
  $config->get($key, $regex);

Emits the value for the specified key. The optional second argument is a
regular expression that the value to be returned must match. Exits with an
error if the is more than one value for the specified key, or if the key does
not exist.

=head3 C<get_all>

  $config->get_all($key);
  $config->get_all($key, $regex);

Like C<get()>, but emits all of the values for the given key, rather then
exiting with an error when there is more than one value.

=head3 C<get_regex>

  $config->get_regex($key);
  $config->get_regex($key, $regex);

Like C<get_all()>, but the first parameter is a regular expression that will
be matched against all keys.

=head3 C<set>

  $config->set($key, $value);
  $config->set($key, $value, $regex);

Sets the value for a key. Exits with an error if the key already exists and
has multiple values.

=head3 C<add>

  $config->add($key, $value);

Adds a value for a key. If the key already exists, the value will be added as
an additional value.

=head3 C<replace_all>

  $config->replace_all($key, $value);
  $config->replace_all($key, $value, $regex);

Replace all matching values.

=head3 C<unset>

  $config->unset($key);
  $config->unset($key, $regex);

Unsets a key. If the optional second argument is passed, the key will be unset
only if the value matches the regular expression. If the key has multiple
values, C<unset()> will exit with an error.

=head3 C<unset_all>

  $config->unset_all($key);
  $config->unset_all($key, $regex);

Like C<unset()>, but will not exit with an error if the key has multiple
values.

=head3 C<rename_section>

  $config->rename_section($old_name, $new_name);

Renames a section. Exits with an error if the section does not exist or if
either name is not a valid section name.

=head3 C<remove_section>

  $config->remove_section($section);

Removes a section. Exits with an error if the section does not exist.

=head3 C<list>

  $config->list;

Lists all of the values in the configuration. If the context is C<local>,
C<user>, or C<system>, only the settings set for that context will be emitted.
Otherwise, all settings will be listed.

=head3 C<edit>

  $config->edit;

Opens the context-specific configuration file in a text editor for direct
editing. If no context is specified, the local config file will be opened. The
editor is determined by L<Sqitch/editor>.

=head2 Instance Accessors

=head3 C<file>

  my $file_name = $config->file;

Returns the path to the configuration file to be acted upon. If the context is
C<system>, then the value returned is C<$($etc_prefix)/sqitch.conf>. If the
context is C<user>, then the value returned is C<~/.sqitch/sqitch.conf>.
Otherwise, the default is F<./sqitch.conf>.

=head1 See Also

=over

=item L<sqitch-config>

Help for the C<config> command to the Sqitch command-line client.

=item L<sqitch>

The Sqitch command-line client.

=back

=head1 Author

David E. Wheeler <[e-mail]>

=head1 License

Copyright (c) 2012-2023 iovation Inc., David E. Wheeler

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

=cut