view release on metacpan or  search on metacpan

lib/Perinci/CmdLine/Inline.pm  view on Meta::CPAN

                        push @l, "      handler => sub {},\n";
                    }
                    push @l, "    },\n";
                }
            }
            if ($stage == 1) {
                push @l, "};\n"; # end of %go_spec1
            } else {
                push @l, "  },\n"; # end of options
            }

            if ($stage == 2) {
                # subcommand options
                push @l, "  subcommands => {\n";
                for my $sc_name (sort keys %{ $cd->{metas} }) {
                    my $meta = $cd->{metas}{$sc_name};
                    push @l, "    '$sc_name' => {\n";
                    push @l, "      options => {\n";
                    my $ggl_res = $cd->{ggl_res}{$sc_name};
                    my $specmetas = $ggl_res->[3]{'func.specmeta'};
                    for my $o (sort keys %$specmetas) {
                        my $specmeta = $specmetas->{$o};
                        my $argname = $specmeta->{arg}; # XXX can't handle submetadata yet
                        next unless defined $argname;
                        my $arg_spec = $meta->{args}{$argname};
                        push @l, "        '$o' => {\n";
                        push @l, "          handler => sub { ";
                        if ($specmeta->{is_alias} && $specmeta->{is_code}) {
                            my $alias_spec = $arg_spec->{cmdline_aliases}{$specmeta->{alias}};
                            if ($specmeta->{is_code}) {
                                push @l, 'my $code = ', dmp($alias_spec->{code}), '; ';
                                push @l, '$code->(\%_pci_args);';
                            } else {
                                push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];';
                            }
                        } else {
                            if (($specmeta->{parsed}{type} // '') =~ /\@/) {
                                push @l, 'if ($mentioned_args{\'', $specmeta->{arg}, '\'}++) { push @{ $_pci_args{\'', $specmeta->{arg}, '\'} }, $_[1] } else { $_pci_args{\'', $specmeta->{arg}, '\'} = [$_[1]] }';
                            } elsif ($specmeta->{is_json}) {
                                push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = _pci_json()->decode($_[1]);';
                            } elsif ($specmeta->{is_neg}) {
                                push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = 0;';
                            } else {
                                push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];';
                            }
                        }
                        push @l, " },\n"; # end of handler
                        push @l, "        },\n"; # end of option
                    }
                    push @l, "      },\n"; # end of options
                    push @l, "    },\n"; # end of subcommand
                }
                push @l, "  },\n"; # end of subcommands
                push @l, "  default_subcommand => ".dmp($cd->{gen_args}{default_subcommand}).",\n";

                push @l, "};\n"; # end of %go_spec2
            } # subcommand options
        } # stage

        push @l, "{\n";
        push @l, '  local @ARGV = @ARGV;', "\n";
        push @l, '  my $old_conf = Getopt::Long::EvenLess::Configure("pass_through");', "\n";
        push @l, '  Getopt::Long::EvenLess::GetOptions(%$go_spec1);', "\n";
        push @l, '  Getopt::Long::EvenLess::Configure($old_conf);', "\n";
        push @l, '  { my $first_non_opt_arg; for (@ARGV) { next if /^-/; $first_non_opt_arg = $_; last } if (!length $_pci_r->{subcommand_name} && defined $first_non_opt_arg) { $_pci_r->{subcommand_name} = $first_non_opt_arg } }', "\n";
        push @l, '  if (!length $_pci_r->{subcommand_name}) { $_pci_r->{subcommand_name} = '.dmp($cd->{gen_args}{default_subcommand}).' } ' if defined $cd->{gen_args}{default_subcommand};
        push @l, "}\n";
        push @l, _gen_read_env($cd);
        push @l, _gen_read_config($cd);
        push @l, 'my $res = Getopt::Long::Subcommand::GetOptions(%$go_spec2);', "\n";
        push @l, '_pci_debug("args after GetOptions: ", \%_pci_args);', "\n" if $cd->{gen_args}{with_debug};
        push @l, '_pci_err([500, "GetOptions failed"]) unless $res->{success};', "\n";
        push @l, 'if (!length $_pci_r->{subcommand_name}) { print $help_msg; exit 0 }', "\n";

    } else {

        my $meta = $cd->{metas}{''};
        # stage 1 is catching common options only (--help, etc)
        for my $stage (1, 2) {
            push @l, "my \$go_spec$stage = {\n";
            for my $go_spec (sort keys %{ $cd->{ggl_res}{''}[2] }) {
                my $specmeta = $cd->{ggl_res}{''}[3]{'func.specmeta'}{$go_spec};
                my $co = $specmeta->{common_opt};
                next if $stage == 1 && !$co;
                push @l, "    '$go_spec' => sub { "; # begin option handler
                if ($co) {
                    if ($stage == 1) {
                        push @l, _gen_common_opt_handler($cd, $co);
                    } else {
                        # empty, we've done handling common options in stage 1
                    }
                } else {
                    my $arg_spec = $meta->{args}{$specmeta->{arg}};
                    push @l, '        ';
                    if ($stage == 1) {
                        # in stage 1, we do not yet deal with argument options
                    } elsif ($specmeta->{is_alias} && $specmeta->{is_code}) {
                        my $alias_spec = $arg_spec->{cmdline_aliases}{$specmeta->{alias}};
                        if ($specmeta->{is_code}) {
                            push @l, 'my $code = ', dmp($alias_spec->{code}), '; ';
                            push @l, '$code->(\%_pci_args);';
                        } else {
                            push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];';
                        }
                    } else {
                        if (($specmeta->{parsed}{type} // '') =~ /\@/) {
                            push @l, 'if ($mentioned_args{\'', $specmeta->{arg}, '\'}++) { push @{ $_pci_args{\'', $specmeta->{arg}, '\'} }, $_[1] } else { $_pci_args{\'', $specmeta->{arg}, '\'} = [$_[1]] }';
                        } elsif ($specmeta->{is_json}) {
                            push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = _pci_json()->decode($_[1]);';
                        } elsif ($specmeta->{is_neg}) {
                            push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = 0;';
                        } else {
                            push @l, '$_pci_args{\'', $specmeta->{arg}, '\'} = $_[1];';
                        }
                    }
                    push @l, "\n";
                }
                push @l, " },\n"; # end option handler
            } # options
            push @l, "};\n";
        } # stage