File Coverage

blib/lib/App/Nopaste/Service/Gist.pm
Criterion Covered Total %
statement 33 84 39.2
branch 5 28 17.8
condition 2 13 15.3
subroutine 11 15 73.3
pod 3 6 50.0
total 54 146 36.9


line stmt bran cond sub pod time code
1 2     2   93531 use strict;
  2         15  
  2         61  
2 2     2   10 use warnings;
  2         4  
  2         104  
3             package App::Nopaste::Service::Gist;
4             # ABSTRACT: Service provider for GitHub gist - http://gist.github.com/
5              
6             our $VERSION = '1.013';
7              
8 2     2   438 use parent 'App::Nopaste::Service';
  2         311  
  2         11  
9              
10 2     2   121 use LWP::UserAgent;
  2         4  
  2         36  
11 2     2   497 use JSON::MaybeXS;
  2         5794  
  2         119  
12 2     2   490 use Module::Runtime 'use_module';
  2         1771  
  2         15  
13 2     2   960 use Path::Tiny;
  2         11319  
  2         112  
14 2     2   472 use namespace::clean 0.19;
  2         11028  
  2         13  
15              
16 1     1 0 149 sub available { 1 }
17 1     1 0 5 sub forbid_in_default { 0 }
18              
19             sub nopaste {
20 0     0 1 0 my $self = shift;
21 0         0 $self->run(@_);
22             }
23              
24             sub run {
25 0     0 1 0 my ($self, %arg) = @_;
26 0         0 my $ua = LWP::UserAgent->new;
27              
28             my $content = {
29             public => defined $arg{private} ? JSON->false : JSON->true,
30 0 0       0 defined $arg{desc} ? (description => $arg{desc}) : (),
    0          
31             };
32              
33             my $filename = defined $arg{filename}
34 0 0       0 ? path($arg{filename})->basename
35             : 'nopaste';
36              
37             $content->{files} = {
38             $filename => {
39             content => $arg{text}
40             }
41 0         0 };
42              
43 0         0 $content = encode_json($content);
44              
45 0         0 my %auth = $self->_get_auth;
46              
47 0         0 my $url = 'https://api.github.com/gists';
48              
49 0         0 my $res = do {
50 0 0       0 if ($auth{oauth_token}) {
51 0         0 $ua->post(
52             $url,
53             'Authorization' => "token $auth{oauth_token}",
54             Content => $content,
55             Content_Type => 'application/json',
56             );
57             }
58             else {
59 0         0 use_module('HTTP::Request::Common');
60 0         0 my $req = HTTP::Request::Common::POST($url, Content => $content);
61 0         0 $req->authorization_basic(@auth{qw/username password/});
62 0         0 $ua->request($req);
63             }
64             };
65              
66 0         0 return $self->return($res);
67             }
68              
69             sub _get_auth {
70 4     4   10614 my ($self) = @_;
71              
72 4 100 66     25 if (my $oauth_token = $ENV{GITHUB_OAUTH_TOKEN}) {
    100          
73 1         8 return (oauth_token => $oauth_token);
74             }
75             elsif ($ENV{GITHUB_USER} && $ENV{GITHUB_PASSWORD}) {
76             return (
77             username => $ENV{GITHUB_USER},
78             password => $ENV{GITHUB_PASSWORD},
79 1         9 );
80             }
81             else {
82             # this is also done by the fallback mechanism in Config::Identity::GitHub.
83 2         7 my $github_config = path('~', '.github');
84 2 50       138 if (-f $github_config) {
85 0         0 my $content = $github_config->slurp_utf8;
86 0         0 my ($username) = $content =~ m/\blogin (.+)(?:$|#)/m;
87 0         0 my ($password) = $content =~ m/\bpassword (.+)(?:$|#)/m;
88             return (
89 0 0 0     0 username => $username,
90             password => $password,
91             ) if $username and $password;
92             }
93             }
94              
95 2         41 die join("\n",
96             "Export GITHUB_OAUTH_TOKEN first. For example:",
97             " perl -MApp::Nopaste::Service::Gist -e 'App::Nopaste::Service::Gist->create_token'",
98             "",
99             "OR you can export GITHUB_USER and GITHUB_PASSWORD.",
100             "OR you can set 'login' and 'password' in ~/.github.",
101             ) . "\n";
102             }
103              
104             sub create_token {
105 0     0 0   my ($self) = @_;
106              
107 0           local $| = 1;
108 0           print "Username: ";
109 0           chomp(my $username = <>);
110 0           print "Password: ";
111 0           chomp(my $password = <>);
112 0           print "\n\n";
113              
114 0 0 0       exit unless $username && $password;
115              
116 0           my $parameters = {
117             scopes => ["gist"],
118             note => "App::Nopaste",
119             note_url => "https://metacpan.org/module/App::Nopaste",
120             };
121              
122 0           my $ua = LWP::UserAgent->new;
123              
124 0           my $request = HTTP::Request->new(POST => 'https://api.github.com/authorizations');
125 0           $request->authorization_basic($username, $password);
126 0           $request->content(encode_json($parameters));
127              
128 0           my $response = $ua->request($request);
129              
130 0           my $response_content = decode_json($response->decoded_content);
131              
132 0 0         if ($response_content->{token} ) {
133 0           print "GITHUB_OAUTH_TOKEN=$response_content->{token}\n";
134             }
135             else {
136 0   0       print $response_content->{message} || "Unspecified error", "\n";
137             }
138             }
139              
140             sub return {
141 0     0 1   my ($self, $res) = @_;
142              
143 0 0         if ($res->is_error) {
144 0           my $text = $res->status_line;
145 0 0         if ($res->code == 401) {
146 0           $text .= "\nYou may need to authorize $0. See `perldoc " . __PACKAGE__ . "`";
147             }
148 0           return (0, "Failed: " . $text);
149             }
150              
151 0 0 0       if (($res->header('Client-Warning') || '') eq 'Internal response') {
152 0           return (0, "LWP Error: " . $res->content);
153             }
154              
155 0           my $id = decode_json($res->content)->{id};
156              
157 0 0         return (0, "Could not find paste link.") if !$id;
158 0           return (1, "https://gist.github.com/$id");
159             }
160              
161             1;
162              
163             __END__