Config::Tree::CmdLine - Read configuration tree from command line options

 # READING CONFIG FROM COMMAND LINE

 # in shell:

 % perl script.pl --foo/bar=3
 % perl script.pl --foo='{bar: 3}'; # same thing
 % perl script.pl '{bar: 3}'; # same thing, since ui.order of foo is 0

 # in script.pl:

 use Config::Tree::CmdLine;

 my $conf = Config::Tree::CmdLine->new(
     schema => [hash=>{keys=>{
         foo=>[hash=>{ keys=>{bar=>"int"}, "ui.order"=>0, "ui.description"=>"Foo is blah" }],
         baz=>[str=>{ "ui.order"=>1, "ui.description"=>"Baz is blah..." }],
     }}],
     # when_invalid => ...,
     # include_path_re => qr/.../,
     # exclude_path_re => qr/.../,
     # must_exist => 0|1,
     # special_options => {...},
     ro    => 0,
 );
 my $val = $conf->get('/foo/bar'); # 3
 $conf->cd('/foo');
 $conf->set('bar', 10); # same as set('/foo/bar', 10);




 # DISPLAYING HELP

 # in shell:
 % perl script.pl --help; # will display help using information from schema

package Config::Tree::CmdLine;

use Moose;
extends 'Config::Tree::Base';
use Data::Schema;
use File::Slurp;
use List::MoreUtils qw/any/;
use YAML::XS; # YAML.pm sucks: too strict for simple values, requiring ---, newline, etc

has _tree => (is => 'rw');
has _mtime => (is => 'rw');
has _loaded => (is => 'rw', default => 0);
has special_options => (is => 'rw');
has short_options => (is => 'rw'); # hashref, letter => long equivalent
has stop_after_first_arg => (is => 'rw', default => 0);
has argv => (is => 'rw');

sub BUILD {
    my ($self) = @_;
    if (!$self->special_options) {
        $self->special_options(
            { help => { schema=>'bool', sub=>sub {print $self->usage(), "\n"; exit 0} } }
        );
    }

    # immediately load
    $self->get_tree_for('/');
    $self->name("cmdline") unless $self->name;
}

# tree is a tree, vars is a hashref containing name=>val pairs. name can contain
# path separators and it will be added to the right branch.
sub __add_to_tree {
    my ($tree, $vars) = @_;

    foreach my $name (keys %$vars) {
        my $val = $vars->{$name};
        my $t = $tree;
        my @path = grep {length} split m!/+!, $name;
        my $n = pop @path;
        for (@path) {
            if (!exists $t->{$_}) {
                $t->{$_} = {};
                $t = $t->{$_};
            } else {
                die "Command line option conflict with previous one(s): $name";
            }
        }
        if (!exists($t->{$n})) {
            $t->{$n} = $val;
        } else {
            die "Command line option conflict: $name";
        }
    }
}

sub _get_tree {
    my ($self) = @_;

    unless ($self->_loaded) {
        my $tree = {};
        my @argv = $self->argv ? @{ $self->argv } : @ARGV;
        my $schema = $self->schema;
        my $key_schemas = $self->_get_all_key_schemas;

        my $i = 0;
        my @non_opts;
        while ($i < @argv) {
            my $a = $argv[$i];
            $i++;
            unless ($a =~ /^-/) {
                if ($self->stop_after_first_arg) {
                    push @non_opts, @argv[$i-1..$#argv];
                    last;
                } else {
                    push @non_opts, $a;
                    next;
                }
            }
            do { push @non_opts, @argv[$i .. $#argv]; last } if $a eq '--';
            my ($name, $eq, $val);
            if ($a =~ /^--/) {
                ($name, $eq, $val) = $a =~ m!^--/?(\w+(?:/\w+)*)(=)?(.*)!s
                    or die "Invalid command line option: $a";
            } else {
                $a =~ /^-(.)/;
                if ($self->short_options && $self->short_options->{$1}) {
                    $name = $self->short_options->{$1};
                } else {
                    die "Unknown short option: $a";
                }
            }

            # find in special options
            my $ss;
            if ($self->special_options && ($ss = $self->special_options->{$name})) {
                if ($ss->{schema} && ref($ss->{schema}) ne 'HASH') {
                    $ss->{schema} = $self->validator->normalize_schema($ss->{schema});
                }
                # XXX validate with schema ss?
            }

            # find in key schema
            my $p = $name =~ m!^/! ? $name : "/$name";
            my $ks = $key_schemas->{$p};
            my $found = $ss || $ks;

            my $takes_arg =
                ($ss && $ss->{schema} && $ss->{schema}{type} =~ /^(bool|boolean)$/) ? 0 :
                ($ks && $ks->{type} =~ /^(bool|boolean)$/) ? 0 : 1;

            # --nofoo (or --foo/nobar) for boolean
            my ($m1, $m2) = $p =~ m!(.*)/no(\w+)$!;
            if (defined($m2) && !$ks && $key_schemas->{"$m1/$m2"} &&
                $key_schemas->{"$m1/$m2"}{type} =~ /^(?:bool|boolean)$/) {
                $name = "$m1/$m2"; $name =~ s!^/!!;
                $val = 0;
                $found++;
            }
            # --foo followed by a non-opt, becomes --foo=NONOPT
            elsif ($takes_arg && !$eq && $i < @argv && $argv[$i] !~ /^--/) {
                $val = $argv[$i];
                $i++;
            }

            if ($schema && !$found) {
                if ($self->when_invalid eq 'die') {
                    die "Unknown option: $a";
                } elsif ($self->when_invalid eq 'warn') {
                    warn "Unknown option: $a";
                }
            }

            if (length($val)) {
                eval { $val = Load($val) };
                die "YAML parse error in command line option $a: $@" if $@;
            } else {
                # --foo followed by other opt, or --foo at the end => --foo=1
                $val = 1;
            }

            my $to_add;
            if ($ss) {
                $to_add = $ss->{sub}->($val, $self) || {};
            } else {
                $to_add = {$name=>$val};
            }
            __add_to_tree($tree, $to_add);
        }

        # add args to tree if ui.order attribute is specified
        my %indexes_found;
        for (keys %$key_schemas) {
            my $ks = $key_schemas->{$_};
            my $order = $ks->{attr_hashes}[0]{"ui.order"};
            next unless defined($order);
            next if $order >= @non_opts;
            die "Duplicate ui.order ($order) in keys schema: $_" if $indexes_found{$order};
            $indexes_found{$order} = $_;
        }
        for (sort {$b<=>$a} keys %indexes_found) {
            __add_to_tree($tree, {$indexes_found{$_} => $non_opts[$_]});
            splice @non_opts, $_, 1;
        }

        $self->_tree($tree);
        $self->_mtime(time);
        $self->_loaded(1);

        if ($self->argv) {
            $self->argv(\@non_opts);
        } else {
            @ARGV = @non_opts;
        }

    }
    ($self->_tree, $self->_mtime);
}

sub usage {
    my ($self, $key_schemas) = @_;
    $key_schemas ||= $self->_get_all_key_schemas;
    if (!$self->schema) { return "Sorry, no help available.\n" }
    my $v = $self->validator;
    my $schema = $v->normalize_schema($self->schema);
    my $u = '';

    my $tmp = $schema->{attr_hashes}[0]{"ui.description"};
    if (defined($tmp)) {
        my $app = $0; $app =~ s!.+/!!;
        $u .= "$app - $tmp\n\n";
    }

    $u .= "Options (* denotes required options):\n";
    for my $k (sort keys %$key_schemas) {
        my ($s, $sopt) = @{ $key_schemas->{$k} };
        my $desc = "[" . $v->get_type_handler($s->{type})->type_in_english($s) . "]";
        $tmp = $s->{attr_hashes}[0]{"ui.order"};
        $desc .= " [or arg ".($tmp+1)."]" if defined($tmp);
        $tmp = $s->{attr_hashes}[0]{"ui.description"};
        $desc .= " $tmp" if defined($tmp);
        $k =~ s!^/!!;
        $u .= sprintf "  --%-12s %s\n", $k . ($sopt->{required} ? "*" : ""), $desc;
    }

    $u;
}

# search schema for hashes and then list all its key schemas, recursively. as
# well as normalize the schemas into third form. return an empty list if there
# is no schema or no keys schemas.

sub _get_all_key_schemas {
    my ($self, $prefix, $schema, $res) = @_;

    $prefix ||= "";
    $schema ||= $self->schema;
    $res ||= {};

    if ($schema) {
        my $v = $self->validator;
        my $s = $v->normalize_schema($schema);
        my $mr = $v->merge_attr_hashes($s->{attr_hashes});
        for my $ah (@{ $mr->{result} }) {
            next unless ref($ah->{keys}) eq 'HASH';
            for my $hk (keys %{ $ah->{keys} }) {
                my $ss = $v->normalize_schema($ah->{keys}{$hk});
                my $k = $hk; $k =~ s/^[*+.^!-]//;
                next unless $k =~ /^\w+$/;
                my $pk = "$prefix/$k";
                next if exists $res->{$pk};
                my $required = 0;
                if (($ah->{required_keys} && any {$_ eq $k} @{ $ah->{required_keys} }) ||
                    ($ah->{required_keys_regex} && $k =~ /$ah->{required_keys_regex}/)) {
                    $required = 1;
                }
                $res->{$pk} = [$ss, {required=>$required}];
                $self->_get_all_key_schemas($pk, $ss, $res);
            }
        }
    }
    $res;
}

sub _format_validation_error {
    my ($self, $res) = @_;
    sprintf("%sconfig has %d error(s): `%s`",
            ($self->modified ? "modified " : ""),
            scalar(@{ $res->{errors} }),
            join(", ", @{ $res->{errors} }));
}

sub _save {
    my ($self) = @_;
    1;
}

__PACKAGE__->meta->make_immutable;
1;