File Coverage

blib/lib/App/MetaCPAN/Gtk2/Notify.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package App::MetaCPAN::Gtk2::Notify;
2              
3 1     1   27902 use 5.006;
  1         5  
  1         63  
4 1     1   6 use strict;
  1         1  
  1         39  
5 1     1   5 use warnings;
  1         14  
  1         53  
6             our $VERSION = '0.05';
7              
8 1     1   1639 use JSON;
  1         62410  
  1         6  
9 1     1   4082 use LWP::UserAgent;
  1         118939  
  1         48  
10 1     1   1166 use Gtk2::Notify;
  0            
  0            
11             use File::Temp ();
12             use File::Spec;
13             use File::Slurp qw(write_file);
14              
15             =head1 NAME
16              
17             App::MetaCPAN::Gtk2::Notify - Notify about recent modules uploaded to CPAN
18              
19             =head1 SYNOPSIS
20              
21             use App::MetaCPAN::Gtk2::Notify;
22              
23             App::MetaCPAN::Gtk2::Notify->run;
24              
25             =head1 METHODS
26              
27             =cut
28              
29             my $search_url = 'http://api.metacpan.org/v0/release/_search';
30             my $post_data = JSON::encode_json(
31             {
32             'size' => 20,
33             'from' => 0,
34             'sort' => [ { 'date' => { 'order' => 'desc', }, }, ],
35             'query' => { match_all => {} },
36             'fields' => [qw(name author id)],
37             }
38             );
39              
40             my $ua = LWP::UserAgent->new(agent => "MetaCPAN Notify/$VERSION");
41              
42             =head2 run
43              
44             This starts notifier.
45              
46             =cut
47              
48             my %prev_id;
49              
50             sub run {
51             my ( $class, %params ) = @_;
52             $prev_id{1} = 1 if $params{debug};
53             while (1) {
54             my @recent = get_recent();
55             show_recent( \@recent ) if @recent;
56             sleep 300;
57             }
58             }
59              
60             =head2 get_recent
61              
62             Get list of 20 latest recent modules from MetaCPAN. Returns reference to array
63             of hashes. Each hash contain keys: author, name, id.
64              
65             =cut
66              
67             sub get_recent {
68             my $resp = $ua->post( $search_url, Content => $post_data );
69             if ( $resp->is_success ) {
70             my $res = JSON::decode_json( $resp->content );
71             return map { $_->{fields} } @{ $res->{hits}{hits} };
72             }
73             else {
74             warn "Can't fetch recent modules from MetaCPAN: ", $resp->message;
75             return;
76             }
77             }
78              
79             =head2 show_recent(\@recent)
80              
81             Show notifications about recent packages
82              
83             =cut
84              
85             sub show_recent {
86             my $recent = shift;
87              
88             # skip notifying on a first run
89             if (%prev_id) {
90             Gtk2::Notify->init('MetaCPAN_recent');
91             for ( reverse @$recent ) {
92             next if $prev_id{ $_->{id} };
93             my ( $auth_name, $avatar ) = @{ get_author( $_->{author} ) };
94             my $url = "https://metacpan.org/release/$_->{author}/$_->{name}";
95             Gtk2::Notify->new( "$auth_name ($_->{author})", "uploaded $_->{name}", $avatar || () )
96             ->show;
97             }
98             Gtk2::Notify->uninit;
99             }
100             %prev_id = map { $_ => 1 } map { $_->{id} } @$recent;
101             }
102              
103             my %authors;
104             my $tmpdir = File::Temp->newdir;
105              
106             =head2 get_author($cpan_id)
107              
108             Return author name by cpan_id
109              
110             =cut
111              
112             sub get_author {
113             my $author = shift;
114             unless ( $authors{$author} ) {
115             my $resp = $ua->get("http://api.metacpan.org/v0/author/$author");
116             if ( $resp->is_success ) {
117             my $res = JSON::decode_json( $resp->content );
118             my $avatar = $ua->get( $res->{gravatar_url} );
119             my $avatar_file = File::Spec->catfile( $tmpdir, "$author.jpg" );
120             if ( $avatar->is_success ) {
121             write_file( $avatar_file, $avatar->content );
122             $avatar_file = "$avatar_file";
123             }
124             else {
125             $avatar_file = undef;
126             }
127             $authors{$author} = [ $res->{name}, $avatar_file ];
128             }
129             else {
130             $authors{$author} = [ " ", undef ];
131             }
132             }
133             return $authors{$author};
134             }
135              
136             1;
137              
138             =head1 AUTHOR
139              
140             Pavel Shaydo, C<< >>
141              
142             =head1 LICENSE AND COPYRIGHT
143              
144             Copyright 2011 Pavel Shaydo.
145              
146             This program is free software; you can redistribute it and/or modify it
147             under the terms of either: the GNU General Public License as published
148             by the Free Software Foundation; or the Artistic License.
149              
150             See http://dev.perl.org/licenses/ for more information.
151              
152              
153             =cut