File Coverage

blib/lib/GraphQL/Client/CLI.pm

Criterion	Covered	Total	%
statement	75	201	37.3
branch	28	118	23.7
condition	4	40	10.0
subroutine	13	18	72.2
pod	2	2	100.0
total	122	379	32.1

package GraphQL::Client::CLI;
# ABSTRACT: Implementation of the graphql CLI program

use warnings;
use strict;

use Encode qw(decode);
use Getopt::Long 2.39 qw(GetOptionsFromArray);
use GraphQL::Client;
use JSON::MaybeXS;
use Text::ParseWords;
use namespace::clean;

our $VERSION = '0.603'; # VERSION

my $JSON = JSON::MaybeXS->new(canonical => 1);

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)
        binmode(STDIN, 'encoding(UTF-8)');
        $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;
    }

    binmode(STDOUT, 'encoding(UTF-8)');
    _print_data($data, $format);

    exit($unpack && $err ? 1 : 0);
}

sub _get_options {
    my $self = shift;
    my @args = @_;

    unshift @args, shellwords($ENV{GRAPHQL_CLIENT_OPTIONS} || '');

    # assume UTF-8 args if non-ASCII
    @args = map { decode('UTF-8', $_) } @args if grep { /\P{ASCII}/ } @args;

    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->decode($options{variables}) };
        die "The --variables JSON does not parse.\n" if $@;
    }

    return \%options;
}

sub _stringify {
    my ($item) = @_;
    if (ref($item) eq 'ARRAY') {
        my $first = @$item && $item->[0];
        return join(',', @$item) if !ref($first);
        return join(',', map { $JSON->encode($_) } @$item);
    }
    return $JSON->encode($item) if ref($item) eq 'HASH';
    return $item;
}

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);
        $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 { [map { _stringify($_) } @{$_}{@columns}] } @$val
                    ];
                }
                elsif ($first) {
                    @columns = keys %$unpacked;
                    $rows = [map { [map { _stringify($_) } $_] } @$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 <
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__