From: Charles McGarvey Date: Wed, 18 Mar 2020 00:18:05 +0000 (-0600) Subject: fix CLI option processing X-Git-Tag: v0.602~2 X-Git-Url: https://git.dogcows.com/gitweb?a=commitdiff_plain;h=1a966ff0db27d934fce36e2bd43ea6aace0a7555;p=chaz%2Fgraphql-client fix CLI option processing --- diff --git a/bin/graphql b/bin/graphql index 82025c4..724f6f3 100755 --- a/bin/graphql +++ b/bin/graphql @@ -1,220 +1,6 @@ #! perl -# PODNAME: graphql # ABSTRACT: Command-line GraphQL client - -# FATPACK - Do not remove this line. - -use warnings; -use strict; - -use Getopt::Long; -use GraphQL::Client; -use JSON::MaybeXS; - -our $VERSION = '999.999'; # VERSION - -my $version; -my $help; -my $manual; -my $url; -my $transport = {}; -my $query = '-'; -my $variables = {}; -my $operation_name; -my $format = 'json:pretty'; -my $unpack = 0; -my $outfile; -GetOptions( - 'version' => \$version, - 'help|h|?' => \$help, - 'manual|man' => \$manual, - 'url|u=s' => \$url, - 'query|mutation=s' => \$query, - 'variables|vars|V=s' => \$variables, - 'variable|var|d=s%' => \$variables, - 'operation-name|n=s' => \$operation_name, - 'transport|t=s%' => \$transport, - 'format|f=s' => \$format, - 'unpack!' => \$unpack, - 'output|o=s' => \$outfile, -) or pod2usage(2); - -if ($version) { - print "graphql $VERSION\n"; - exit 0; -} -if ($help) { - pod2usage(-exitval => 0, -verbose => 99, -sections => [qw(NAME SYNOPSIS OPTIONS)]); -} -if ($manual) { - pod2usage(-exitval => 0, -verbose => 2); -} - -$url = shift if !$url; -$query = shift if !$query || $query eq '-'; - -if (!$url) { - print STDERR "The or --url option argument is required.\n"; - pod2usage(2); -} - -$transport = expand_vars($transport); - -if (ref $variables) { - $variables = expand_vars($variables); -} -else { - $variables = JSON::MaybeXS->new->decode($variables); -} - -my $client = GraphQL::Client->new(url => $url); - -eval { $client->transport }; -if (my $err = $@) { - warn $err if $ENV{GRAPHQL_CLIENT_DEBUG}; - print STDERR "Could not construct a transport for URL: $url\n"; - print STDERR "Is this URL correct?\n"; - pod2usage(2); -} - -if (!$query || $query eq '-') { - print STDERR "Interactive mode engaged! Waiting for a query on ...\n" - if -t STDIN; ## no critic (InputOutput::ProhibitInteractiveTest) - $query = do { local $/; <> }; -} - -my $resp = $client->execute($query, $variables, $operation_name, $transport); -my $err = $resp->{errors}; -$unpack = 0 if $err; -my $data = $unpack ? $resp->{data} : $resp; - -if ($outfile) { - open(my $out, '>', $outfile) or die "Open $outfile failed: $!"; - *STDOUT = $out; -} - -print_data($data, $format); - -exit($unpack && $err ? 1 : 0); - -sub print_data { - my ($data, $format) = @_; - $format = lc($format || 'json:pretty'); - if ($format eq 'json' || $format eq 'json:pretty') { - my %opts = (canonical => 1, utf8 => 1); - $opts{pretty} = 1 if $format eq 'json:pretty'; - print JSON::MaybeXS->new(%opts)->encode($data); - } - elsif ($format eq 'yaml') { - eval { require YAML } or die "Missing dependency: YAML\n"; - print YAML::Dump($data); - } - elsif ($format eq 'csv' || $format eq 'tsv' || $format eq 'table') { - my $sep = $format eq 'tsv' ? "\t" : ','; - - my $unpacked = $data; - $unpacked = $data->{data} if !$unpack && !$err; - - # check the response to see if it can be formatted - my @columns; - my $rows = []; - if (keys %$unpacked == 1) { - my ($val) = values %$unpacked; - if (ref $val eq 'ARRAY') { - my $first = $val->[0]; - if ($first && ref $first eq 'HASH') { - @columns = sort keys %$first; - $rows = [ - map { [@{$_}{@columns}] } @$val - ]; - } - elsif ($first) { - @columns = keys %$unpacked; - $rows = [map { [$_] } @$val]; - } - } - } - - if (@columns) { - if ($format eq 'table') { - eval { require Text::Table::Any } or die "Missing dependency: Text::Table::Any\n"; - my $table = Text::Table::Any::table( - header_row => 1, - rows => [[@columns], @$rows], - backend => $ENV{PERL_TEXT_TABLE}, - ); - print $table; - } - else { - eval { require Text::CSV } or die "Missing dependency: Text::CSV\n"; - my $csv = Text::CSV->new({binary => 1, sep => $sep, eol => $/}); - $csv->print(*STDOUT, [@columns]); - for my $row (@$rows) { - $csv->print(*STDOUT, $row); - } - } - } - else { - print_data($data); - print STDERR sprintf("Error: Response could not be formatted as %s.\n", uc($format)); - exit 3; - } - } - elsif ($format eq 'perl') { - eval { require Data::Dumper } or die "Missing dependency: Data::Dumper\n"; - print Data::Dumper::Dumper($data); - } - else { - print STDERR "Error: Format not supported: $format\n"; - print_data($data); - exit 3; - } -} - -sub expand_vars { - my $vars = shift; - - my %out; - while (my ($key, $value) = each %$vars) { - my $var = $value; - my @segments = split(/\./, $key); - for my $segment (reverse @segments) { - my $saved = $var; - if ($segment =~ /^(\d+)$/) { - $var = []; - $var->[$segment] = $saved; - } - else { - $var = {}; - $var->{$segment} = $saved; - } - } - %out = (%out, %$var); - } - - return \%out; -} - -sub pod2usage { - eval { require Pod::Usage }; - if ($@) { - my $ref = $VERSION eq '999.999' ? 'master' : "v$VERSION"; - my $exit = (@_ == 1 && $_[0] =~ /^\d+$/ && $_[0]) // - (@_ % 2 == 0 && {@_}->{'-exitval'}) // 2; - print STDERR <, C<-V> =head2 C<--variable KEY=VALUE> -An alternative way to provide variables. Repeat this option to provide multiple variables. +An alternative way to provide variables one at a time. This option can be repeated to provide +multiple variables. If used in combination with L, this option is silently ignored. @@ -439,6 +226,7 @@ Some environment variables affect the way C behaves: =for :list * C - Set to 1 to print diagnostic messages to STDERR. * C - Set the HTTP user agent string. +* C - Set the default set of options. * C - Set table format backend; see L. =head1 EXIT STATUS @@ -451,3 +239,20 @@ Here is a consolidated summary of what exit statuses mean: * C<2> - Option usage is wrong * C<3> - Could not format the response as requested +=head1 SEE ALSO + +=for :list +* L - Programmatic interface + +=cut + +# FATPACK - Do not remove this line. + +use warnings; +use strict; + +use GraphQL::Client::CLI; + +our $VERSION = '999.999'; # VERSION + +GraphQL::Client::CLI->main(@ARGV); diff --git a/lib/GraphQL/Client/CLI.pm b/lib/GraphQL/Client/CLI.pm new file mode 100644 index 0000000..7c1c545 --- /dev/null +++ b/lib/GraphQL/Client/CLI.pm @@ -0,0 +1,313 @@ +package GraphQL::Client::CLI; +# ABSTRACT: Implementation of the graphql CLI program + +use warnings; +use strict; + +use Text::ParseWords; +use Getopt::Long 2.39 qw(GetOptionsFromArray); +use GraphQL::Client; +use JSON::MaybeXS; +use namespace::clean; + +our $VERSION = '999.999'; # VERSION + +sub _croak { require Carp; goto &Carp::croak } + +sub new { + my $class = shift; + bless {}, $class; +} + +sub main { + my $self = shift; + $self = $self->new if !ref $self; + + my $options = eval { $self->_get_options(@_) }; + if (my $err = $@) { + print STDERR $err; + _pod2usage(2); + } + + if ($options->{version}) { + print "graphql $VERSION\n"; + exit 0; + } + if ($options->{help}) { + _pod2usage(-exitval => 0, -verbose => 99, -sections => [qw(NAME SYNOPSIS OPTIONS)]); + } + if ($options->{manual}) { + _pod2usage(-exitval => 0, -verbose => 2); + } + + my $url = $options->{url}; + if (!$url) { + print STDERR "The or --url option argument is required.\n"; + _pod2usage(2); + } + + my $variables = $options->{variables}; + my $query = $options->{query}; + my $operation_name = $options->{operation_name}; + my $unpack = $options->{unpack}; + my $outfile = $options->{outfile}; + my $format = $options->{format}; + my $transport = $options->{transport}; + + my $client = GraphQL::Client->new(url => $url); + + eval { $client->transport }; + if (my $err = $@) { + warn $err if $ENV{GRAPHQL_CLIENT_DEBUG}; + print STDERR "Could not construct a transport for URL: $url\n"; + print STDERR "Is this URL correct?\n"; + _pod2usage(2); + } + + if ($query eq '-') { + print STDERR "Interactive mode engaged! Waiting for a query on ...\n" + if -t STDIN; ## no critic (InputOutput::ProhibitInteractiveTest) + $query = do { local $/; }; + } + + my $resp = $client->execute($query, $variables, $operation_name, $transport); + my $err = $resp->{errors}; + $unpack = 0 if $err; + my $data = $unpack ? $resp->{data} : $resp; + + if ($outfile) { + open(my $out, '>', $outfile) or die "Open $outfile failed: $!"; + *STDOUT = $out; + } + + _print_data($data, $format); + + exit($unpack && $err ? 1 : 0); +} + +sub _get_options { + my $self = shift; + my @args = @_; + + unshift @args, shellwords($ENV{GRAPHQL_CLIENT_OPTIONS} || ''); + + my %options = ( + format => 'json:pretty', + unpack => 0, + ); + + GetOptionsFromArray(\@args, + 'version' => \$options{version}, + 'help|h|?' => \$options{help}, + 'manual|man' => \$options{manual}, + 'url|u=s' => \$options{url}, + 'query|mutation=s' => \$options{query}, + 'variables|vars|V=s' => \$options{variables}, + 'variable|var|d=s%' => \$options{variables}, + 'operation-name|n=s' => \$options{operation_name}, + 'transport|t=s%' => \$options{transport}, + 'format|f=s' => \$options{format}, + 'unpack!' => \$options{unpack}, + 'output|o=s' => \$options{outfile}, + ) or _pod2usage(2); + + $options{url} = shift @args if !$options{url}; + $options{query} = shift @args if !$options{query}; + + $options{query} ||= '-'; + + my $transport = eval { _expand_vars($options{transport}) }; + die "Two or more --transport keys are incompatible.\n" if $@; + + if (ref $options{variables}) { + $options{variables} = eval { _expand_vars($options{variables}) }; + die "Two or more --variable keys are incompatible.\n" if $@; + } + elsif ($options{variables}) { + $options{variables} = eval { JSON::MaybeXS->new->decode($options{variables}) }; + die "The --variables JSON does not parse.\n" if $@; + } + + return \%options; +} + +sub _print_data { + my ($data, $format) = @_; + $format = lc($format || 'json:pretty'); + if ($format eq 'json' || $format eq 'json:pretty') { + my %opts = (allow_nonref => 1, canonical => 1, utf8 => 1); + $opts{pretty} = 1 if $format eq 'json:pretty'; + print JSON::MaybeXS->new(%opts)->encode($data); + } + elsif ($format eq 'yaml') { + eval { require YAML } or die "Missing dependency: YAML\n"; + print YAML::Dump($data); + } + elsif ($format eq 'csv' || $format eq 'tsv' || $format eq 'table') { + my $sep = $format eq 'tsv' ? "\t" : ','; + + my $unpacked = $data; + # $unpacked = $data->{data} if !$unpack && !$err; + $unpacked = $data->{data} if $data && $data->{data}; + + # check the response to see if it can be formatted + my @columns; + my $rows = []; + if (keys %$unpacked == 1) { + my ($val) = values %$unpacked; + if (ref $val eq 'ARRAY') { + my $first = $val->[0]; + if ($first && ref $first eq 'HASH') { + @columns = sort keys %$first; + $rows = [ + map { [@{$_}{@columns}] } @$val + ]; + } + elsif ($first) { + @columns = keys %$unpacked; + $rows = [map { [$_] } @$val]; + } + } + } + + if (@columns) { + if ($format eq 'table') { + eval { require Text::Table::Any } or die "Missing dependency: Text::Table::Any\n"; + my $table = Text::Table::Any::table( + header_row => 1, + rows => [[@columns], @$rows], + backend => $ENV{PERL_TEXT_TABLE}, + ); + print $table; + } + else { + eval { require Text::CSV } or die "Missing dependency: Text::CSV\n"; + my $csv = Text::CSV->new({binary => 1, sep => $sep, eol => $/}); + $csv->print(*STDOUT, [@columns]); + for my $row (@$rows) { + $csv->print(*STDOUT, $row); + } + } + } + else { + _print_data($data); + print STDERR sprintf("Error: Response could not be formatted as %s.\n", uc($format)); + exit 3; + } + } + elsif ($format eq 'perl') { + eval { require Data::Dumper } or die "Missing dependency: Data::Dumper\n"; + print Data::Dumper::Dumper($data); + } + else { + print STDERR "Error: Format not supported: $format\n"; + _print_data($data); + exit 3; + } +} + +sub _parse_path { + my $path = shift; + + my @path; + + my @segments = map { split(/\./, $_) } split(/(\[[^\.\]]+\])\.?/, $path); + for my $segment (@segments) { + if ($segment =~ /\[([^\.\]]+)\]/) { + $path[-1]{type} = 'ARRAY' if @path; + push @path, { + name => $1, + index => 1, + }; + } + else { + $path[-1]{type} = 'HASH' if @path; + push @path, { + name => $segment, + }; + } + } + + return \@path; +} + +sub _expand_vars { + my $vars = shift; + + my $root = {}; + + while (my ($key, $value) = each %$vars) { + my $parsed_path = _parse_path($key); + + my $curr = $root; + for my $segment (@$parsed_path) { + my $name = $segment->{name}; + my $type = $segment->{type} || ''; + my $next = $type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : $value; + if (ref $curr eq 'HASH') { + _croak 'Conflicting keys' if $segment->{index}; + if (defined $curr->{$name}) { + _croak 'Conflicting keys' if $type ne ref $curr->{$name}; + $next = $curr->{$name}; + } + else { + $curr->{$name} = $next; + } + } + elsif (ref $curr eq 'ARRAY') { + _croak 'Conflicting keys' if !$segment->{index}; + if (defined $curr->[$name]) { + _croak 'Conflicting keys' if $type ne ref $curr->[$name]; + $next = $curr->[$name]; + } + else { + $curr->[$name] = $next; + } + } + else { + _croak 'Conflicting keys'; + } + $curr = $next; + } + } + + return $root; +} + +sub _pod2usage { + eval { require Pod::Usage }; + if ($@) { + my $ref = $VERSION eq '999.999' ? 'master' : "v$VERSION"; + my $exit = (@_ == 1 && $_[0] =~ /^\d+$/ && $_[0]) // + (@_ % 2 == 0 && {@_}->{'-exitval'}) // 2; + print STDERR <. + +The interface is B. Don't rely on it. + +=method new + +Construct a new CLI. + +=method main + +Run the script. diff --git a/lib/GraphQL/Client/http.pm b/lib/GraphQL/Client/http.pm index 796e380..77a089f 100644 --- a/lib/GraphQL/Client/http.pm +++ b/lib/GraphQL/Client/http.pm @@ -90,6 +90,8 @@ sub _handle_error { my $reason = $resp->{reason} // ''; my $message = "HTTP transport returned $resp->{status} ($reason): $content"; + chomp $message; + return { error => $message, response => $data, @@ -201,8 +203,8 @@ See L. Get a response from the GraphQL server. -The C<%data> structure must have a C key whose value is the query or mutation string. It may -optionally have a C hashref and an C string. +The C<%request> structure must have a C key whose value is the query or mutation string. It +may optionally have a C hashref and an C string. The C<%options> structure is optional and may contain options passed through to the user agent. The only useful options are C (which should have a hashref value) and C and C to @@ -216,7 +218,7 @@ such a hashref: data => {...}, errors => [...], }, - error => 'Something happened', # may be ommitted if no error occurred + error => 'Something happened', # omitted if no error occurred details => { # optional information which may aide troubleshooting }, } diff --git a/t/cli.t b/t/cli.t new file mode 100755 index 0000000..2ae980e --- /dev/null +++ b/t/cli.t @@ -0,0 +1,81 @@ +#!/usr/bin/env perl + +use warnings; +use strict; + +use Test::Exception; +use Test::More; + +use GraphQL::Client::CLI; + +subtest 'get_options' => sub { + my $expected = { + format => 'json:pretty', + help => undef, + manual => undef, + operation_name => undef, + outfile => undef, + query => 'bar', + transport => undef, + unpack => 0, + url => 'foo', + variables => undef, + version => undef, + }; + + my $r = GraphQL::Client::CLI->_get_options(qw{--url foo --query bar}); + is_deeply($r, $expected, '--url and --query set options') or diag explain $r; + + $r = GraphQL::Client::CLI->_get_options(qw{foo --query bar}); + is_deeply($r, $expected, '--url is optional') or diag explain $r; + + $r = GraphQL::Client::CLI->_get_options(qw{foo bar}); + is_deeply($r, $expected, '--query is also optional') or diag explain $r; +}; + +subtest 'expand_vars' => sub { + my $r = GraphQL::Client::CLI::_expand_vars({ + 'foo.bar' => 'baz', + 'foo.qux.muf' => 42, + 'arr1[1].tut' => 'whatever', + 'arr2[1][0].meh'=> 3.1415, + }); + is_deeply($r, { + foo => { + bar => 'baz', + qux => { + muf => 42, + }, + }, + arr1 => [ + undef, + { + tut => 'whatever', + } + ], + arr2 => [ + undef, + [ + { + meh => 3.1415, + }, + ], + ], + }, 'expand all the vars') or diag explain $r; + + throws_ok { + GraphQL::Client::CLI::_expand_vars({ + 'foo[0]' => 'baz', + 'foo.bar' => 'muf', + }); + } qr/^Conflicting keys/, 'throw if conflict between hash and array'; + + throws_ok { + GraphQL::Client::CLI::_expand_vars({ + 'foo' => 'baz', + 'foo.bar' => 'muf', + }); + } qr/^Conflicting keys/, 'throw if conflict between hash and scalar'; +}; + +done_testing; diff --git a/t/client.t b/t/client.t index 1dd0cd4..841bd8c 100755 --- a/t/client.t +++ b/t/client.t @@ -60,7 +60,7 @@ subtest 'request to transport' => sub { $req = ($mock->requests)[-1]; is_deeply($req->[1], { baz => 'qux', - }, 'operation name can be ommitted with transport options'); + }, 'operation name can be omitted with transport options'); }; subtest 'success response' => sub {