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