#! 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 <URL> 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 <STDIN>...\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 <<END;
-Online documentation is available at:
-
- https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
-
-Tip: To enable inline documentation, install the Pod::Usage module.
-
-END
- exit $exit;
- }
- else {
- goto &Pod::Usage::pod2usage;
- }
-}
+# PODNAME: graphql
=head1 SYNOPSIS
=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</"--variables JSON">, this option is silently ignored.
=for :list
* C<GRAPHQL_CLIENT_DEBUG> - Set to 1 to print diagnostic messages to STDERR.
* C<GRAPHQL_CLIENT_HTTP_USER_AGENT> - Set the HTTP user agent string.
+* C<GRAPHQL_CLIENT_OPTIONS> - Set the default set of options.
* C<PERL_TEXT_TABLE> - Set table format backend; see L</FORMAT>.
=head1 EXIT STATUS
* C<2> - Option usage is wrong
* C<3> - Could not format the response as requested
+=head1 SEE ALSO
+
+=for :list
+* L<GraphQL::Client> - 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);
--- /dev/null
+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 <URL> 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 <STDIN>...\n"
+ if -t STDIN; ## no critic (InputOutput::ProhibitInteractiveTest)
+ $query = do { local $/; <STDIN> };
+ }
+
+ 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 <<END;
+Online documentation is available at:
+
+ https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
+
+Tip: To enable inline documentation, install the Pod::Usage module.
+
+END
+ exit $exit;
+ }
+ else {
+ goto &Pod::Usage::pod2usage;
+ }
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+This is the actual implementation of L<graphql>.
+
+The interface is B<EXPERIMENTAL>. Don't rely on it.
+
+=method new
+
+Construct a new CLI.
+
+=method main
+
+Run the script.
my $reason = $resp->{reason} // '';
my $message = "HTTP transport returned $resp->{status} ($reason): $content";
+ chomp $message;
+
return {
error => $message,
response => $data,
Get a response from the GraphQL server.
-The C<%data> structure must have a C<query> key whose value is the query or mutation string. It may
-optionally have a C<variables> hashref and an C<operationName> string.
+The C<%request> structure must have a C<query> key whose value is the query or mutation string. It
+may optionally have a C<variables> hashref and an C<operationName> string.
The C<%options> structure is optional and may contain options passed through to the user agent. The
only useful options are C<headers> (which should have a hashref value) and C<method> and C<url> to
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
},
}
--- /dev/null
+#!/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;
$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 {
projects / chaz / graphql-client / commitdiff
