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;
  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 _print_data {
 135     my ($data, $format) = @_;
 136     $format = lc($format || 'json:pretty');
 137     if ($format eq 'json' || $format eq 'json:pretty') {
 138         my %opts = (allow_nonref => 1, canonical => 1, utf8 => 1);
 139         $opts{pretty} = 1 if $format eq 'json:pretty';
 140         print JSON::MaybeXS->new(%opts)->encode($data);
 141     }
 142     elsif ($format eq 'yaml') {
 143         eval { require YAML } or die "Missing dependency: YAML\n";
 144         print YAML::Dump($data);
 145     }
 146     elsif ($format eq 'csv' || $format eq 'tsv' || $format eq 'table') {
 147         my $sep = $format eq 'tsv' ? "\t" : ',';
 148
 149         my $unpacked = $data;
 150         # $unpacked = $data->{data} if !$unpack && !$err;
 151         $unpacked = $data->{data} if $data && $data->{data};
 152
 153         # check the response to see if it can be formatted
 154         my @columns;
 155         my $rows = [];
 156         if (keys %$unpacked == 1) {
 157             my ($val) = values %$unpacked;
 158             if (ref $val eq 'ARRAY') {
 159                 my $first = $val->[0];
 160                 if ($first && ref $first eq 'HASH') {
 161                     @columns = sort keys %$first;
 162                     $rows = [
 163                         map { [@{$_}{@columns}] } @$val
 164                     ];
 165                 }
 166                 elsif ($first) {
 167                     @columns = keys %$unpacked;
 168                     $rows = [map { [$_] } @$val];
 169                 }
 170             }
 171         }
 172
 173         if (@columns) {
 174             if ($format eq 'table') {
 175                 eval { require Text::Table::Any } or die "Missing dependency: Text::Table::Any\n";
 176                 my $table = Text::Table::Any::table(
 177                     header_row  => 1,
 178                     rows        => [[@columns], @$rows],
 179                     backend     => $ENV{PERL_TEXT_TABLE},
 180                 );
 181                 print $table;
 182             }
 183             else {
 184                 eval { require Text::CSV } or die "Missing dependency: Text::CSV\n";
 185                 my $csv = Text::CSV->new({binary => 1, sep => $sep, eol => $/});
 186                 $csv->print(*STDOUT, [@columns]);
 187                 for my $row (@$rows) {
 188                     $csv->print(*STDOUT, $row);
 189                 }
 190             }
 191         }
 192         else {
 193             _print_data($data);
 194             print STDERR sprintf("Error: Response could not be formatted as %s.\n", uc($format));
 195             exit 3;
 196         }
 197     }
 198     elsif ($format eq 'perl') {
 199         eval { require Data::Dumper } or die "Missing dependency: Data::Dumper\n";
 200         print Data::Dumper::Dumper($data);
 201     }
 202     else {
 203         print STDERR "Error: Format not supported: $format\n";
 204         _print_data($data);
 205         exit 3;
 206     }
 207 }
 208
 209 sub _parse_path {
 210     my $path = shift;
 211
 212     my @path;
 213
 214     my @segments = map { split(/\./, $_) } split(/(\[[^\.\]]+\])\.?/, $path);
 215     for my $segment (@segments) {
 216         if ($segment =~ /\[([^\.\]]+)\]/) {
 217             $path[-1]{type} = 'ARRAY' if @path;
 218             push @path, {
 219                 name  => $1,
 220                 index => 1,
 221             };
 222         }
 223         else {
 224             $path[-1]{type} = 'HASH' if @path;
 225             push @path, {
 226                 name => $segment,
 227             };
 228         }
 229     }
 230
 231     return \@path;
 232 }
 233
 234 sub _expand_vars {
 235     my $vars = shift;
 236
 237     my $root = {};
 238
 239     while (my ($key, $value) = each %$vars) {
 240         my $parsed_path = _parse_path($key);
 241
 242         my $curr = $root;
 243         for my $segment (@$parsed_path) {
 244             my $name = $segment->{name};
 245             my $type = $segment->{type} || '';
 246             my $next = $type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : $value;
 247             if (ref $curr eq 'HASH') {
 248                 _croak 'Conflicting keys' if $segment->{index};
 249                 if (defined $curr->{$name}) {
 250                     _croak 'Conflicting keys' if $type ne ref $curr->{$name};
 251                     $next = $curr->{$name};
 252                 }
 253                 else {
 254                     $curr->{$name} = $next;
 255                 }
 256             }
 257             elsif (ref $curr eq 'ARRAY') {
 258                 _croak 'Conflicting keys' if !$segment->{index};
 259                 if (defined $curr->[$name]) {
 260                     _croak 'Conflicting keys' if $type ne ref $curr->[$name];
 261                     $next = $curr->[$name];
 262                 }
 263                 else {
 264                     $curr->[$name] = $next;
 265                 }
 266             }
 267             else {
 268                 _croak 'Conflicting keys';
 269             }
 270             $curr = $next;
 271         }
 272     }
 273
 274     return $root;
 275 }
 276
 277 sub _pod2usage {
 278     eval { require Pod::Usage };
 279     if ($@) {
 280         my $ref  = $VERSION eq '999.999' ? 'master' : "v$VERSION";
 281         my $exit = (@_ == 1 && $_[0] =~ /^\d+$/ && $_[0]) //
 282                    (@_ % 2 == 0 && {@_}->{'-exitval'})    // 2;
 283         print STDERR <<END;
 284 Online documentation is available at:
 285
 286   https://github.com/chazmcgarvey/graphql-client/blob/$ref/README.md
 287
 288 Tip: To enable inline documentation, install the Pod::Usage module.
 289
 290 END
 291         exit $exit;
 292     }
 293     else {
 294         goto &Pod::Usage::pod2usage;
 295     }
 296 }
 297
 298 1;
 299 __END__
 300
 301 =head1 DESCRIPTION
 302
 303 This is the actual implementation of L<graphql>.
 304
 305 The interface is B<EXPERIMENTAL>. Don't rely on it.
 306
 307 =method new
 308
 309 Construct a new CLI.
 310
 311 =method main
 312
 313 Run the script.