The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

use Test::Most;

plan qw/no_plan/;

our @did;

package My::Command;

    use Getopt::Chain::Declare;

    start [qw/ verbose|v /]; # These are "global"
                             # my-command --verbose initialize ...

    # my-command ? initialize ... --> my-command help initialize ...
    rewrite qr/^\?(.*)/ => sub { "help ".($1||'') };

    # NOTE: Rewriting applies to the command sequence, NOT options

    # my-command about ... --> my-command help about
    rewrite [ ['about', 'copying'] ] => sub { "help $1" };

    # my-command initialize --dir=...
    on initialize => [qw/ dir|d=s /], sub {
        my $context = shift;

        my $dir = $context->option( 'dir' );

        push @did, [ $context->command, dir => $dir ];
        # Do initialize stuff with $dir
    };

    # my-command help
    on help => undef, sub {
        my $context = shift;

        # Do help stuff ...
        # First argument is undef because help
        # doesn't take any options
        
        push @did, [ $context->command, ];
    };

    under help => sub {

        # my-command help create
        # my-command help initialize
        on [ [ qw/create initialize/ ] ] => undef, sub {
            my $context = shift;

            # Do help for create/initialize
            # Both: "help create" and "help initialize" go here

            push @did, [ $context->command, ];
        };

        # my-command help about
        on 'about' => undef, sub {
            my $context = shift;

            # Help for about...

            push @did, [ $context->command, ];
        };

        # my-command help copying
        on 'copying' => undef, sub {
            my $context = shift;

            # Help for copying...

            push @did, [ $context->command, ];
        };

        # my-command help ...
        on qr/^(\S+)$/ => undef, sub {
           my $context = shift;
           my $topic = $1;

            # Catch-all for anything not fitting into the above...
            
            push @did, [ $context->command, "I don't know about \"$topic\"\n" ]
        };
    };

no Getopt::Chain::Declare;

package main;

my $options;

sub run {
    undef @did;
    $options = My::Command->new->run( [ @_ ] );
}

run qw/--verbose/;
ok( $options->{verbose} );
ok( ! @did );

run qw/--verbose about/;
ok( $options->{verbose} );
cmp_deeply( \@did, [ [ "about" ] ] );

run qw/help copying/;
ok( ! $options->{verbose} );
cmp_deeply( \@did, [ [ "copying" ] ] );

run qw/initialize/;
ok( ! $options->{verbose} );
cmp_deeply( \@did, [ [ "initialize", dir => undef ] ] );

run qw/initialize --dir ./;
ok( ! $options->{verbose} );
cmp_deeply( \@did, [ [ "initialize", dir => '.' ] ] );

run qw/-v ? create/;
ok( $options->{verbose} );
cmp_deeply( \@did, [ [ "create" ] ] );

run qw/? xyzzy/;
cmp_deeply( \@did, [ [ "xyzzy", "I don't know about \"xyzzy\"\n" ] ] );