view release on metacpan or  search on metacpan

lib/App/MatrixTool.pm  view on Meta::CPAN

C<App::MatrixTool> - commands to interact with a Matrix home-server

=head1 SYNOPSIS

Usually this would be used via the F<matrixtool> command

 $ matrixtool server-key matrix.org

=head1 DESCRIPTION

Provides the base class and basic level support for commands that interact
with a Matrix home-server. See individual command modules, found under the
C<App::MatrixTool::Command::> namespace, for details on specific commands.

=cut

readonly_struct ArgSpec => [qw( name print_name optional eatall )];
sub ARGSPECS
{
   map {
      my $name = $_;
      my $optional = $name =~ s/\?$//;
      my $eatall   = $name =~ m/\.\.\.$/;

      ( my $print_name = uc $name ) =~ s/_/-/g;

      ArgSpec( $name, $print_name, $optional||$eatall, $eatall )
   } shift->ARGUMENTS;
}

readonly_struct OptSpec => [qw( name print_name shortname getopt description )];
sub OPTSPECS
{
   pairmap {
      my ( $name, $desc ) = ( $a, $b ); # allocate new SVtPVs to placate odd COW-related bug in 5.18

      my $getopt = $name;

      $name =~ s/=.*//;

      my $shortname;
      $name =~ s/^(.)\|// and $shortname = $1;

      my $printname = $name;
      $name =~ s/-/_/g;

      OptSpec( $name, $printname, $shortname, $getopt, $desc )
   } shift->OPTIONS;
}

sub new
{
   my $class = shift;
   return bless { @_ }, $class;
}

sub sock_family
{
   my $self = shift;
   return AF_INET if $self->{inet4};
   return AF_INET6 if $self->{inet6};
   return AF_UNSPEC;
}

sub _pkg_for_command
{
   my $self = shift;
   my ( $cmd ) = @_;

   my $class = ref $self || $self;

   my $base = $class eq __PACKAGE__ ? "App::MatrixTool::Command" : $class;

   # Allow hyphens in command names
   $cmd =~ s/-/_/g;

   my $pkg = "${base}::${cmd}";
   use_package_optimistically( $pkg );
}

sub run
{
   my $self = shift;
   my @args = @_;

   my %global_opts;
   $opt_parser->getoptionsfromarray( \@args,
      'inet4|4' => \$global_opts{inet4},
      'inet6|6' => \$global_opts{inet6},
      'print-request'  => \$global_opts{print_request},
      'print-response' => \$global_opts{print_response},
   ) or return 1;

   my $cmd = @args ? shift @args : "help";

   my $pkg = $self->_pkg_for_command( $cmd );
   $pkg->can( "new" ) or
      return $self->error( "No such command '$cmd'" );

   my $runner = $pkg->new( %global_opts );

   $self->run_command_in_runner( $runner, @args );
}

sub run_command_in_runner
{
   my $self = shift;
   my ( $runner, @args ) = @_;

   my @argvalues;

   if( $runner->can( "OPTIONS" ) ) {
      my %optvalues;

      $opt_parser->getoptionsfromarray( \@args,
         map { $_->getopt => \$optvalues{ $_->name } } $runner->OPTSPECS
      ) or exit 1;

      push @argvalues, \%optvalues;
   }

   my @argspecs = $runner->ARGSPECS;
   while( @argspecs ) {
      my $spec = shift @argspecs;

      if( !@args ) {
         last if $spec->optional;

         return $self->error( "Required argument '${\ $spec->print_name }' missing" );
      }

      if( $spec->eatall ) {
         push @argvalues, @args;
         @args = ();
      }
      else {
         push @argvalues, shift @args;
      }
   }
   @args and return $self->error( "Found extra arguments" );

   my $ret = $runner->run( @argvalues );
   $ret = $ret->get if blessed $ret and $ret->isa( "Future" );
   $ret //= 0;

   return $ret;
}

sub output