File Coverage

blib/lib/Getopt/Long/Descriptive.pm

Criterion	Covered	Total	%
statement	234	324	72.2
branch	77	140	55.0
condition	38	63	60.3
subroutine	33	40	82.5
pod	3	3	100.0
total	385	570	67.5

use strict;
use warnings;
package Getopt::Long::Descriptive 0.117;
# ABSTRACT: Getopt::Long, but simpler and more powerful

use v5.12;

use Carp qw(carp croak);
use File::Basename ();
use Getopt::Long 2.55;
use List::Util qw(first);
use Params::Validate 0.97 qw(:all);
use Scalar::Util ();

use Getopt::Long::Descriptive::Opts;
use Getopt::Long::Descriptive::Usage;

#pod =head1 SYNOPSIS
#pod
#pod   use Getopt::Long::Descriptive;
#pod
#pod   my ($opt, $usage) = describe_options(
#pod     'my-program %o ',
#pod     [ 'server|s=s', "the server to connect to", { required => 1  } ],
#pod     [ 'port|p=i',   "the port to connect to",   { default  => 79 } ],
#pod     [],
#pod     [ 'verbose|v',  "print extra stuff"            ],
#pod     [ 'help',       "print usage message and exit", { shortcircuit => 1 } ],
#pod   );
#pod
#pod   print($usage->text), exit if $opt->help;
#pod
#pod   Client->connect( $opt->server, $opt->port );
#pod
#pod   print "Connected!\n" if $opt->verbose;
#pod
#pod ...and running C will produce:
#pod
#pod   my-program [-psv] [long options...]
#pod     -s --server     the server to connect to
#pod     -p --port       the port to connect to
#pod
#pod     -v --verbose    print extra stuff
#pod     --help          print usage message and exit
#pod
#pod =head1 DESCRIPTION
#pod
#pod Getopt::Long::Descriptive is yet another Getopt library.  It's built atop
#pod Getopt::Long, and gets a lot of its features, but tries to avoid making you
#pod think about its huge array of options.
#pod
#pod It also provides usage (help) messages, data validation, and a few other useful
#pod features.
#pod
#pod =head1 FUNCTIONS
#pod
#pod Getopt::Long::Descriptive only exports one routine by default:
#pod C.  All GLD's exports are exported by L.
#pod
#pod =head2 describe_options
#pod
#pod   my ($opt, $usage) = describe_options($usage_desc, @opt_spec, \%arg);
#pod
#pod This routine inspects C<@ARGV> for options that match the supplied spec. If all
#pod the options are valid then it returns the options given and an object for
#pod generating usage messages; if not then it dies with an explanation of what was
#pod wrong and a usage message.
#pod
#pod The C<$opt> object will be a dynamically-generated subclass of
#pod L.  In brief, each of the options in
#pod C<@opt_spec> becomes an accessor method on the object, using the first-given
#pod name, with dashes converted to underscores.  For more information, see the
#pod documentation for the Opts class.
#pod
#pod The C<$usage> object will be a L object,
#pod which provides a C method to get the text of the usage message and C
#pod to die with it.  For more methods and options, consults the documentation for
#pod the Usage class.
#pod
#pod =head3 $usage_desc
#pod
#pod The C<$usage_desc> parameter to C is a C-like string
#pod that is used in generating the first line of the usage message.  It's a
#pod one-line summary of how the command is to be invoked.  A typical usage
#pod description might be:
#pod
#pod   $usage_desc = "%c %o  ";
#pod
#pod C<%c> will be replaced with what Getopt::Long::Descriptive thinks is the
#pod program name (it's computed from C<$0>, see L).
#pod
#pod C<%o> will be replaced with a list of the short options, as well as the text
#pod "[long options...]" if any have been defined.
#pod
#pod The rest of the usage description can be used to summarize what arguments are
#pod expected to follow the program's options, and is entirely free-form.
#pod
#pod Literal C<%> characters will need to be written as C<%%>, just like with
#pod C.
#pod
#pod =head3 @opt_spec
#pod
#pod The C<@opt_spec> part of the args to C is used to configure
#pod option parsing and to produce the usage message.  Each entry in the list is an
#pod arrayref describing one option, like this:
#pod
#pod   @opt_spec = (
#pod     [ "verbose|V" => "be noisy"       ],
#pod     [ "logfile=s" => "file to log to" ],
#pod   );
#pod
#pod The first value in the arrayref is a Getopt::Long-style option specification.
#pod In brief, they work like this:  each one is a pipe-delimited list of names,
#pod optionally followed by a type declaration.  Type declarations are '=x' or ':x',
#pod where C<=> means a value is required and C<:> means it is optional.  I may
#pod be 's' to indicate a string is required, 'i' for an integer, or 'f' for a
#pod number with a fractional part.  The type spec may end in C<@> to indicate that
#pod the option may appear multiple times.
#pod
#pod For more information on how these work, see the L documentation.
#pod
#pod The first name given should be the canonical name, as it will be used as the
#pod accessor method on the C<$opt> object.  Dashes in the name will be converted to
#pod underscores, and all letters will be lowercased.  For this reason, all options
#pod should generally have a long-form name.
#pod
#pod The second value in the arrayref is a description of the option, for use in the
#pod usage message.
#pod
#pod =head4 Special Option Specifications
#pod
#pod If the option specification (arrayref) is empty, it will have no effect other
#pod than causing a blank line to appear in the usage message.
#pod
#pod If the option specification contains only one element, it will be printed in
#pod the usage message with no other effect.  If the element is a reference, its
#pod referent will be printed as-is.  Otherwise, it will be reformatted like other
#pod text in the usage message.
#pod
#pod If the option specification contains a third element, it adds extra constraints
#pod or modifiers to the interpretation and validation of the value.  These are the
#pod keys that may be present in that hashref, and how they behave:
#pod
#pod =over 4
#pod
#pod =item implies
#pod
#pod   implies => 'bar'
#pod   implies => [qw(foo bar)]
#pod   implies => { foo => 1, bar => 2 }
#pod
#pod If option I has an "implies" entry, then if I is given, other options
#pod will be enabled.  The value may be a single option to set, an arrayref of
#pod options to set, or a hashref of options to set to specific values.
#pod
#pod =item required
#pod
#pod   required => 1
#pod
#pod If an option is required, failure to provide the option will result in
#pod C printing the usage message and exiting.
#pod
#pod =item hidden
#pod
#pod   hidden => 1
#pod
#pod This option will not show up in the usage text.
#pod
#pod You can achieve the same behavior by using the string "hidden" for the option's
#pod description.
#pod
#pod =item one_of
#pod
#pod   one_of => \@subopt_specs
#pod
#pod This is useful for a group of options that are related.  Each option
#pod spec is added to the list for normal parsing and validation.
#pod
#pod Your option name will end up with a value of the name of the
#pod option that was chosen.  For example, given the following spec:
#pod
#pod   [ "mode" => hidden => { one_of => [
#pod     [ "get|g"  => "get the value" ],
#pod     [ "set|s"  => "set the value" ],
#pod     [ "delete" => "delete it" ],
#pod   ] } ],
#pod
#pod No usage text for 'mode' will be displayed, but text for get, set, and delete
#pod will be displayed.
#pod
#pod If more than one of get, set, or delete is given, an error will be thrown.
#pod
#pod So, given the C<@opt_spec> above, and an C<@ARGV> of C<('--get')>, the
#pod following would be true:
#pod
#pod   $opt->get == 1;
#pod
#pod   $opt->mode eq 'get';
#pod
#pod B: C would not be set if C defaulted to 'get' and no arguments
#pod were passed in.
#pod
#pod Even though the option sub-specs for C are meant to be 'first
#pod class' specs, some options don't make sense with them, e.g. C.
#pod
#pod As a further shorthand, you may specify C options using this form:
#pod
#pod   [ mode => \@option_specs, \%constraints ]
#pod
#pod
#pod =item shortcircuit
#pod
#pod   shortcircuit => 1
#pod
#pod If this option is present no other options will be returned.  Other
#pod options present will be checked for proper types, but I for
#pod constraints.  This provides a way of specifying C<--help> style options.
#pod
#pod =item Params::Validate
#pod
#pod In addition, any constraint understood by Params::Validate may be used.
#pod
#pod For example, to accept positive integers:
#pod
#pod   [ 'max-iterations=i', "maximum number of iterations",
#pod     { callbacks => { positive => sub { shift() > 0 } } } ],
#pod
#pod (Internally, all constraints are translated into Params::Validate options or
#pod callbacks.)
#pod
#pod =back
#pod
#pod =head3 %arg
#pod
#pod The C<%arg> to C is optional.  If the last parameter is a
#pod hashref, it contains extra arguments to modify the way C
#pod works.  Valid arguments are:
#pod
#pod   getopt_conf   - an arrayref of strings, passed to Getopt::Long::Configure
#pod   show_defaults - a boolean which controls whether an option's default
#pod                   value (if applicable) is shown as part of the usage message
#pod                   (for backward compatibility this defaults to false)
#pod
#pod =head2 prog_name
#pod
#pod This routine, exported on demand, returns the basename of C<$0>, grabbed at
#pod compile-time.  You can override this guess by calling C
#pod yourself.
#pod
#pod =head1 OTHER EXPORTS
#pod
#pod =head2 C<-types>
#pod
#pod Any of the Params::Validate type constants (C, etc.) can be imported as
#pod well.  You can get all of them at once by importing C<-types>.
#pod
#pod =head2 C<-all>
#pod
#pod This import group will import C<-type>, C, and C.
#pod
#pod =cut

my $prog_name;
sub prog_name { @_ ? ($prog_name = shift) : $prog_name }

BEGIN {
  # grab this before someone decides to change it
  prog_name(File::Basename::basename($0));
}

use Sub::Exporter::Util ();
use Sub::Exporter 0.972 -setup => {
  exports => [
    describe_options  => \'_build_describe_options',
    q(prog_name),
    @{ $Params::Validate::EXPORT_TAGS{types} }
  ],
  groups  => [
    default => [ qw(describe_options) ],
    types   => $Params::Validate::EXPORT_TAGS{types},
  ],
};

my %CONSTRAINT = (
  implies  => \&_mk_implies,
  only_one => \&_mk_only_one,
);

our $MungeOptions = 1;

our $TERM_WIDTH;
{
  $TERM_WIDTH = $ENV{COLUMNS} || 80;

  # So, this was the old code:
  #
  #   if (eval { require Term::ReadKey; 1 }) {
  #     my ($width) = Term::ReadKey::GetTerminalSize();
  #     $TERM_WIDTH = $width;
  #   } else {
  #     $TERM_WIDTH = $ENV{COLUMNS} || 80;
  #   }
  #
  # ...but the problem is that Term::ReadKey will carp when it can't get an
  # answer, it can't be trivially made to keep quiet.  (I decline to stick a
  # local $SIG{__WARN__} here, as it's too heavy a hammer.)  With the new (as
  # of 2021-03) formatting code, using the full width is less of an issue,
  # anyway.
}

sub _nohidden {
  return grep { ! $_->{constraint}->{hidden} } @_;
}

sub _expand {
  my @expanded;

  for my $opt (@_) {
    push @expanded, {
      spec       => $opt->[0] || '',
      desc       => @$opt > 1 ? $opt->[1] : 'spacer',
      constraint => $opt->[2] || {},

      # if @$_ is 0 then we got [], a spacer
      name       => @$opt ? _munge((split /[:=|!+]/, $opt->[0] || '')[0]) : '',
    };
  }

  return @expanded;
}

my %HIDDEN = (
  hidden => 1,
);

my $SPEC_RE = qr{(?:[:=][0-9\w\+]+[%@]?(\{[0-9]*,[0-9]*\})?|[!+])$};
sub _strip_assignment {
  my ($self, $str) = @_;

  (my $copy = $str) =~ s{$SPEC_RE}{};

  if (wantarray) {
    my $len = length $copy;
    my $assignment = substr($str, $len) // q{};

    return ($copy, $assignment);
  }
  return $copy;
}

# This is here only to deal with people who were calling this fully-qualified
# without importing.  Sucks to them!  -- rjbs, 2009-08-21
sub describe_options {
  my $sub = __PACKAGE__->_build_describe_options(describe_options => {} => {});
  $sub->(@_);
}

sub usage_class { 'Getopt::Long::Descriptive::Usage' }

sub _build_describe_options {
  my ($class) = @_;

  sub {
    my $format = (ref $_[0] ? '%c %o' : shift(@_));
    my $arg    = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};

    # If GETOPT_LONG_DESCRIPTIVE_COMPLETION is set, emit a shell completion
    # script to stdout and exit 42.  Supported values are 'bash' and 'zsh'.
    # Any other value raises an exception.  If
    # GETOPT_LONG_DESCRIPTIVE_COMPLETION_NAME is set, it is treated as a
    # comma-separated list of command names to register completion for,
    # overriding the script name. -- claude, 2026-02-19
    if (my $shell = $ENV{GETOPT_LONG_DESCRIPTIVE_COMPLETION}) {
      if ($shell eq 'bash') {
        print _bash_completion_script(@_);
        exit 42;
      } elsif ($shell eq 'zsh') {
        print _zsh_completion_script(@_);
        exit 42;
      } else {
        Carp::croak("unknown shell '$shell' in GETOPT_LONG_DESCRIPTIVE_COMPLETION");
      }
    }

    my @opts;

    my %parent_of;

    # special casing
    # wish we had real loop objects
    my %method_map;
    for my $opt (_expand(@_)) {
      $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer';

      if (ref($opt->{desc}) eq 'ARRAY') {
        $opt->{constraint}->{one_of} = delete $opt->{desc};
        $opt->{desc} = 'hidden';
      }

      if ($HIDDEN{$opt->{desc}}) {
        $opt->{constraint}->{hidden}++;
      }

      if ($opt->{constraint}->{one_of}) {
        for my $one_opt (_expand(
          @{delete $opt->{constraint}->{one_of}}
        )) {
          $parent_of{$one_opt->{name}} = $opt->{name};
          $one_opt->{constraint}->{implies}
            ->{$opt->{name}} = $one_opt->{name};
          for my $wipe (qw(required default)) {
            if ($one_opt->{constraint}->{$wipe}) {
              carp "'$wipe' constraint does not make sense in sub-option";
              delete $one_opt->{constraint}->{$wipe};
            }
          }
          $one_opt->{constraint}->{one_of} = $opt->{name};
          push @opts, $one_opt;

          # Ensure that we generate accessors for all one_of sub-options
          $method_map{ $one_opt->{name} } = undef
            unless $one_opt->{desc} eq 'spacer';
        }
      }

      if ($opt->{constraint}{shortcircuit}
        && exists $opt->{constraint}{default}
      ) {
        carp('option "' . $opt->{name} . q[": 'default' does not make sense for shortcircuit options]);
      }

      push @opts, $opt;
    }

    my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
    if ($arg->{getopt}) {
      warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
    }

    push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
    push @go_conf, "no_auto_help"  unless grep { /no_auto_help/i } @go_conf;
    push @go_conf, "no_ignore_case"
      unless grep { /no_ignore_case/i } @go_conf;

    # not entirely sure that all of this (until the Usage->new) shouldn't be
    # moved into Usage -- rjbs, 2009-08-19

    # all specs including hidden
    my @getopt_specs =
      map  { $_->{spec} }
      grep { $_->{desc} ne 'spacer' }
      @opts;

    my @specs =
      map  { $_->{spec} }
      grep { $_->{desc} ne 'spacer' }
      _nohidden(@opts);

    my @options =
      map   { split /\|/ }
      map   { scalar __PACKAGE__->_strip_assignment($_) }
      @specs;

    my %opt_count;
    $opt_count{$_}++ for @options;

    my $short = join q{},
      sort  { lc $a cmp lc $b or $a cmp $b }
      grep  { /^.$/ }
      @options;

    my $long = grep /\b[^|]{2,}/, @specs;

    my %replace = (
      "%" => "%",
      "c" => prog_name,
      "o" => join(q{ },
        ($short ? "[-$short]" : ()),
        ($long  ? "[long options...]" : ())
      ),
    );

    (my $str = $format) =~ s<%(.)><
      $replace{$1}
      // Carp::croak("unknown sequence %$1 in first argument to describe_options")
    >ge;

    $str =~ s/[\x20\t]{2,}/ /g;

    my $usage = $class->usage_class->new({
      options       => [ _nohidden(@opts) ],
      leader_text   => $str,
      show_defaults => $arg->{show_defaults},
    });

    my $old_go_conf = Getopt::Long::Configure(@go_conf);

    my %return;
    $usage->die unless GetOptions(\%return, grep { length } @getopt_specs);
    my @given_keys = keys %return;

    Getopt::Long::Configure($old_go_conf);

    for my $opt (keys %return) {
      my $newopt = _munge($opt);
      next if $newopt eq $opt;
      $return{$newopt} = delete $return{$opt};
    }

    # ensure that shortcircuit options are handled first
    for my $copt (
      sort {     ($b->{constraint}{shortcircuit} || 0)
             <=> ($a->{constraint}{shortcircuit} || 0)
           } grep { $_->{constraint} } @opts
    ) {
      delete $copt->{constraint}->{hidden};
      my $is_shortcircuit = delete $copt->{constraint}{shortcircuit};
      my $name = $copt->{name};
      my $new  = _validate_with(
        name   => $name,
        params => \%return,
        spec   => $copt->{constraint},
        opts   => \@opts,
        usage  => $usage,
        given_keys => \@given_keys,
        parent_of  => \%parent_of,
      );
      next unless defined $new || exists $return{$name};
      $return{$name} = $new;

      if ($is_shortcircuit) {
        %return = ($name => $return{$name});
        last;
      }
    }

    my $opt_obj = Getopt::Long::Descriptive::Opts->___new_opt_obj({
      values => { %method_map, %return },
      given  => { map {; $_ => 1 } @given_keys },
    });

    return($opt_obj, $usage);
  }
}

sub _munge {
  my ($opt) = @_;
  return $opt unless $MungeOptions;
  $opt = lc($opt);
  $opt =~ tr/-/_/;
  return $opt;
}

sub _validate_with {
  my (%arg) = validate(@_, {
    name   => 1,
    params => 1,
    spec   => 1,
    opts   => 1,
    usage  => 1,
    given_keys => 1,
    parent_of  => 1,
  });

  my $spec = $arg{spec};
  my %pvspec;
  SPEC_ENTRY: for my $ct (keys %{$spec}) {
    if ($ct eq 'required') {
      # This used to be in %CONSTRAINT but this whole system is a bit
      # overcomplex, I think, and moving this here makes life simpler.  Someday
      # (ha ha) this can all be overhauled. -- rjbs, 2024-01-20
      $pvspec{optional} = ! $spec->{$ct};
      next SPEC_ENTRY;
    }

    if ($CONSTRAINT{$ct} and ref $CONSTRAINT{$ct} eq 'CODE') {
      $pvspec{callbacks} ||= {};
      $pvspec{callbacks} = {
        %{$pvspec{callbacks}},
        $CONSTRAINT{$ct}->(
          $arg{name},
          $spec->{$ct},
          $arg{params},
          $arg{opts},
        ),
      };
    } else {
      %pvspec = (
        %pvspec,
        $CONSTRAINT{$ct} ? %{$CONSTRAINT{$ct}} : ($ct => $spec->{$ct}),
      );
    }
  }

  $pvspec{optional} = 1 unless exists $pvspec{optional};

  # we need to implement 'default' by ourselves sometimes
  # because otherwise the implies won't be checked/executed
  # XXX this should be more generic -- we'll probably want
  # other callbacks to always run, too
  if (!defined($arg{params}{$arg{name}})
        && $pvspec{default}
          && $spec->{implies}) {

    $arg{params}{$arg{name}} = delete $pvspec{default};
  }

  my %p;
  my $ok = eval {
    %p = validate_with(
      params => [
        %{$arg{params}},
        '-given_keys', $arg{given_keys},
        '-parent_of',  $arg{parent_of},
      ],
      spec   => { $arg{name} => \%pvspec },
      allow_extra => 1,
      on_fail     => sub {
        my $fail_msg = shift;
        Getopt::Long::Descriptive::_PV_Error->throw($fail_msg);
      },
    );
    1;
  };

  if (! $ok) {
    my $error = $@;
    if (
      Scalar::Util::blessed($error)
      && $error->isa('Getopt::Long::Descriptive::_PV_Error')
    ) {
      $arg{usage}->die({ pre_text => $error->error . "\n" });
    }

    die $@;
  }

  return $p{$arg{name}};
}

# scalar:   single option = true
# arrayref: multiple options = true
# hashref:  single/multiple options = given values
sub _norm_imply {
  my ($what) = @_;

  return { $what => 1 } unless my $ref = ref $what;

  return $what                      if $ref eq 'HASH';
  return { map { $_ => 1 } @$what } if $ref eq 'ARRAY';

  die "can't imply: $what";
}

sub _mk_implies {
  my $name = shift;
  my $what = _norm_imply(shift);
  my $param = shift;
  my $opts  = shift;

  for my $implied (keys %$what) {
    die("option specification for $name implies nonexistent option $implied\n")
      unless first { $_->{name} eq $implied } @$opts
  }

  my $whatstr = join(q{, }, map { "$_=$what->{$_}" } keys %$what);

  return "$name implies $whatstr" => sub {
    my ($pv_val, $rest) = @_;

    # negatable options will be 0 here, which is ok.
    return 1 unless defined $pv_val;

    while (my ($key, $val) = each %$what) {
      # Really, this should be called "-implies" and should include all implies
      # relationships, but they'll have to get handled by setting conflicts.
      my $parent   = $rest->{'-parent_of'}{$name};
      my @siblings = $parent
                   ? (grep {; defined $rest->{'-parent_of'}{$_}
                              && $rest->{'-parent_of'}{$_} eq $parent }
                      @{ $rest->{'-given_keys'} })
                   : ();

      if (@siblings > 1) {
        die "these options conflict; each wants to set the $parent: @siblings\n";
      }

      if (  exists $param->{$key}
        and $param->{$key} ne $val
        and grep {; $_ eq $key } @{ $rest->{'-given_keys'} }
      ) {
        die(
          "option specification for $name implies that $key should be "
          . "set to '$val', but it is '$param->{$key}' already\n"
        );
      }
      $param->{$key} = $val;
    }

    return 1;
  };
}

sub _mk_only_one {
  die "unimplemented";
}

# Parse the opt_spec list (same format as describe_options) into a list of
# hashrefs suitable for generating completion data.  Hidden and spacer entries
# are omitted.  one_of grouping options are transparent: the outer option is
# skipped and its sub-options are included in its place.
sub _parse_specs_for_completion {
  pop if ref $_[-1] eq 'HASH';
  my @parsed;

  for my $opt (_expand(@_)) {
    next if $opt->{desc} eq 'spacer';  # skip spacers and display-only text entries

    my $constraint = $opt->{constraint};

    # one_of comes in two forms:
    #   Form 1: [ 'group', [ [inner specs...] ] ]   -- desc is the arrayref
    #   Form 2: [ 'group', 'desc', { one_of => [...] } ]  -- explicit constraint
    # In both cases suppress the outer option and recurse into the sub-options.
    if (ref($opt->{desc}) eq 'ARRAY') {
      push @parsed, _parse_specs_for_completion(@{ $opt->{desc} });
      next;
    }

    if (ref($constraint->{one_of}) eq 'ARRAY') {
      push @parsed, _parse_specs_for_completion(@{ $constraint->{one_of} });
      next;
    }

    next if $constraint->{hidden} || ($opt->{desc} // '') eq 'hidden';

    my ($names_str, $assignment) = __PACKAGE__->_strip_assignment($opt->{spec});

    push @parsed, {
      names       => [ split /\|/, $names_str ],
      takes_value => !!($assignment =~ /\A[:=]/),
      negatable   => !!($assignment =~ /\A!/),
      desc        => $opt->{desc},
      completion  => $constraint->{completion},
    };
  }

  return @parsed;
}

sub _bash_completion_action {
  my ($completion) = @_;

  if (ref $completion eq 'ARRAY') {
    return undef unless @$completion;
    my $vals = join q{ }, @$completion;
    return qq{COMPREPLY=(\$(compgen -W "$vals" -- "\$cur"))};
  }

  return q{COMPREPLY=($(compgen -f -- "$cur"))} if $completion eq 'files';
  return q{COMPREPLY=($(compgen -d -- "$cur"))} if $completion eq 'dirs';

  if ($completion =~ /\Afn:(.+)\z/) {
    return qq{COMPREPLY=(\$($1 "\$cur"))};
  }

  return undef;
}

sub _zsh_completion_action {
  my ($completion) = @_;

  return '_files'    if $completion eq 'files';
  return '_files -/' if $completion eq 'dirs';

  if (ref $completion eq 'ARRAY') {
    return '(' . join(' ', @$completion) . ')';
  }

  if ($completion =~ /\Afn:(.+)\z/) {
    return $1;
  }

  return '';
}

# _completion_for_bash(\@opt_spec)
#
# Given an @opt_spec in the same format as describe_options, returns a hashref
# describing bash completion for those options.
#
# The 'flags' key holds a space-separated string of all option flags, suitable
# for passing to compgen -W.
#
# The 'prev_cases' key holds an arrayref of hashrefs, each with a 'pattern'
# (suitable for a case "$prev" arm) and an 'action' (bash code that sets
# COMPREPLY).  Only options that carry a 'completion' key in their constraint
# hashref produce a prev_case entry.
#
# The 'completion' key in an option's constraint hashref may be:
#   - an arrayref: completes from a fixed list
#   - 'files':     completes to file paths
#   - 'dirs':      completes to directory paths
#   - 'fn:NAME':   delegates to the named shell function; $cur is available
#                  in the environment
sub _completion_for_bash {
  my (@specs) = @_;

  my @flags;
  my @prev_cases;

  for my $p (_parse_specs_for_completion(@specs)) {
    for my $name (@{ $p->{names} }) {
      push @flags, length($name) == 1 ? "-$name" : "--$name";
      push @flags, "--no-$name" if $p->{negatable} && length($name) > 1;
    }

    if ($p->{takes_value} && defined $p->{completion}) {
      my $action = _bash_completion_action($p->{completion});
      if (defined $action) {
        my $pattern = join '|',
          map { length($_) == 1 ? "-$_" : "--$_" } @{ $p->{names} };
        push @prev_cases, { pattern => $pattern, action => $action };
      }
    }
  }

  return {
    flags      => join(' ', @flags),
    prev_cases => \@prev_cases,
  };
}

# _completion_for_zsh(@opt_spec)
#
# Given an @opt_spec in the same format as describe_options, returns a list of
# strings in _arguments spec format for use in a zsh completion function.
# Each string describes one option flag.  The 'completion' constraint key is
# supported with the same values as _completion_for_bash.
sub _completion_for_zsh {
  my (@specs) = @_;

  my @args;
  for my $p (_parse_specs_for_completion(@specs)) {
    my $safe_desc = $p->{desc} // '';
    $safe_desc =~ s/\[/\\[/g;
    $safe_desc =~ s/\]/\\]/g;
    $safe_desc =~ s/'/'\\''/g;

    for my $name (@{ $p->{names} }) {
      my $flag = length($name) == 1 ? "-$name" : "--$name";
      if ($p->{takes_value}) {
        my $action = defined $p->{completion}
          ? _zsh_completion_action($p->{completion})
          : '';
        push @args, qq('${flag}=[${safe_desc}]: :${action}');
      } else {
        push @args, qq('${flag}[${safe_desc}]');
      }
      push @args, qq('--no-${name}[disable ${name}]')
        if $p->{negatable} && length($name) > 1;
    }
  }

  return @args;
}

sub _completion_names {
  if (my $names = $ENV{GETOPT_LONG_DESCRIPTIVE_COMPLETION_NAME}) {
    return split /,/, $names;
  }
  return prog_name();
}

sub _bash_completion_script {
  my @names = _completion_names();
  (my $fn_name = "_$names[0]_completion") =~ s/[^a-zA-Z0-9_]/_/g;

  my $data = _completion_for_bash(@_);

  my $script  = "$fn_name() {\n";
  $script    .= "    local cur prev\n";
  $script    .= "    COMPREPLY=()\n";
  $script    .= '    cur="${COMP_WORDS[COMP_CWORD]}"' . "\n";
  $script    .= '    prev="${COMP_WORDS[COMP_CWORD-1]}"' . "\n";

  if (@{ $data->{prev_cases} }) {
    $script  .= "    case \"\$prev\" in\n";
    for my $case (@{ $data->{prev_cases} }) {
      $script .= "        $case->{pattern})\n";
      $script .= "            $case->{action}\n";
      $script .= "            return\n";
      $script .= "            ;;\n";
    }
    $script  .= "    esac\n";
  }

  my $flags = $data->{flags};
  $script  .= "    COMPREPLY=(\$(compgen -W \"$flags\" -- \"\$cur\"))\n";
  $script  .= "}\n";
  $script  .= "complete -F $fn_name $_\n" for @names;

  return $script;
}

sub _zsh_completion_script {
  my @names = _completion_names();
  (my $fn_name = "_$names[0]") =~ s/[^a-zA-Z0-9_]/_/g;

  my @args = _completion_for_zsh(@_);

  my $script  = "#compdef " . join(' ', @names) . "\n";
  $script    .= "$fn_name() {\n";
  $script    .= "    local -a arguments\n";
  $script    .= "    arguments=(\n";
  $script    .= "        $_\n" for @args;
  $script    .= "    )\n";
  $script    .= "    _arguments \$arguments\n";
  $script    .= "}\n";
  $script    .= "$fn_name\n";

  return $script;
}

{
  package
    Getopt::Long::Descriptive::_PV_Error;
  sub error { $_[0]->{error} }
  sub throw {
    my ($class, $error_msg) = @_;
    my $self = { error => $error_msg };
    bless $self, $class;
    die $self;
  }
}

#pod =head1 CUSTOMIZING
#pod
#pod Getopt::Long::Descriptive uses L to build and
#pod export the C routine.  By writing a new class that extends
#pod Getopt::Long::Descriptive, the behavior of the constructed C
#pod routine can be changed.
#pod
#pod The following methods can be overridden:
#pod
#pod =head2 usage_class
#pod
#pod   my $class = Getopt::Long::Descriptive->usage_class;
#pod
#pod This returns the class to be used for constructing a Usage object, and defaults
#pod to Getopt::Long::Descriptive::Usage.
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L
#pod * L
#pod
#pod =cut

1; # End of Getopt::Long::Descriptive

__END__