Dogcows Code - chaz/graphql-client/blob - lib/GraphQL/Client/CLI.pm

   1 package GraphQL::Client::CLI;
   2 # ABSTRACT: Implementation of the graphql CLI program
   3
   4 use warnings;
   5 use strict;
   6
   7 use Encode qw(decode);
   8 use Getopt::Long 2.39 qw(GetOptionsFromArray);
   9 use GraphQL::Client;
  10 use JSON::MaybeXS;
  11 use Text::ParseWords;
  12 use namespace::clean;
  13
  14 our $VERSION = '999.999'; # VERSION
  15
  16 my $JSON = JSON::MaybeXS->new(canonical => 1);
  17
  18 sub _croak { require Carp; goto &Carp::croak }
  19
  20 sub new {
  21     my $class = shift;
  22     bless {}, $class;
  23 }
  24
  25 sub main {
  26     my $self = shift;
  27     $self = $self->new if !ref $self;
  28
  29     my $options = eval { $self->_get_options(@_) };
  30     if (my $err = $@) {
  31         print STDERR $err;
  32         _pod2usage(2);
  33     }
  34
  35     if ($options->{version}) {
  36         print "graphql $VERSION\n";
  37         exit 0;
  38     }
  39     if ($options->{help}) {
  40         _pod2usage(-exitval => 0, -verbose => 99, -sections => [qw(NAME SYNOPSIS OPTIONS)]);
  41     }
  42     if ($options->{manual}) {
  43         _pod2usage(-exitval => 0, -verbose => 2);
  44     }
  45
  46     my $url = $options->{url};
  47     if (!$url) {
  48         print STDERR "The <URL> or --url option argument is required.\n";
  49         _pod2usage(2);
  50     }
  51
  52     my $variables = $options->{variables};
  53     my $query = $options->{query};
  54     my $operation_name = $options->{operation_name};
  55     my $unpack = $options->{unpack};
  56     my $outfile = $options->{outfile};
  57     my $format = $options->{format};
  58     my $transport = $options->{transport};
  59
  60     my $client = GraphQL::Client->new(url => $url);
  61
  62     eval { $client->transport };
  63     if (my $err = $@) {
  64         warn $err if $ENV{GRAPHQL_CLIENT_DEBUG};
  65         print STDERR "Could not construct a transport for URL: $url\n";
  66         print STDERR "Is this URL correct?\n";
  67         _pod2usage(2);
  68     }
  69
  70     if ($query eq '-') {
  71         print STDERR "Interactive mode engaged! Waiting for a query on <STDIN>...\n"
  72             if -t STDIN; ## no critic (InputOutput::ProhibitInteractiveTest)
  73         binmode(STDIN, 'encoding(UTF-8)');
  74         $query = do { local $/; <STDIN> };
  75     }
  76
  77     my $resp = $client->execute($query, $variables, $operation_name, $transport);
  78     my $err  = $resp->{errors};
  79     $unpack = 0 if $err;
  80     my $data = $unpack ? $resp->{data} : $resp;
  81
  82     if ($outfile) {
  83         open(my $out, '>', $outfile) or die "Open $outfile failed: $!";
  84         *STDOUT = $out;
  85     }
  86
  87     binmode(STDOUT, 'encoding(UTF-8)');
  88     _print_data($data, $format);
  89
  90     exit($unpack && $err ? 1 : 0);
  91 }
  92
  93 sub _get_options {
  94     my $self = shift;
  95     my @args = @_;
  96
  97     unshift @args, shellwords($ENV{GRAPHQL_CLIENT_OPTIONS} || '');
  98
  99     # assume UTF-8 args if non-ASCII
 100     @args = map { decode('UTF-8', $_) } @args if grep { /\P{ASCII}/ } @args;
 101
 102     my %options = (
 103         format  => 'json:pretty',
 104         unpack  => 0,
 105     );
 106
 107     GetOptionsFromArray(\@args,
 108         'version'               => \$options{version},
 109         'help|h|?'              => \$options{help},
 110         'manual|man'            => \$options{manual},
 111         'url|u=s'               => \$options{url},
 112         'query|mutation=s'      => \$options{query},
 113         'variables|vars|V=s'    => \$options{variables},
 114         'variable|var|d=s%'     => \$options{variables},
 115         'operation-name|n=s'    => \$options{operation_name},
 116         'transport|t=s%'        => \$options{transport},
 117         'format|f=s'            => \$options{format},
 118         'unpack!'               => \$options{unpack},
 119         'output|o=s'            => \$options{outfile},
 120     ) or _pod2usage(2);
 121
 122     $options{url}   = shift @args if !$options{url};
 123     $options{query} = shift @args if !$options{query};
 124
 125     $options{query} ||= '-';
 126
 127     my $transport = eval { _expand_vars($options{transport}) };
 128     die "Two or more --transport keys are incompatible.\n" if $@;
 129
 130     if (ref $options{variables}) {
 131         $options{variables} = eval { _expand_vars($options{variables}) };
 132         die "Two or more --variable keys are incompatible.\n" if $@;
 133     }
 134     elsif ($options{variables}) {
 135         $options{variables} = eval { $JSON->decode($options{variables}) };
 136         die "The --variables JSON does not parse.\n" if $@;
 137     }
 138
 139     return \%options;
 140 }
 141
 142 sub _stringify {
 143     my ($item) = @_;
 144     if (ref($item) eq 'ARRAY') {
 145         my $first = @$item && $item->[0];
 146         return join(',', @$item) if !ref($first);
 147         return join(',', map { $JSON->encode($_) } @$item);
 148     }
 149     return $JSON->encode($item) if ref($item) eq 'HASH';
 150     return $item;
 151 }
 152
 153 sub _print_data {
 154     my ($data, $format) = @_;
 155     $format = lc($format || 'json:pretty');
 156     if ($format eq 'json' || $format eq 'json:pretty') {
 157         my %opts = (allow_nonref => 1, canonical => 1);
 158         $opts{pretty} = 1 if $format eq 'json:pretty';
 159         print JSON::MaybeXS->new(%opts)->encode($data);
 160     }
 161     elsif ($format eq 'yaml') {
 162         eval { require YAML } or die "Missing dependency: YAML\n";
 163         print YAML::Dump($data);
 164     }
 165     elsif ($format eq 'csv' || $format eq 'tsv' || $format eq 'table') {
 166         my $sep = $format eq 'tsv' ? "\t" : ',';
 167
 168         my $unpacked = $data;
 169         # $unpacked = $data->{data} if !$unpack && !$err;
 170         $unpacked = $data->{data} if $data && $data->{data};
 171
 172         # check the response to see if it can be formatted
 173         my @columns;
 174         my $rows = [];
 175         if (keys %$unpacked == 1) {
 176             my ($val) = values %$unpacked;
 177             if (ref $val eq 'ARRAY') {
 178                 my $first = $val->[0];
 179                 if ($first && ref $first eq 'HASH') {
 180                     @columns = sort keys %$first;
 181                     $rows = [
 182                         map { [map { _stringify($_) } @{$_}{@columns}] } @$val
 183                     ];
 184                 }
 185                 elsif ($first) {
 186                     @columns = keys %$unpacked;
 187                     $rows = [map { [map { _stringify($_) } $_] } @$val];
 188                 }
 189             }
 190         }
 191
 192         if (@columns) {
 193             if ($format eq 'table') {
 194                 eval { require Text::Table::Any } or die "Missing dependency: Text::Table::Any\n";
 195                 my $table = Text::Table::Any::table(
 196                     header_row  => 1,
 197                     rows        => [[@columns], @$rows],
 198                     backend     => $ENV{PERL_TEXT_TABLE},
 199                 );
 200                 print $table;
 201             }
 202             else {
 203                 eval { require Text::CSV } or die "Missing dependency: Text::CSV\n";
 204                 my $csv = Text::CSV->new({binary => 1, sep => $sep, eol => $/});
 205                 $csv->print(*STDOUT, [@columns]);
 206                 for my $row (@$rows) {
 207                     $csv->print(*STDOUT, $row);
 208                 }
 209             }
 210         }
 211         else {
 212             _print_data($data);
 213             print STDERR sprintf("Error: Response could not be formatted as %s.\n", uc($format));
 214             exit 3;
 215         }
 216     }
 217     elsif ($format eq 'perl') {
 218         eval { require Data::Dumper } or die "Missing dependency: Data::Dumper\n";
 219         print Data::Dumper::Dumper($data);
 220     }
 221     else {
 222         print STDERR "Error: Format not supported: $format\n";
 223         _print_data($data);
 224         exit 3;
 225     }
 226 }
 227
 228 sub _parse_path {
 229     my $path = shift;
 230
 231     my @path;
 232
 233     my @segments = map { split(/\./, $_) } split(/(\[[^\.\]]+\])\.?/, $path);
 234     for my $segment (@segments) {
 235         if ($segment =~ /\[([^\.\]]+)\]/) {
 236             $path[-1]{type} = 'ARRAY' if @path;
 237             push @path, {
 238                 name  => $1,
 239                 index => 1,
 240             };
 241         }
 242         else {
 243             $path[-1]{type} = 'HASH' if @path;
 244             push @path, {
 245                 name => $segment,
 246             };
 247         }
 248     }
 249
 250     return \@path;
 251 }
 252
 253 sub _expand_vars {
 254     my $vars = shift;
 255
 256     my $root = {};
 257
 258     while (my ($key, $value) = each %$vars) {
 259         my $parsed_path = _parse_path($key);
 260
 261         my $curr = $root;
 262         for my $segment (@$parsed_path) {
 263             my $name = $segment->{name};
 264             my $type = $segment->{type} || '';
 265             my $next = $type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : $value;
 266             if (ref $curr eq 'HASH') {
 267                 _croak 'Conflicting keys' if $segment->{index};
 268                 if (defined $curr->{$name}) {
 269                     _croak 'Conflicting keys' if $type ne ref $curr->{$name};
 270                     $next = $curr->{$name};
 271                 }
 272                 else {
 273                     $curr->{$name} = $next;
 274                 }
 275             }
 276             elsif (ref $curr eq 'ARRAY') {
 277                 _croak 'Conflicting keys' if !$segment->{index};
 278                 if (defined $curr->[$name]) {
 279                     _croak 'Conflicting keys' if $type ne ref $curr->[$name];
 280                     $next = $curr->[$name];
 281                 }
 282                 else {
 283                     $curr->[$name] = $next;
 284                 }
 285             }
 286             else {
 287                 _croak 'Conflicting keys';
 288             }
 289             $curr = $next;
 290         }
 291     }
 292
 293     return $root;
 294 }
 295
 296 sub _pod2usage {
 297     eval { require Pod::Usage };
 298     if ($@) {
 299         my $ref  = $VERSION eq '999.999' ? 'master' : "v$VERSION";
 300         my $exit = (@_ == 1 && $_[0] =~ /^\d+$/ && $_[0]) //
 301                    (@_ % 2 == 0 && {@_}->{'-exitval'})    // 2;
 302         print STDERR <<END;
 303 Online documentation is available at:
 304
 305   https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
 306
 307 Tip: To enable inline documentation, install the Pod::Usage module.
 308
 309 END
 310         exit $exit;
 311     }
 312     else {
 313         goto &Pod::Usage::pod2usage;
 314     }
 315 }
 316
 317 1;
 318 __END__
 319
 320 =head1 DESCRIPTION
 321
 322 This is the actual implementation of L<graphql>.
 323
 324 The interface is B<EXPERIMENTAL>. Don't rely on it.
 325
 326 =method new
 327
 328 Construct a new CLI.
 329
 330 =method main
 331
 332 Run the script.