File Coverage

blib/lib/Reddit/Client.pm
Criterion Covered Total %
statement 337 1242 27.1
branch 1 476 0.2
condition 0 397 0.0
subroutine 113 220 51.3
pod 70 108 64.8
total 521 2443 21.3


line stmt bran cond sub pod time code
1             package Reddit::Client;
2              
3             our $VERSION = '1.395';
4             # 1.395 2/15/23 duplicates
5             # 1.394 8/16/21 Added third argument to approve_user, for unapprove
6             # 1.394 Added unapprove_user, alias for approve_user with unapprove arg set
7              
8             # Not in yet: gallery links to Link
9             # Not in yet: keys is_gallery and gallery_data to Link
10              
11             # 1.390 fixed reply() in Link and Comment
12              
13             # 1.389 docs, fixed get_flair_options. when requesting flair for specific user it always failed
14             # and returned the requsting user's flair instead.
15              
16             # 1.388 5/3 added approve and ignore_reports to Comment
17             # Needs doc:
18             # report, modmail_mute, modmail_action, Modm...->archive, sticky_post
19              
20             # 1.387 Added approve and ignore_report functions to Link.pm
21              
22             $VERSION = eval $VERSION;
23              
24 5     5   142295 use strict;
  5         40  
  5         146  
25 5     5   41 use Carp;
  5         11  
  5         272  
26              
27 5     5   2420 use Data::Dumper qw/Dumper/;
  5         30136  
  5         302  
28 5     5   720 use JSON qw/decode_json/;
  5         12782  
  5         33  
29 5     5   838 use File::Spec qw//;
  5         12  
  5         107  
30 5     5   25 use Digest::MD5 qw/md5_hex/;
  5         12  
  5         251  
31 5     5   2794 use POSIX qw/strftime/;
  5         31440  
  5         38  
32             #use File::Path::Expand qw//; # Does nothing?
33              
34             require Reddit::Client::Account;
35             require Reddit::Client::Comment;
36             require Reddit::Client::Link;
37             require Reddit::Client::SubReddit;
38             require Reddit::Client::Request;
39             require Reddit::Client::Message;
40             require Reddit::Client::MoreComments;
41             require Reddit::Client::ModmailConversation;
42             require Reddit::Client::ModmailMessage;
43              
44             #===============================================================================
45             # Constants
46             #===============================================================================
47              
48 5     5   7943 use constant DEFAULT_LIMIT => 25;
  5         10  
  5         334  
49              
50 5     5   39 use constant VIEW_HOT => '';
  5         11  
  5         299  
51 5     5   37 use constant VIEW_NEW => 'new';
  5         9  
  5         246  
52 5     5   28 use constant VIEW_CONTROVERSIAL => 'controversial';
  5         37  
  5         212  
53 5     5   26 use constant VIEW_TOP => 'top';
  5         30  
  5         232  
54 5     5   29 use constant VIEW_RISING => 'rising';
  5         9  
  5         214  
55 5     5   25 use constant VIEW_DEFAULT => VIEW_HOT;
  5         9  
  5         245  
56              
57 5     5   28 use constant VOTE_UP => 1;
  5         9  
  5         255  
58 5     5   30 use constant VOTE_DOWN => -1;
  5         9  
  5         232  
59 5     5   26 use constant VOTE_NONE => 0;
  5         9  
  5         246  
60              
61 5     5   61 use constant SUBMIT_LINK => 'link';
  5         12  
  5         214  
62 5     5   24 use constant SUBMIT_SELF => 'self';
  5         9  
  5         242  
63 5     5   29 use constant SUBMIT_MESSAGE => 'message';
  5         8  
  5         245  
64 5     5   28 use constant SUBMIT_CROSSPOST => 'crosspost';
  5         8  
  5         233  
65              
66 5     5   27 use constant MESSAGES_INBOX => 'inbox';
  5         9  
  5         325  
67 5     5   34 use constant MESSAGES_UNREAD => 'unread';
  5         8  
  5         229  
68 5     5   27 use constant MESSAGES_SENT => 'sent';
  5         8  
  5         292  
69 5     5   27 use constant MESSAGES_MESSAGES => 'messages';
  5         16  
  5         249  
70 5     5   31 use constant MESSAGES_COMMENTREPLIES => 'comments';
  5         8  
  5         242  
71 5     5   25 use constant MESSAGES_POSTREPLIES => 'selfreply';
  5         9  
  5         229  
72 5     5   29 use constant MESSAGES_MENTIONS => 'mentions';
  5         8  
  5         269  
73              
74 5     5   27 use constant SUBREDDITS_HOME => '';
  5         9  
  5         237  
75 5     5   28 use constant SUBREDDITS_MINE => 'subscriber';
  5         342  
  5         217  
76 5     5   26 use constant SUBREDDITS_POPULAR => 'popular';
  5         39  
  5         227  
77 5     5   30 use constant SUBREDDITS_NEW => 'new';
  5         9  
  5         235  
78 5     5   36 use constant SUBREDDITS_CONTRIB => 'contributor';
  5         9  
  5         264  
79 5     5   30 use constant SUBREDDITS_MOD => 'moderator';
  5         7  
  5         240  
80              
81 5     5   31 use constant USER_OVERVIEW => 'overview';
  5         9  
  5         222  
82 5     5   27 use constant USER_COMMENTS => 'comments';
  5         8  
  5         240  
83 5     5   29 use constant USER_SUBMITTED => 'submitted';
  5         7  
  5         229  
84 5     5   29 use constant USER_GILDED => 'gilded';
  5         8  
  5         219  
85 5     5   27 use constant USER_UPVOTED => 'upvoted';
  5         9  
  5         248  
86 5     5   30 use constant USER_DOWNVOTED => 'downvoted';
  5         19  
  5         304  
87 5     5   66 use constant USER_HIDDEN => 'hidden';
  5         10  
  5         254  
88 5     5   38 use constant USER_SAVED => 'saved';
  5         10  
  5         242  
89 5     5   26 use constant USER_ABOUT => 'about';
  5         11  
  5         219  
90              
91 5     5   27 use constant API_ME => 0;
  5         27  
  5         240  
92 5     5   28 use constant API_INFO => 1;
  5         7  
  5         196  
93 5     5   26 use constant API_SUB_SEARCH => 2;
  5         15  
  5         229  
94 5     5   27 use constant API_LOGIN => 3;
  5         8  
  5         234  
95 5     5   28 use constant API_SUBMIT => 4;
  5         7  
  5         260  
96 5     5   40 use constant API_COMMENT => 5;
  5         12  
  5         253  
97 5     5   37 use constant API_VOTE => 6;
  5         8  
  5         244  
98 5     5   30 use constant API_SAVE => 7;
  5         7  
  5         233  
99 5     5   26 use constant API_UNSAVE => 8;
  5         10  
  5         245  
100 5     5   28 use constant API_HIDE => 9;
  5         10  
  5         242  
101 5     5   53 use constant API_UNHIDE => 10;
  5         18  
  5         215  
102 5     5   43 use constant API_SUBREDDITS => 11;
  5         10  
  5         243  
103 5     5   27 use constant API_LINKS_FRONT => 12;
  5         8  
  5         216  
104 5     5   24 use constant API_LINKS_OTHER => 13;
  5         16  
  5         257  
105 5     5   27 use constant API_DEL => 14;
  5         30  
  5         244  
106 5     5   27 use constant API_MESSAGE => 15;
  5         19  
  5         230  
107 5     5   26 use constant API_COMMENTS_FRONT => 16;
  5         9  
  5         257  
108 5     5   29 use constant API_COMMENTS => 17;
  5         16  
  5         213  
109 5     5   26 use constant API_MESSAGES => 18;
  5         8  
  5         238  
110 5     5   37 use constant API_MARK_READ => 19;
  5         9  
  5         218  
111 5     5   27 use constant API_MARKALL => 20;
  5         11  
  5         264  
112 5     5   31 use constant API_MY_SUBREDDITS => 21;
  5         102  
  5         264  
113 5     5   27 use constant API_USER => 22;
  5         10  
  5         290  
114 5     5   30 use constant API_SELECTFLAIR => 23;
  5         10  
  5         214  
115 5     5   28 use constant API_FLAIROPTS => 24;
  5         9  
  5         325  
116 5     5   28 use constant API_EDITWIKI => 25;
  5         9  
  5         223  
117 5     5   26 use constant API_CREATEMULTI => 26;
  5         14  
  5         235  
118 5     5   28 use constant API_DELETEMULTI => 27;
  5         10  
  5         202  
119 5     5   22 use constant API_GETMULTI => 28;
  5         9  
  5         281  
120 5     5   42 use constant API_EDITMULTI => 29;
  5         11  
  5         279  
121 5     5   66 use constant API_SUBREDDIT_INFO => 30;
  5         11  
  5         244  
122 5     5   30 use constant API_SEARCH => 31;
  5         10  
  5         204  
123 5     5   27 use constant API_MODQ => 32;
  5         9  
  5         215  
124 5     5   28 use constant API_EDIT => 33;
  5         10  
  5         244  
125 5     5   39 use constant API_REMOVE => 34;
  5         9  
  5         245  
126 5     5   27 use constant API_APPROVE => 35;
  5         10  
  5         212  
127 5     5   27 use constant API_IGNORE_REPORTS => 36;
  5         10  
  5         297  
128 5     5   31 use constant API_GETWIKI => 37;
  5         9  
  5         242  
129 5     5   28 use constant API_GET_MODMAIL => 38;
  5         9  
  5         228  
130 5     5   41 use constant API_BAN => 39;
  5         16  
  5         266  
131 5     5   27 use constant API_MORECHILDREN => 40;
  5         10  
  5         254  
132 5     5   28 use constant API_BY_ID => 41;
  5         10  
  5         223  
133 5     5   25 use constant API_FLAIR => 42;
  5         8  
  5         249  
134 5     5   30 use constant API_DELETEFLAIR => 43;
  5         9  
  5         226  
135 5     5   26 use constant API_UNBAN => 44;
  5         7  
  5         256  
136 5     5   29 use constant API_DISTINGUISH => 45;
  5         17  
  5         232  
137 5     5   47 use constant API_UNDISTINGUISH => 46;
  5         12  
  5         220  
138 5     5   35 use constant API_LOCK => 47;
  5         10  
  5         221  
139 5     5   24 use constant API_UNLOCK => 48;
  5         9  
  5         221  
140 5     5   26 use constant API_MARKNSFW => 49;
  5         15  
  5         251  
141 5     5   42 use constant API_UNMARKNSFW => 50;
  5         9  
  5         267  
142 5     5   29 use constant API_FLAIRTEMPLATE2 => 51;
  5         17  
  5         228  
143 5     5   27 use constant API_LINKFLAIRV1 => 52;
  5         9  
  5         271  
144 5     5   28 use constant API_LINKFLAIRV2 => 53;
  5         10  
  5         216  
145 5     5   33 use constant API_USERFLAIRV1 => 54;
  5         27  
  5         239  
146 5     5   39 use constant API_USERFLAIRV2 => 55;
  5         16  
  5         224  
147 5     5   27 use constant API_NEW_MM_CONV => 56;
  5         11  
  5         244  
148 5     5   27 use constant API_FRIEND => 57;
  5         8  
  5         237  
149 5     5   27 use constant API_STICKY_POST => 58;
  5         9  
  5         249  
150 5     5   26 use constant API_MM_MUTE => 59;
  5         11  
  5         250  
151 5     5   28 use constant API_REPORT => 60;
  5         17  
  5         261  
152 5     5   29 use constant API_MM_POST_ACTION => 61;
  5         10  
  5         214  
153 5     5   35 use constant API_MM_GET_ACTION => 62;
  5         11  
  5         265  
154 5     5   34 use constant API_SUBINFO => 63;
  5         10  
  5         228  
155 5     5   28 use constant API_ABOUT => 64;
  5         7  
  5         228  
156 5     5   44 use constant API_DUPLICATES => 65;
  5         19  
  5         361  
157              
158             #===============================================================================
159             # Parameters
160             #===============================================================================
161              
162             our $DEBUG = 0;
163             our $BASE_URL = 'https://oauth.reddit.com';
164 5     5   31 use constant BASE_URL =>'https://oauth.reddit.com';
  5         9  
  5         719  
165             our $LINK_URL = 'https://www.reddit.com'; # Why are there two of these?
166 5     5   30 use constant LINK_URL =>'https://www.reddit.com'; # both are unused now?
  5         16  
  5         3364  
167              
168             our @API;
169             $API[API_ME ] = ['GET', '/api/v1/me' ];
170             $API[API_INFO ] = ['GET', '/api/info' ];
171             $API[API_SUB_SEARCH ] = ['GET', '/subreddits/search' ];
172             $API[API_LOGIN ] = ['POST', '/api/login/%s' ];
173             $API[API_SUBMIT ] = ['POST', '/api/submit' ];
174             $API[API_COMMENT ] = ['POST', '/api/comment' ];
175             $API[API_VOTE ] = ['POST', '/api/vote' ];
176             $API[API_SAVE ] = ['POST', '/api/save' ];
177             $API[API_UNSAVE ] = ['POST', '/api/unsave' ];
178             $API[API_HIDE ] = ['POST', '/api/hide' ];
179             $API[API_UNHIDE ] = ['POST', '/api/unhide' ];
180             $API[API_SUBREDDITS ] = ['GET', '/subreddits/%s' ];
181             $API[API_MY_SUBREDDITS ] = ['GET', '/subreddits/mine/%s' ];
182             $API[API_LINKS_OTHER ] = ['GET', '/%s' ];
183             $API[API_LINKS_FRONT ] = ['GET', '/r/%s/%s' ];
184             $API[API_DEL ] = ['POST', '/api/del' ];
185             $API[API_MESSAGE ] = ['POST', '/api/compose' ];
186             $API[API_COMMENTS ] = ['GET', '/r/%s/comments' ];
187             $API[API_COMMENTS_FRONT] = ['GET', '/comments' ];
188             $API[API_MESSAGES ] = ['GET', '/message/%s' ];
189             $API[API_MARK_READ ] = ['POST', '/api/read_message' ];
190             $API[API_MARKALL ] = ['POST', '/api/read_all_messages' ];
191             $API[API_USER ] = ['GET', '/user/%s/%s' ];
192             $API[API_SELECTFLAIR ] = ['POST', '/r/%s/api/selectflair' ];
193             $API[API_FLAIROPTS ] = ['POST', '/r/%s/api/flairselector' ];
194             $API[API_EDITWIKI ] = ['POST', '/r/%s/api/wiki/edit' ];
195             $API[API_GETWIKI ] = ['GET', '/r/%s/wiki/%s' ];
196             $API[API_CREATEMULTI ] = ['POST', '/api/multi/user/%s/m/%s' ];
197             $API[API_GETMULTI ] = ['GET', '/api/multi/user/%s/m/%s%s'];
198             $API[API_DELETEMULTI ] = ['DELETE','/api/multi/user/%s/m/%s'];
199             $API[API_EDITMULTI ] = ['PUT', '/api/multi/user/%s/m/%s' ];
200             $API[API_ABOUT ] = ['GET', '/r/%s/about' ];
201             $API[API_SUBINFO ] = ['GET', '/r/%s/about/%s' ];
202             $API[API_SEARCH ] = ['GET', '/r/%s/search' ];
203             $API[API_MODQ ] = ['GET', '/r/%s/about/%s' ];
204             $API[API_EDIT ] = ['POST', '/api/editusertext' ];
205             $API[API_REMOVE ] = ['POST', '/api/remove' ];
206             $API[API_APPROVE ] = ['POST', '/api/approve' ];
207             $API[API_IGNORE_REPORTS] = ['POST', '/api/ignore_reports' ];
208             $API[API_GET_MODMAIL ] = ['GET', '/api/mod/conversations' ];
209             $API[API_BAN ] = ['POST', '/r/%s/api/friend' ];
210             $API[API_MORECHILDREN ] = ['GET', '/api/morechildren' ];
211             $API[API_BY_ID ] = ['GET', '/by_id' ];
212             $API[API_FLAIR ] = ['POST', '/r/%s/api/flair' ];
213             $API[API_DELETEFLAIR ] = ['POST', '/r/%s/api/deleteflair' ];
214             $API[API_UNBAN ] = ['POST', '/r/%s/api/unfriend' ];
215             $API[API_DISTINGUISH ] = ['POST', '/api/distinguish' ];
216             $API[API_UNDISTINGUISH ] = ['POST', '/api/distinguish' ];
217             $API[API_LOCK ] = ['POST', '/api/lock' ]; # fullname
218             $API[API_UNLOCK ] = ['POST', '/api/unlock' ]; # only
219             $API[API_MARKNSFW ] = ['POST', '/api/marknsfw' ]; # these
220             $API[API_UNMARKNSFW ] = ['POST', '/api/unmarknsfw' ]; # four
221             $API[API_FLAIRTEMPLATE2] = ['POST', '/r/%s/api/flairtemplate_v2'];
222             $API[API_LINKFLAIRV1 ] = ['GET', '/r/%s/api/link_flair' ];
223             $API[API_LINKFLAIRV2 ] = ['GET', '/r/%s/api/link_flair_v2' ];
224             $API[API_USERFLAIRV1 ] = ['GET', '/r/%s/api/user_flair' ];
225             $API[API_USERFLAIRV2 ] = ['GET', '/r/%s/api/user_flair_v2' ];
226             # Read modmail conversation uses GET on the same endpoint
227             $API[API_NEW_MM_CONV ] = ['POST', '/api/mod/conversations' ];
228             $API[API_FRIEND ] = ['PUT', '/api/v1/me/friends/%' ];
229             $API[API_STICKY_POST ] = ['POST', '/api/set_subreddit_sticky'];
230             $API[API_MM_MUTE ] = ['POST', '/api/mod/conversations/%s/mute'];
231             $API[API_REPORT ] = ['POST', '/api/report' ];
232             $API[API_MM_POST_ACTION] = ['POST', '/api/mod/conversations/%s/%s'];
233             $API[API_DUPLICATES ] = ['GET', '/duplicates/%s' ];
234              
235             #POST /api/mod/conversations/:conversation_id/mute
236             #conversation_id base36 modmail conversation id
237              
238             #
239             #
240              
241              
242             #===============================================================================
243             # Class methods
244             #===============================================================================
245              
246             use fields (
247 5         51 'modhash', # No longer used. stored session modhash
248             'cookie', # No longer used. stored user cookie
249             'session_file', # No longer used. path to session file
250             'user_agent', # user agent string
251             'token', # oauth authorization token
252             'tokentype', # unused but saved for reference
253             'last_token', # time last token was acquired
254             'client_id', # always required
255             'secret', # always required
256             'username', # now optional for web apps
257             'password', # script apps only
258             'request_errors', # print request errors, deprecated
259             'print_request_errors', # print request errors
260             'print_response', # print response content, deprecated
261             'print_response_content',# print response content
262             'print_request', # print entire request
263             'print_request_on_error',# print entire request on error
264             'refresh_token', # oauth refresh token
265             'auth_type', # 'script' or 'webapp'
266             'debug',
267             'subdomain',
268 5     5   2032 );
  5         6452  
269              
270             sub new {
271 0     0 1 0 my ($class, %param) = @_;
272 0         0 my $self = fields::new($class);
273              
274 0 0       0 if (not exists $param{user_agent}) {
275 0         0 croak "param 'user_agent' is required.";
276             }
277 0         0 $self->{user_agent} = $param{user_agent};
278             # request_errors does nothing?
279 0   0     0 $self->{request_errors} = $param{print_request_errors} || $param{request_errors} || 0;
280 0   0     0 $self->{print_response} = $param{print_response} || $param{print_response_conent} || 0;
281 0   0     0 $self->{print_request} = $param{print_request} || 0;
282 0   0     0 $self->{debug} = $param{debug} || 0;
283 0   0     0 $self->{print_request_on_error} = $param{print_request_on_error} || 0;
284 0   0     0 $self->{subdomain} = $param{subdomain} || 'www';
285              
286 0 0       0 if ($param{password}) {
    0          
287 0 0 0     0 if (!$param{username}) {
    0          
288 0         0 croak "if password is provided, username is required.";
289             } elsif (!$param{client_id} or !$param{secret}) {
290 0         0 croak "client_id and secret are required for authorized apps.";
291             } else {
292 0         0 $self->{auth_type} = 'script';
293 0         0 $self->{client_id} = $param{client_id};
294 0         0 $self->{secret} = $param{secret};
295 0         0 $self->{username} = $param{username};
296 0         0 $self->{password} = $param{password};
297              
298 0         0 $self->get_token();
299             }
300             } elsif ($param{refresh_token}) {
301 0 0 0     0 croak "client_id and secret are required for authorized apps." unless $param{client_id} and $param{secret};
302            
303 0         0 $self->{auth_type} = 'webapp';
304 0         0 $self->{client_id} = $param{client_id};
305 0         0 $self->{secret} = $param{secret};
306 0         0 $self->{refresh_token}= $param{refresh_token};
307             # will this break anything?
308 0 0       0 $self->{username} = $param{username} if $param{username};
309              
310 0         0 $self->get_token();
311             } else {
312             # optionall allow people to pass in client id and secret now, for people
313             # who choose to get refresh token from an RC object
314 0 0       0 $self->{client_id} = $param{client_id} if $param{client_id};
315 0 0       0 $self->{secret} = $param{secret} if $param{secret};
316             # can this even be run without auth anymore?
317 0         0 $self->{auth_type} = 'none';
318             }
319              
320 0         0 return $self;
321             }
322              
323             sub version {
324 0     0 1 0 my $self = shift;
325 0         0 return $VERSION;
326             }
327              
328             #===============================================================================
329             # Requests and Oauth
330             #===============================================================================
331              
332             sub request {
333 0     0 0 0 my ($self, $method, $path, $query, $post_data) = @_;
334              
335             # 401s not being caused by this. they are a new API issue apparently.
336 0 0 0     0 if (!$self->{last_token} or $self->{last_token} <= ( time - 3600 + 55) ) {
337             # passing in username, pass, client_id, secret here did nothing
338 0         0 $self->get_token();
339             }
340              
341             # Trim leading slashes off of the path
342 0         0 $path =~ s/^\/+//;
343             my $request = Reddit::Client::Request->new(
344             user_agent => $self->{user_agent},
345             # path is sprintf'd before call, in api_json_request
346             # the calling function passes in path %s's in 'args' param
347             url => sprintf('%s/%s', $BASE_URL, $path),
348             method => $method,
349             query => $query,
350             post_data => $post_data,
351             modhash => $self->{modhash},
352             cookie => $self->{cookie},
353             token => $self->{token},
354             tokentype => $self->{tokentype},
355             last_token => $self->{last_token},
356             request_errors=> $self->{request_errors},
357             print_response=> $self->{print_response},
358             print_request=> $self->{print_request},
359             print_request_on_error=>$self->{print_request_on_error},
360 0         0 );
361              
362 0         0 return $request->send;
363             }
364              
365             sub get_token {
366 0     0 1 0 my ($self, %param) = @_;
367              
368             # let people set auth things here. this was stupid to allow.
369             # these all set $self properties then continue as normal.
370 0 0 0     0 if ($param{username} or $param{password}) {
    0          
371 0 0 0     0 die "get_token: if username or password are provided, all 4 script-type authentication arguments (username, password, client_id, secret) are required." unless $param{username} and $param{password} and $param{client_id} and $param{secret};
      0        
      0        
372              
373 0         0 $self->{auth_type} = 'script';
374 0         0 $self->{client_id} = $param{client_id};
375 0         0 $self->{secret} = $param{secret};
376 0         0 $self->{username} = $param{username};
377 0         0 $self->{password} = $param{password};
378              
379             } elsif ($param{refresh_token}) {
380 0         0 $self->{auth_type} = 'webapp';
381 0   0     0 $self->{client_id} = $param{client_id} || $self->{client_id} || die "get_token: 'client_id' must be set, either as a parameter to get_token or when instantiating the Reddit::Client object.";
382 0   0     0 $self->{secret} = $param{secret} || $self->{secret} || die "get_token: 'secret' must be set, either as a parameter to get_token or when instantiating the Reddit::Client object.";
383 0         0 $self->{refresh_token} = $param{refresh_token};
384             }
385              
386 0         0 $self->{last_token} = time;
387              
388             # why don't we just pass in the whole Client object ffs
389             my %p = (
390             client_id => $self->{client_id},
391             secret => $self->{secret},
392             user_agent => $self->{user_agent},
393             auth_type => $self->{auth_type},
394 0         0 );
395              
396 0 0       0 if ($self->{auth_type} eq 'script') {
    0          
397             $p{username} = $self->{username},
398             $p{password} = $self->{password},
399 0         0 } elsif ($self->{auth_type} eq 'webapp') {
400 0         0 $p{refresh_token} = $self->{refresh_token};
401 0         0 } else { die "get_token: invalid auth type"; }
402              
403             # Why is this static?
404 0         0 my $message = Reddit::Client::Request->token_request(%p);
405 0         0 my $j = decode_json($message);
406 0         0 $self->{token} = $j->{access_token};
407 0         0 $self->{tokentype} = $j->{token_type};
408              
409 0 0       0 if (!$self->{token}) { croak "Unable to get or parse token."; }
  0         0  
410             }
411              
412             sub has_token {
413 0     0 1 0 my $self = shift;
414 0 0 0     0 return (!$self->{last_token} || $self->{last_token} <= time - 3595) ? 0 : 1;
415             }
416             #
417             # This must be called in static context because no refresh token or user/
418             # pass combination exist. We would have to add a third flow and that doesn't
419             # seem worth it.
420             #
421             # We could call it in an empty RC object, but that would require all sorts
422             # of annoyoing conditions, and all other methods would be broken until
423             # tokens were obtained
424             sub get_refresh_token {
425 0     0 1 0 my ($self, %param) = @_;
426              
427 0         0 my %data;
428 0   0     0 $data{code} = $param{code} || die "'code' is required.\n";
429 0   0     0 $data{redirect_uri} = $param{redirect_uri} || die "'redirect_uri' is required.\n";
430 0   0     0 $data{client_id} = (ref $self eq 'HASH' and $self->{client_id} ? $self->{client_id} : undef) || $param{client_id} || die "'client_id' is required.\n";
431 0   0     0 $data{secret} = (ref $self eq 'HASH' and $self->{secret} ? $self->{secret} : undef) || $param{secret} || die "'secret' is required.";
432 0   0     0 $data{ua} = (ref $self eq 'HASH' and $self->{user_agent} ? $self->{user_agent} : undef) || $param{user_agent} || die "'user_agent' is required.";
433             #$data{ua} = $param{user_agent} || die "user_agent is required";
434 0         0 $data{grant_type} = 'authorization_code';
435 0         0 $data{duration} = 'permanent';
436              
437 0         0 my $refresh_token = Reddit::Client::Request->refresh_token_request(%data);
438 0         0 return $refresh_token;
439             }
440              
441             sub json_request {
442 0     0 0 0 my ($self, $method, $path, $query, $post_data) = @_;
443 0         0 DEBUG('%4s JSON', $method);
444              
445 0 0       0 if ($method eq 'POST') {
446 0   0     0 $post_data ||= {};
447 0         0 $post_data->{api_type} = 'json'; # only POST enpoints require*
448             } else {
449             #$path .= '.json'; # the oauth api returns json by default
450             }
451              
452 0         0 my $response = $self->request($method, $path, $query, $post_data);
453 0 0       0 my $json = JSON::from_json($response) if $response;
454              
455 0 0 0     0 if (ref $json eq 'HASH' && $json->{json}) {
456 0         0 my $result = $json->{json};
457 0 0       0 if (@{$result->{errors}}) {
  0         0  
458 0         0 DEBUG('API Errors: %s', Dumper($result->{errors}));
459             my @errors = map {
460 0         0 sprintf '[%s] %s', $_->[0], $_->[1]
461 0         0 } @{$result->{errors}};
  0         0  
462 0         0 croak sprintf("Error(s): %s", join('|', @errors));
463             } else {
464 0         0 return $result;
465             }
466             } else {
467 0         0 return $json;
468             }
469             }
470              
471             sub api_json_request {
472 0     0 0 0 my ($self, %param) = @_;
473 0   0     0 my $args = $param{args} || [];
474 0         0 my $api = $param{api};
475 0         0 my $data = $param{data};
476 0         0 my $callback = $param{callback};
477              
478 0 0       0 croak 'Expected "api"' unless defined $api;
479              
480 0         0 DEBUG('API call %d', $api);
481              
482 0   0     0 my $info = $API[$api] || croak "Unknown API: $api";
483 0         0 my ($method, $path) = @$info;
484 0         0 $path = sprintf $path, @$args;
485              
486 0         0 my ($query, $post_data);
487 0 0 0     0 if ($method eq 'GET' or $method eq 'DELETE') {
488 0         0 $query = $data;
489             } else {
490 0         0 $post_data = $data;
491             }
492              
493 0         0 my $result = $self->json_request($method, $path, $query, $post_data);
494              
495             # This breaks on endpoints that return an array like flairselect v2
496 0 0 0     0 if (ref $result eq 'HASH' and exists $result->{errors}) {
497 0         0 my @errors = @{$result->{errors}};
  0         0  
498              
499 0 0       0 if (@errors) {
500 0         0 DEBUG("ERRORS: @errors");
501 0         0 my $message = join(' | ', map { join(', ', @$_) } @errors);
  0         0  
502 0         0 croak $message;
503             }
504             }
505             # The fuck is this?
506 0 0 0     0 if (defined $callback && ref $callback eq 'CODE') {
507 0         0 return $callback->($result);
508             } else {
509 0         0 return $result;
510             }
511             }
512              
513             # deprecated, to be removed
514             sub is_logged_in {
515 0     0 0 0 return defined $_[0]->{modhash};
516             }
517              
518             # deprecated, to be removed
519             sub require_login {
520 0     0 0 0 my $self = shift;
521 0         0 return;
522             }
523              
524              
525             #===============================================================================
526             # User and account management
527             #===============================================================================
528              
529             sub me {
530 0     0 1 0 my $self = shift;
531 0         0 DEBUG('Request user account info');
532 0         0 my $result = $self->api_json_request(api => API_ME);
533             # Account has no data property like other things
534 0         0 return Reddit::Client::Account->new($self, $result);
535             }
536             sub list_subreddits {
537 0     0 1 0 my ($self, %param) = @_;
538 0   0     0 my $type = $param{view} || SUBREDDITS_HOME;
539 0 0       0 $type = '' if lc $type eq 'home';
540              
541 0         0 my $query = $self->set_listing_defaults(%param);
542              
543 0 0 0     0 my $api = $type eq SUBREDDITS_MOD || $type eq SUBREDDITS_CONTRIB || $type eq SUBREDDITS_MINE ? API_MY_SUBREDDITS : API_SUBREDDITS;
544              
545 0         0 my $result = $self->api_json_request(
546             api => $api,
547             args => [$type],
548             data => $query,
549             );
550              
551             return [
552 0         0 map {Reddit::Client::SubReddit->new($self, $_->{data})} @{$result->{data}{children}}
  0         0  
  0         0  
553             ];
554             }
555              
556             sub contrib_subreddits {
557 0     0 0 0 my ($self, %param) = @_;
558 0         0 $param{view} = SUBREDDITS_CONTRIB;
559 0         0 return $_[0]->list_subreddits(%param);
560             }
561             sub home_subreddits {
562 0     0 0 0 my ($self, %param) = @_;
563 0         0 $param{view} = SUBREDDITS_HOME;
564 0         0 return $_[0]->list_subreddits(%param);
565             }
566             sub mod_subreddits {
567 0     0 0 0 my ($self, %param) = @_;
568 0         0 $param{view} = SUBREDDITS_MOD;
569 0         0 return $_[0]->list_subreddits(%param);
570             }
571             sub my_subreddits {
572 0     0 0 0 my ($self, %param) = @_;
573 0         0 $param{view} = SUBREDDITS_MINE;
574 0         0 return $_[0]->list_subreddits(%param);
575             }
576             sub new_subreddits {
577 0     0 0 0 my ($self, %param) = @_;
578 0         0 $param{view} = SUBREDDITS_NEW;
579 0         0 return $_[0]->list_subreddits(%param);
580             }
581             sub popular_subreddits {
582 0     0 0 0 my ($self, %param) = @_;
583 0         0 $param{view} = SUBREDDITS_POPULAR;
584 0         0 return $_[0]->list_subreddits(%param);
585             }
586              
587             #===============================================================================
588             # Inbox and messages
589             #===============================================================================
590             sub get_inbox {
591 0     0 1 0 my ($self, %param) = @_;
592 0   0     0 my $limit = $param{limit} || DEFAULT_LIMIT;
593 0   0     0 my $mode = $param{mode} || MESSAGES_INBOX;
594 0   0     0 my $view = $param{view} || MESSAGES_INBOX;
595              
596             # this before and after business is stupid and needs to be fixed
597             # in 3 separate places
598 0         0 my $query = {};
599 0 0       0 $query->{mark} = $param{mark} ? 'true' : 'false';
600 0 0       0 $query->{sr_detail} = $param{sr_detail} if $param{sr_detail};
601 0 0       0 $query->{before} = $param{before} if $param{before};
602 0 0       0 $query->{after} = $param{after} if $param{after};
603 0 0 0     0 if (exists $param{limit}) { $query->{limit} = $param{limit} || 500; }
  0         0  
604 0         0 else { $query->{limit} = DEFAULT_LIMIT; }
605            
606 0         0 my $result = $self->api_json_request(
607             api => API_MESSAGES,
608             args => [$view],
609             data => $query,
610             );
611              
612             #return $result;
613             return [
614 0         0 map { Reddit::Client::Message->new($self, $_->{data}) } @{$result->{data}{children}}
  0         0  
  0         0  
615             ];
616             }
617              
618             # TODO
619             sub mark_read {
620 0     0 0 0 my ($self, %param) = @_;
621              
622             }
623              
624             sub mark_inbox_read {
625 0     0 1 0 my $self = shift;
626 0         0 my ($method, $path) = @{$API[API_MARKALL]};
  0         0  
627             # Why does this error without api_type? json_request is adding it anyway?
628 0         0 my $post_data = {api_type => 'json'};
629 0         0 my $result = $self->request($method, $path, {}, $post_data);
630             }
631              
632             #===============================================================================
633             # Subreddits and listings
634             #===============================================================================
635              
636             # works section 1:
637             # banned, muted, wikibanned, contributors, wikicontributors, moderators, edit, log
638              
639             # should work but returns undef:
640             # rules (uses read), traffic (uses modconfig),
641             #
642             sub get_subreddit_info {
643 0     0 1 0 my $self = shift;
644 0   0     0 my $sub = shift || croak 'Argument 1 (subreddit name) is required.';
645 0         0 $sub = subreddit($sub);
646 0         0 my $page = shift;
647              
648 0         0 my ($api, $args);
649 0 0       0 if ($page) {
650 0         0 $api = API_SUBINFO;
651 0         0 $args = [$sub, $page];
652             } else {
653 0         0 $api = API_ABOUT;
654 0         0 $args = [$sub];
655             }
656              
657 0         0 my $result = $self->api_json_request(
658             api => $api,
659             args => $args,
660             );
661             #return $result->{data};
662 0         0 return $result;
663             }
664              
665             sub info {
666 0     0 1 0 my ($self, $id) = @_;
667 0 0       0 defined $id || croak 'Expected $id';
668 0         0 my $query->{id} = $id;
669            
670 0         0 my $info = $self->api_json_request(
671             api => API_INFO,
672             data=>$query
673             );
674             #return $info;
675 0         0 my $rtn = $info->{data}->{children}[0]->{data};
676 0 0       0 $rtn->{kind} = $info->{data}->{children}[0]->{kind} if $rtn;
677 0         0 return $rtn;
678             }
679              
680             sub search {
681 0     0 0 0 my ($self, %param) = @_;
682 0   0     0 my $sub = $param{subreddit} || $param{sub} || croak "'subreddit' or 'sub' is required.";
683              
684 0         0 my $query = $self->set_listing_defaults(%param);
685 0   0     0 $query->{q} = $param{q} || croak "'q' (search string) is required.";
686              
687             # things the user should be able to choose but we're hard coding
688 0         0 $query->{restrict_sr} = 'on';
689 0         0 $query->{include_over18}= 'on';
690 0         0 $query->{t} = 'all';
691 0         0 $query->{syntax} = 'cloudsearch';
692 0         0 $query->{show} = 'all';
693 0         0 $query->{type} = 'link'; # return Link objects
694 0         0 $query->{sort} = 'top';
695            
696 0         0 my $args = [$sub];
697              
698 0         0 my $result = $self->api_json_request(
699             api => API_SEARCH,
700             args=> $args,
701             data => $query,
702             );
703              
704             #return $result->{data};
705             return [
706 0         0 map {Reddit::Client::Link->new($self, $_->{data})} @{$result->{data}{children}}
  0         0  
  0         0  
707             ];
708             }
709             sub get_permalink {
710             # This still makes an extra request. Why?
711 0     0 1 0 my ($self, $commentid, $post_fullname) = @_;
712              
713 0 0       0 if (substr ($commentid, 0, 3) eq "t1_") { $commentid = substr $commentid, 3; }
  0         0  
714 0 0       0 if (substr ($post_fullname, 0, 3) ne "t3_") { $post_fullname = "t3_" . $post_fullname; }
  0         0  
715              
716 0         0 my $info = $self->info($post_fullname);
717 0         0 return sprintf "%s%s%s", $LINK_URL, $info->{permalink}, $commentid;
718             }
719              
720             sub find_subreddits {
721 0     0 1 0 my ($self, %param) = @_;
722              
723 0         0 my $query = $self->set_listing_defaults(%param);
724 0   0     0 $query->{q} = $param{q} || croak "expected 'q'";
725 0   0     0 $query->{sort} = $param{sort} || 'relevance';
726              
727 0         0 my $result = $self->api_json_request(
728             api => API_SUB_SEARCH,
729             data => $query,
730             );
731             return [
732 0         0 map { Reddit::Client::SubReddit->new($self, $_->{data}) } @{$result->{data}{children}}
  0         0  
  0         0  
733             ];
734             }
735              
736             # should first arg be id?
737             sub duplicates {
738 0     0 1 0 my ($self, $id, %param) = @_;
739 0         0 $id = id($id); # strip permalink code if it exists
740 0         0 my $query = $self->set_listing_defaults(%param);
741 0 0       0 $query->{crossposts_only} = $param{crossposts_only} ? 'true' : 'false';
742 0         0 $query->{sort} = 'num_comments';
743 0 0       0 $query->{sort} = $param{sort} if $param{sort};
744 0 0 0     0 $query->{sr} = $param{subreddit}||$param{sub} if $param{subreddit}||$param{sub}; # optional?
      0        
745 0         0 $query->{article} = $id; # specification has it both in URL and here, /shrug
746              
747 0         0 my $args = [$id];
748              
749 0         0 my $result = $self->api_json_request(
750             api => API_DUPLICATES,
751             args => $args,
752             data => $query,
753             );
754             # Reddit returns two listings: a listing with a single element of the
755             # requested post, and a second listing with the matches. Reddit::Client only
756             # returns the second listing, assuming the user already has the first or can
757             # access it.
758              
759             return [
760 0         0 map { Reddit::Client::Link->new($self, $_->{data}) } @{$$result[1]{data}{children}}
  0         0  
  0         0  
761             ];
762             }
763              
764             sub fetch_links {
765 0     0 0 0 my ($self, %param) = @_;
766 0   0     0 my $subreddit = $param{sub} || $param{subreddit} || '';
767 0   0     0 my $view = $param{view}|| VIEW_DEFAULT;
768              
769 0         0 my $query = $self->set_listing_defaults(%param);
770              
771 0         0 $subreddit = subreddit($subreddit);
772              
773 0         0 my $args = [$view];
774 0 0       0 unshift @$args, $subreddit if $subreddit;
775              
776             #$API[API_LINKS_OTHER ] = ['GET', '/%s' ];
777             #$API[API_LINKS_FRONT ] = ['GET', '/r/%s/%s' ];
778             # this is backwards? front is actually a specific sub, other is front page
779 0 0       0 my $result = $self->api_json_request(
780             api => ($subreddit ? API_LINKS_FRONT : API_LINKS_OTHER),
781             args => $args,
782             data => $query,
783             );
784             #return $result;
785              
786             return [
787 0         0 map { Reddit::Client::Link->new($self, $_->{data}) } @{$result->{data}{children}}
  0         0  
  0         0  
788             ];
789             }
790              
791             sub get_links { # alias for fetch_links to make naming convention consistent
792 0     0 1 0 my ($self, %param) = @_;
793 0         0 return $self->fetch_links(%param);
794             }
795             # Is this a better way to get a single link than a call to info?
796             sub get_links_by_id {
797 0     0 1 0 my ($self, @fullnames) = @_;
798 0 0       0 die "get_links_by_id: argument 1 (\@fullnames) is required.\n" unless @fullnames;
799 0         0 @fullnames = map { fullname($_, 't3') } @fullnames;
  0         0  
800 0         0 my $str = join ",", @fullnames;
801             # what the fuck is this?
802 0         0 my $result = $self->json_request('GET', $API[API_BY_ID][1]."/$str");
803              
804             return [
805 0         0 map { Reddit::Client::Link->new($self, $_->{data}) } @{$result->{data}{children}}
  0         0  
  0         0  
806             ];
807             }
808              
809             sub get_link {
810 0     0 1 0 my ($self, $fullname) = @_;
811 0 0       0 die "get_link: need arg 1 (id/fullname)" unless $fullname;
812              
813 0         0 $fullname = fullname($fullname, 't3');
814 0         0 my $result = $self->json_request('GET', $API[API_BY_ID][1]."/$fullname");
815             # empty return is caused by purged post, not error on our part
816 0         0 return Reddit::Client::Link->new($self, $result->{data}{children}[0]{data});
817             }
818              
819             sub get_comment {
820 0     0 1 0 my ($self, $fullname, %param) = @_;
821 0 0       0 croak "expected argument 1: id or fullname" unless $fullname;
822              
823 0         0 $fullname = fullname($fullname, 't1');
824 0         0 my $info = $self->info($fullname);
825 0 0       0 return unless $info;
826              
827 0         0 my $cmt = Reddit::Client::Comment->new($self, $info);
828 0 0 0     0 if ($param{include_children} and $cmt->{permalink}) {
829 0         0 $cmt = $self->get_comments(permalink=>$cmt->{permalink});
830 0         0 $cmt = $$cmt[0];
831             }
832 0         0 return $cmt;
833             }
834              
835             sub get_subreddit_comments {
836 0     0 1 0 my ($self, %param) = @_;
837 0   0     0 my $subreddit = $param{sub} || $param{subreddit} || '';
838 0   0     0 my $view = $param{view} || VIEW_DEFAULT;
839              
840 0         0 my $query = {};
841 0 0       0 $query->{before} = $param{before} if $param{before};
842 0 0       0 $query->{after} = $param{after} if $param{after};
843 0 0 0     0 if (exists $param{limit}) { $query->{limit} = $param{limit} || 500; }
  0         0  
844 0         0 else { $query->{limit} = DEFAULT_LIMIT; }
845              
846 0         0 $subreddit = subreddit($subreddit); # remove slashes and leading r/
847 0 0       0 my $args = $subreddit ? [$subreddit] : [];
848              
849 0 0       0 my $result = $self->api_json_request(
850             api => ($subreddit ? API_COMMENTS : API_COMMENTS_FRONT),
851             args => $args,
852             data => $query,
853             );
854              
855             #return $result;
856             #return $result->{data}{children}[0]->{data};
857             return [
858 0         0 map {Reddit::Client::Comment->new($self, $_->{data})} @{$result->{data}{children}}
  0         0  
  0         0  
859             ];
860             }
861              
862             #=============================================================
863             # Moderation
864             #=============================================================
865             sub remove {
866 0     0 1 0 my $self = shift;
867 0   0     0 my $fullname = shift || die "remove: arg 1 (fullname) is required.\n";
868            
869 0         0 my $result = $self->api_json_request(
870             api => API_REMOVE,
871             data => { id => $fullname, spam=> 'false' },
872             );
873 0         0 return $result;
874             }
875             # like remove, but sets spam flag
876             sub spam {
877 0     0 0 0 my $self = shift;
878 0   0     0 my $fullname = shift || croak "spam: arg 1 (fullname) is required.\n";
879            
880 0         0 my $result = $self->api_json_request(
881             api => API_REMOVE,
882             data => { id => $fullname, spam => 'true' },
883             );
884 0         0 return $result;
885             }
886             sub approve {
887 0     0 1 0 my $self = shift;
888 0   0     0 my $fullname = shift || die "approve: arg 1 (fullname) is required.\n";
889            
890 0         0 my $result = $self->api_json_request(
891             api => API_APPROVE,
892             data => { id => $fullname },
893             );
894 0         0 return $result;
895             }
896             sub ignore_reports {
897 0     0 1 0 my $self = shift;
898 0   0     0 my $fullname = shift || die "ignore_reports: arg 1 (fullname) is required.\n";
899            
900 0         0 my $result = $self->api_json_request(
901             api => API_IGNORE_REPORTS,
902             data => { id => $fullname },
903             );
904 0         0 return $result;
905             }
906             sub lock {
907 0     0 1 0 my ($self, $fullname, %param) = @_;
908 0 0       0 die "lock: arg 1 (fullname) is required.\n" unless $fullname;
909              
910 0 0 0     0 if (!ispost($fullname) and !iscomment($fullname)) {
911 0         0 die "lock: arg 1 must be a fullname of a post or comment.\n";
912             }
913              
914 0 0       0 my $lock = exists $param{lock} ? $param{lock} : 1;
915              
916 0 0       0 my $result = $self->api_json_request(
917             api => $lock ? API_LOCK : API_UNLOCK,
918             data => { id => $fullname },
919             );
920 0         0 return $result;
921             }
922             sub unlock {
923 0     0 1 0 my ($self, $fullname, %param) = @_;
924            
925 0         0 return $self->lock($fullname, lock=>0);
926             }
927             sub nsfw {
928 0     0 1 0 my ($self, $fullname, %param) = @_;
929 0 0       0 die "nsfw: arg 1 (fullname) is required.\n" unless $fullname;
930              
931 0 0       0 if (!ispost($fullname)) {
932 0         0 die "nsfw: arg 1 must be a fullname of a post or comment.\n";
933             }
934              
935 0 0       0 my $nsfw = exists $param{nsfw} ? $param{nsfw} : 1;
936              
937 0 0       0 my $result = $self->api_json_request(
938             api => $nsfw ? API_MARKNSFW : API_UNMARKNSFW,
939             data => { id => $fullname },
940             );
941 0         0 return $result;
942             }
943             sub unnsfw {
944 0     0 1 0 my ($self, $fullname, %param) = @_;
945            
946 0         0 return $self->nsfw($fullname, nsfw=>0);
947             }
948             # -ban is really a call to friend, which creates relationships between accounts.
949             # other functions can call it and pass in a different mode (see functions below)
950             # this is to make it just as unreadable as Reddit's endpoint
951             # TODO: make this a general fn, call ban from outside like modinvite is
952             #
953             # -ban uses the "modcontributors" oauth scope EXCEPT:
954             # -moderator and moderator_invite use "modothers"
955             # -wikibanned and wikicontributor require both modcontributors and modwiki
956             # https://old.reddit.com/dev/api/#POST_api_friend
957             #
958             sub ban {
959 0     0 1 0 my ($self, %param) = @_;
960 0   0     0 my $sub = $param{sub} || $param{subreddit} || die "subreddit is required\n";
961            
962 0         0 my $data = {};
963 0   0     0 $data->{name} = $param{user} || $param{username} || die "username is required\n";
964             # ban_context = fullname (of what?) - not required
965              
966             # Ban message
967 0 0       0 $data->{ban_message} = $param{ban_message} if $param{ban_message};
968             # Reason: short report reason
969 0 0       0 if ($param{reason}) {
970 0 0       0 if (length $param{reason} > 100) {
971 0         0 print "Warning: 'reason' longer than 100 characters. Truncating.\n";
972 0         0 $param{reason} = substr $param{reason}, 0, 100;
973             }
974 0         0 $data->{ban_reason} = $param{reason};
975             }
976              
977 0 0       0 if ($param{note}) {
978 0 0       0 if (length $param{note} > 300) {
979 0         0 print "Warning: 'note' longer than 300 characters. Truncating.\n";
980 0         0 $param{note} = substr $param{note}, 0, 300;
981             }
982 0         0 $data->{note} = $param{note};
983             }
984              
985 0 0       0 if ($param{duration}){ # if 0 this never even hits which we want anyway
986 0 0       0 if ($param{duration} > 999) {
    0          
987 0         0 print "Warning: Max duration is 999. Setting to 999.\n";
988 0         0 $param{duration} = 999;
989             } elsif ($param{duration} < 1) {
990 0         0 $param{duration} = 0;
991             }
992 0 0       0 $data->{duration} = $param{duration} if $param{duration};
993             }
994             # $data->{container} is not needed unless mode is friend or enemy
995             # from docs for unfriend https://old.reddit.com/dev/api/#POST_api_unfriend:
996             # The user can either be passed in by name (nuser) or by fullname (iuser). If type is friend or enemy, 'container' MUST be the current user's fullname; for other types, the subreddit must be set via URL (e.g., /r/funny/api/unfriend)
997             # So what would the arg be? /r//api/friend?
998             # Unfriend has its own endpoint too
999             # $data->{permissions} = ?
1000              
1001             # type is one of (friend, moderator, moderator_invite, contributor, banned, muted, wikibanned, wikicontributor)
1002 0 0       0 if ($param{mode} eq 'mute') {
    0          
    0          
1003 0         0 $data->{type} = 'muted';
1004             } elsif ($param{mode} eq 'contributor') {
1005 0         0 $data->{type} = 'contributor';
1006             } elsif ($param{mode} eq 'moderator_invite') {
1007             #print "modinvite\n";
1008 0         0 $data->{type} = 'moderator_invite';
1009             } else {
1010 0         0 $data->{type} = 'banned';
1011             }
1012              
1013 0         0 my $result = $self->api_json_request(
1014             api => API_BAN,
1015             args => [$sub],
1016             data => $data,
1017             );
1018 0         0 return $result;
1019             }
1020              
1021             sub mute {
1022 0     0 1 0 my ($self, %param) = @_;
1023 0         0 $param{mode} = 'mute';
1024 0         0 return $self->ban(%param);
1025             }
1026              
1027             sub add_approved_user {
1028 0     0 0 0 my ($self, %param) = @_;
1029 0         0 $param{mode} = 'contributor';
1030 0         0 return $self->ban(%param);
1031             }
1032             # more sensible version of add_approved_user
1033             sub approve_user {
1034 0     0 1 0 my ($self, $user, $sub, $unapprove) = @_;
1035 0         0 my %param;
1036 0   0     0 $param{username} = $user || die "approve_user: arg 1 (username) is required.\n";
1037 0   0     0 $param{subreddit} = $sub || die "approve_user: arg 2 (sub) is required.\n";
1038 0         0 $param{mode} = 'contributor';
1039 0 0       0 unless ($unapprove) {
1040 0         0 return $self->ban(%param);
1041             } else {
1042 0         0 return $self->unban(%param);
1043             }
1044             }
1045             sub unapprove_user {
1046 0     0 1 0 my ($self, $user, $sub) = @_;
1047 0 0       0 if (!$user){ die "unapprove_user: arg 1 (username) is required.\n" }
  0         0  
1048 0 0       0 if (!$sub) { die "unapprove_user: arg 2 (sub) is required.\n" }
  0         0  
1049 0         0 return $self->approve_user($user, $sub, 1);
1050             }
1051             # Requires scope 'modothers'
1052             sub invite_moderator {
1053 0     0 0 0 my ($self, %param) = @_;
1054 0         0 $param{mode} = 'moderator_invite';
1055 0         0 return $self->ban(%param);
1056             }
1057             # so we already had a function to do this and we wrote another one
1058             sub invite_mod {
1059 0     0 0 0 my ($this, $sub, $user) = @_;
1060              
1061 0         0 return $this->ban( # excellent naming of that function, bravo
1062             user => $user,
1063             sub => $sub,
1064             mode => 'moderator_invite',
1065             );
1066             }
1067              
1068             sub unban {
1069 0     0 1 0 my ($self, %param) = @_;
1070 0   0     0 my $sub = $param{sub} || $param{subreddit} || die "subreddit is required\n";
1071            
1072 0         0 my $data = {};
1073 0   0     0 $data->{name} = $param{username} || die "username is required\n";
1074             # ban_context = fullname, but of what - not required
1075              
1076 0 0       0 if ($param{mode} eq 'mute') {
    0          
1077 0         0 $data->{type} = 'muted';
1078             } elsif ($param{mode} eq 'contributor') {
1079 0         0 $data->{type} = 'contributor';
1080             } else {
1081 0         0 $data->{type} = 'banned';
1082             }
1083              
1084 0         0 my $result = $self->api_json_request(
1085             api => API_UNBAN,
1086             args => [$sub],
1087             data => $data,
1088             );
1089 0         0 return $result;
1090             }
1091              
1092             sub unmute {
1093 0     0 1 0 my ($self, %param) = @_;
1094 0         0 $param{mode} = 'mute';
1095 0         0 return $self->unban(%param);
1096             }
1097              
1098             sub distinguish {
1099 0     0 1 0 my ($self, $fullname, %param) = @_;
1100 0         0 my $data = {};
1101              
1102 0 0 0     0 if (!iscomment($fullname) and !ispost($fullname)) {
1103 0         0 die 'Fullname is required (comment preceeded by "t1_", post "t3_")';
1104             }
1105              
1106 0 0       0 if (iscomment($fullname)) {
1107             # only top level can be sticky
1108 0 0       0 my $sticky = exists $param{sticky} ? $param{sticky} : 0;
1109 0 0       0 $data->{sticky} = $sticky ? 'true' : 'false';
1110             }
1111              
1112 0         0 $data->{id} = $fullname;
1113              
1114              
1115 0         0 $data->{how} = 'yes';
1116             # Check manual setting of 'how'. Normal users should never set 'how'.
1117 0 0       0 if ($param{how}) {
1118 0         0 my @valid = qw/yes no admin special/;
1119 0         0 my $ok;
1120 0         0 for (@valid) {
1121 0 0       0 if ($param{how} eq $_) {
1122 0         0 $ok = 1;
1123 0         0 last; # because we have to save potentially TWO CYCLES, right asshole? yeah spend all day on 2 cycles, that's a good use of your time
1124             }
1125             }
1126              
1127 0 0       0 die "valid values for 'how' are: yes, no, admin, special\n" unless $ok;
1128             }
1129            
1130 0         0 my $result = $self->api_json_request(
1131             api => API_DISTINGUISH,
1132             data => $data,
1133             );
1134 0         0 return $result;
1135             }
1136              
1137             sub undistinguish {
1138 0     0 1 0 my ($self, $fullname, %param) = @_;
1139 0         0 my $data = {};
1140              
1141 0 0 0     0 if (!iscomment($fullname) and !ispost($fullname)) {
1142 0         0 die 'Fullname is required (comment preceeded by "t1_", post "t3_")';
1143             }
1144              
1145 0         0 $data->{id} = $fullname;
1146 0         0 $data->{how} = 'no';
1147              
1148 0         0 my $result = $self->api_json_request(
1149             api => API_UNDISTINGUISH,
1150             data => $data,
1151             );
1152 0         0 return $result;
1153             }
1154              
1155             # https://old.reddit.com/dev/api/#POST_api_report
1156             # Send a report. Don't know what most of these fields do. made them all optional
1157             sub report {
1158 0     0 0 0 my ($this, %param) = @_;
1159              
1160             # Nearly all optional until we know what they do lol
1161 0         0 my $data = {};
1162             # is sub required, tho? Not for a sitewide report
1163             # required here so we don't accidentally send a sitewide report
1164 0 0       0 $data->{custom_text} = $param{custom_text} if $param{custom_text};
1165 0 0       0 $data->{from_help_desk} = bool($param{from_help_desk}) if exists $param{from_help_desk};
1166 0 0       0 $data->{from_modmail} = bool($param{from_modmail}) if exists $param{from_modmail};
1167              
1168 0 0       0 $data->{modmail_conv_id}= $param{modmail_conv_id} if $param{modmail_conv_id};
1169 0 0       0 $data->{other_reason} = $param{other_reason} if $param{other_reason};
1170 0 0       0 $data->{reason} = $param{reason} if $param{reason};
1171 0 0       0 $data->{rule_reason} = $param{rule_reason} if $param{rule_reason};
1172 0 0       0 $data->{site_reason} = $param{site_reason} if $param{site_reason};
1173             #$data->{sr_name} = $param{sub} || $param{subreddit} || croak "sub or subreddit is required."; # API says sr_name can be 1000 characters?
1174 0 0 0     0 $data->{sr_name} = $param{sub}||$param{subreddit} if $param{sub}||$param{subreddit};
      0        
1175 0   0     0 my $id = $param{id}||$param{fullname} || croak "fullname (alias id) is required";
1176 0 0       0 croak "fullname (alias id) must be a fullname" unless $id =~ /^t[0-9]_/;
1177 0         0 $data->{thing_id} = $id;
1178            
1179             #$data->{strict_freeform_reports} = bool($param{strict_freeform_reports}) if exists $param{strict_freeform_reports};
1180 0         0 $data->{strict_freeform_reports} = "true"; # see docs
1181 0 0       0 $data->{usernames} = $param{usernames} if $param{usernames}; # a comma-delimited list
1182              
1183 0         0 return $this->api_json_request(
1184             api => API_REPORT,
1185             data => $data,
1186             );
1187             }
1188              
1189             sub get_modlinks {
1190 0     0 1 0 my ($self, %param) = @_;
1191              
1192 0         0 my $query = $self->set_listing_defaults(%param);
1193 0   0     0 my $sub = $param{sub} || $param{subreddit} || 'mod';
1194 0   0     0 my $mode = $param{mode} || 'modqueue';
1195              
1196 0         0 my $result = $self->api_json_request(
1197             api => API_MODQ,
1198             args => [$sub, $mode],
1199             data => $query,
1200             );
1201              
1202             #return $result->{data};
1203              
1204             return [
1205             map {
1206              
1207             $_->{kind} eq "t1" ?
1208             Reddit::Client::Comment->new($self, $_->{data}) :
1209             Reddit::Client::Link->new($self, $_->{data})
1210 0 0       0 }
1211              
1212 0         0 @{$result->{data}{children}}
  0         0  
1213             ];
1214             }
1215             sub get_modqueue {
1216 0     0 1 0 my ($self, %param) = @_;
1217 0         0 $param{mode} = 'modqueue';
1218 0         0 return $self->get_modlinks(%param);
1219             }
1220              
1221             # Get new modmail. This returns metadata and the first message for each conver-
1222             # sation. Full conversations must be loaded separately with get_conversation
1223              
1224             # after: conversation id
1225             # entity: comma-delimited list of subreddit names
1226             # limit
1227             # sort: one of (recent, mod, user, unread)
1228             # state: one of (new, inprogress, mod, notifications, archived, highlighted, all
1229              
1230             # Returns:
1231             # conversationIds, array of conversation IDs
1232             # conversations, hash of data about the conversation, keys are conversation IDs
1233             # -subject
1234             # -numMessages
1235             # -state - corresponds to state arg?
1236             # -authors, array of hashes of information about each author
1237             # -participant, hash of info about the user from the top message?
1238             # -owner, hash of info about the sub
1239             sub get_modmail {
1240 0     0 0 0 my ($self, %param) = @_;
1241              
1242 0         0 my $data = {};
1243 0   0     0 $data->{sort} = $param{sort} || 'unread';
1244 0   0     0 $data->{state} = $param{state} || 'all';
1245 0 0       0 $data->{after} = $param{after} if $param{after};
1246 0 0       0 $data->{limit} = exists $param{limit} ? ( $param{limit} ? $param{limit} : 500 ) : DEFAULT_LIMIT;
    0          
1247              
1248 0   0     0 my $subs = $param{entity} || $param{subreddits} || $param{subs};
1249 0 0       0 if ($subs) {
1250 0 0       0 $subs = join ",", @$subs if ref $subs eq 'ARRAY';
1251 0 0       0 $data->{entity} = $subs if $subs;
1252             }
1253 0         0 my $result = $self->api_json_request(
1254             api => API_GET_MODMAIL,
1255             data => $data,
1256             );
1257 0         0 return $result;
1258             }
1259              
1260             # GET /api/mod/conversations/:conversation_id
1261             # Returns all messages, mod actions and conversation metadata for id
1262             # conversation_id base36 modmail conversation id
1263             # markRead boolean
1264              
1265             sub get_conversation {
1266 0     0 0 0 my ($this, $id, %param) = @_;
1267              
1268             }
1269              
1270             # "This endpoint will create a ModmailConversation object as well as the first ModmailMessage within the ModmailConversation object."
1271             sub new_modmail_conversation {
1272 0     0 1 0 my ($this, %param) = @_;
1273 0         0 my $data = {};
1274              
1275 0   0     0 $data->{body} = $param{body} || croak "new_modmail_conversation: body is required.";
1276             # Unlike Reddit's functionality, this hides the author name by default
1277             my $auth = exists $param{isAuthorHidden} ? $param{isAuthorHidden} :
1278 0 0       0 ( exists $param{hide_author} ? $param{hide_author} : 1 );
    0          
1279             #$data->{isAuthorHidden} = exists $param{isAuthorHidden} ? ( $param{isAuthorHidden} ? "true" : "false" ) : "true";
1280 0 0       0 $data->{isAuthorHidden} = $auth ? "true" : "false";
1281 0   0     0 $data->{srName} = $param{subreddit} || $param{sub} || $param{srName} || croak "new_modmail_conversation: subreddit is required (also accepts aliases 'sub' and 'srName')";
1282 0   0     0 my $subj = $param{subject} || croak "new_modmail_conversation: subject is required";
1283 0 0       0 if (length $subj > 100) {
1284 0         0 print "new_modmail_conversation: subject truncated to 100 characters.\n";
1285 0         0 $subj = substr $subj, 0, 100;
1286             }
1287 0         0 $data->{subject} = $subj;
1288              
1289             # users only or can subreddit be target?
1290 0   0     0 $data->{to} = $param{to} || croak "new_modmail_conversation: fullname is required.";
1291             #$fullname = fullname
1292             # body, isAuthorHidden, srName, subject=100 chars, to=fullname
1293             # documentation is WRONG. to is not a fullname, it's just a username
1294 0         0 my $result = $this->api_json_request(
1295             api => API_NEW_MM_CONV,
1296             data => $data,
1297             );
1298 0 0       0 if (ref $result eq 'HASH') {
1299 0         0 return new Reddit::Client::ModmailConversation($this, $result->{conversation}, $result->{messages}, $result->{modActions});
1300             }
1301 0         0 return $result;
1302             }
1303              
1304             sub sticky_post {
1305 0     0 0 0 my ($this, $id, %opt) = @_;
1306 0         0 my $data = {};
1307             # docs say id but maybe they mean fullname
1308 0   0     0 $id = fullname($id, 't3') || die "sticky_post: arg 1 (id) is required.\n";
1309 0         0 $data->{id} = $id;
1310              
1311 0 0       0 if ($opt{num}) {
1312 0 0       0 if ($opt{num} =~ /^[1234]$/) {
1313 0         0 $data->{num} = $opt{num};
1314             } else {
1315 0         0 print "sticky_post: option 'num' must be an integer from 1-4. Unsetting.\n";
1316             }
1317             }
1318            
1319 0 0       0 $data->{state} = exists $opt{sticky} ? ($opt{sticky} ? "true" : "false") : "true";
    0          
1320 0 0       0 $data->{to_profile} = exists $opt{to_profile} ? ($opt{to_profile} ? "true" : "false") : "false";
    0          
1321              
1322 0         0 return $this->api_json_request(
1323             api => API_STICKY_POST,
1324             data => $data,
1325             );
1326              
1327             }
1328              
1329             #=============================================================
1330             # New modmail functions
1331             # most use the same URL format so we should make a central function
1332              
1333             # Sub for many modmail actions
1334             # these actions take no args, just the action
1335             # TODO: call these from ModmailConversation
1336             sub modmail_action {
1337 0     0 0 0 my ($this, $action, $id) = @_;
1338 0 0 0     0 croak "args 1 and 2 (action and id) are required" unless $action and $id;
1339 0         0 $action = lc $action;
1340              
1341             # Choose MM_POST_ACTION or MM_GET_ACTION
1342             # POST: bulk_read, approve (?), archive, disapprove (?), highlight,
1343             # unarchive, unban, unmute
1344              
1345             # POST: read and unread take single arg
1346              
1347             # POST: mute takes hours, has own function
1348             # POST: temp_ban takes duration, support elsehwere
1349              
1350             # only hightlight uses DELETE, not supporting
1351 0         0 my @post_actions = qw/bulk_read approve archive disapprove highlight unarchive unban unmute /;
1352 0         0 my $api;
1353 0         0 for (@post_actions) {
1354 0 0       0 if ($action eq $_) {
1355 0         0 $api = API_MM_POST_ACTION;
1356 0         0 last;
1357             }
1358             }
1359 0 0       0 croak "'$action' is not a recognized action. only POST actions are implemented at this time." unless $api;
1360              
1361              
1362 0         0 return $this->api_json_request(
1363             api => $api,
1364             args => [$id, $action],
1365             );
1366             }
1367              
1368              
1369             # num_hours one of (72, 168, 672)
1370             sub modmail_mute {
1371 0     0 0 0 my ($this, $id, $length) = @_;
1372 0   0     0 $length ||= 72;
1373              
1374             # We should accept days too
1375 0 0 0     0 if ($length == 3 or $length == 7 or $length == 28) {
    0 0        
      0        
      0        
1376 0         0 $length *= 24;
1377             } elsif ($length != 72 and $length != 168 and $length != 672) {
1378 0         0 die "arg 2 (length) must be 3, 7, or 28 days (or 72, 168, or 672 hours)\n";
1379             }
1380              
1381 0         0 my $data = { num_hours => $length };
1382 0         0 my $args = [ $id ];
1383              
1384 0         0 return $this->api_json_request(
1385             api => API_MM_MUTE,
1386             args => $args,
1387             data => $data,
1388             );
1389             }
1390              
1391             #=============================================================
1392             # Users
1393             #=============================================================
1394             sub get_user {
1395             #my ($self, %param) = @_;
1396             #$user = $param{user} || $param{username} || croak "expected 'user'";
1397             #$view = $param{view} || 'overview';
1398 0     0 1 0 my $self = shift;
1399 0         0 my ($user, $view, %param);
1400              
1401             # old ver: user=>$user, view=>$view
1402             # what if someone passes in another key?
1403             # this fails with unpredictable results lol
1404              
1405             # even elements = old way, odd = new way
1406 0         0 my $odd = scalar(@_) % 2;
1407 0 0 0     0 if (!$odd or $_[0] eq 'user' or $_[0] eq 'username' or $_[0] eq 'view') {
      0        
      0        
1408 0         0 print "This form of get_user is deprecated. A future version will take the following simplified argument structure: get_user(\$username, \%params)\n";
1409 0         0 %param = @_;
1410 0   0     0 $user = $param{user} || $param{username} || croak "expected 'user'";
1411             } else {
1412             # new ver: $user, %params
1413 0         0 $user = shift;
1414 0         0 %param= @_;
1415             }
1416              
1417 0   0     0 $view = $param{view} || 'overview';
1418              
1419             # This can accept limit as data? are all GET string args sent as data?
1420 0         0 my $data = $self->set_listing_defaults(%param);
1421              
1422 0         0 my $args = [$user, $view];
1423              
1424             # $API[API_USER ] = ['GET', '/user/%s/%s' ];
1425             # view is different here; would need third arg, 'sort=new'
1426             # /user/TheUser/submitted?sort=new
1427 0         0 my $result = $self->api_json_request(
1428             api => API_USER,
1429             args => $args,
1430             data => $data,
1431             );
1432              
1433 0 0       0 if ($view eq 'about') {
1434 0         0 return Reddit::Client::Account->new($self, $result->{data});
1435             }
1436              
1437             return [
1438             map {
1439              
1440             $_->{kind} eq "t1" ?
1441             Reddit::Client::Comment->new($self, $_->{data}) :
1442             Reddit::Client::Link->new($self, $_->{data})
1443 0 0       0 }
1444              
1445 0         0 @{$result->{data}{children}}
  0         0  
1446             ];
1447             }
1448             #===============================================================================
1449             # Change posts or comments
1450             #===============================================================================
1451              
1452             sub edit {
1453 0     0 1 0 my ($self, $name, $text) = @_;
1454 0         0 my $type = substr $name, 0, 2;
1455 0 0 0     0 croak 'Argument 1 ($fullname) must be a post or comment.' if $type ne 't1' && $type ne 't3';
1456 0 0       0 croak 'Argument 2 (text) is required. Empty strings are allowed.' unless defined $text;
1457              
1458 0         0 my $data = {
1459             thing_id => $name,
1460             text => $text
1461             };
1462              
1463 0         0 my $result = $self->api_json_request(
1464             api => API_EDIT,
1465             data => $data,
1466             );
1467 0         0 return $result->{data}{things}[0]{data}{name};
1468             }
1469              
1470             sub delete {
1471 0     0 1 0 my ($self, $name) = @_;
1472 0 0       0 croak 'Expected $fullname' if !$name;
1473 0         0 my $type = substr $name, 0, 2;
1474 0 0 0     0 croak '$fullname must be a post or comment' if $type ne 't1' && $type ne 't3';
1475              
1476 0         0 DEBUG('Delete post/comment %s', $name);
1477              
1478 0         0 my $result = $self->api_json_request(api => API_DEL, data => { id => $name });
1479 0         0 return $result;
1480             }
1481              
1482             #===============================================================================
1483             # Submitting links
1484             #===============================================================================
1485              
1486             sub submit_link {
1487 0     0 1 0 my ($self, %param) = @_;
1488             # why is sub allowed to be empty?
1489 0   0     0 my $subreddit = $param{subreddit} || $param{sub} || '';
1490 0   0     0 my $title = $param{title} || croak 'Expected "title"';
1491 0   0     0 my $url = $param{url} || croak 'Expected "url"';
1492 0 0       0 my $replies = exists $param{inbox_replies} ? ($param{inbox_replies} ? "true" : "false") : "true";
    0          
1493 0 0       0 my $repost = exists $param{repost} ? ($param{repost} ? "true" : "false") : "false";
    0          
1494 0 0       0 my $nsfw = exists $param{nsfw} ? ($param{nsfw} ? "true" : "false") : "false";
    0          
1495              
1496 0         0 DEBUG('Submit link to %s: %s', $subreddit, $title, $url);
1497              
1498 0         0 $subreddit = subreddit($subreddit);
1499              
1500 0         0 my $result = $self->api_json_request(api => API_SUBMIT, data => {
1501             title => $title,
1502             url => $url,
1503             sr => $subreddit,
1504             kind => SUBMIT_LINK,
1505             sendreplies => $replies,
1506             resubmit => $repost,
1507             nsfw => $nsfw,
1508             });
1509              
1510 0         0 return $result->{data}{name};
1511             }
1512              
1513             sub submit_crosspost {
1514 0     0 1 0 my ($self, %param) = @_;
1515             # why is subreddit allowed to be empty?
1516 0   0     0 my $subreddit = $param{subreddit} || $param{sub} || die "expected 'subreddit'\n";
1517 0   0     0 my $title = $param{title} || die "Expected 'title'\n";
1518 0   0     0 my $source_id = $param{source_id} || die "Expected 'source_id'\n";
1519 0 0       0 $source_id = "t3_$source_id" if lc substr($source_id, 0, 3) ne 't3_';
1520             #my $url = $param{url} || croak 'Expected "url"';
1521 0 0       0 my $replies = exists $param{inbox_replies} ? ($param{inbox_replies} ? "true" : "false") : "true";
    0          
1522 0 0       0 my $repost = exists $param{repost} ? ($param{repost} ? "true" : "false") : "false";
    0          
1523              
1524 0         0 $subreddit = subreddit($subreddit);
1525              
1526 0         0 my $result = $self->api_json_request(api => API_SUBMIT, data => {
1527             title => $title,
1528             #url => $url,
1529             crosspost_fullname => $source_id,
1530             sr => $subreddit,
1531             kind => SUBMIT_CROSSPOST,
1532             sendreplies => $replies,
1533             resubmit => $repost,
1534             });
1535              
1536 0         0 return $result->{data}{name};
1537             }
1538              
1539             sub submit_text {
1540 0     0 1 0 my ($self, %param) = @_;
1541 0   0     0 my $subreddit = $param{subreddit} || $param{sub} || die "expected 'subreddit'\n";
1542 0   0     0 my $title = $param{title} || croak 'Expected "title"';
1543 0   0     0 my $text = $param{text} || "";#croak 'Expected "text"';
1544             # true and false have to be the strings "true" or "false"
1545 0 0       0 my $replies = exists $param{inbox_replies} ? ($param{inbox_replies} ? "true" : "false") : "true";
    0          
1546              
1547 0         0 DEBUG('Submit text to %s: %s', $subreddit, $title);
1548              
1549 0         0 $subreddit = subreddit($subreddit);
1550              
1551 0         0 my $result = $self->api_json_request(api => API_SUBMIT, data => {
1552             title => $title,
1553             text => $text,
1554             sr => $subreddit,
1555             kind => SUBMIT_SELF,
1556             sendreplies=>$replies,
1557             });
1558              
1559 0         0 return $result->{data}{name};
1560             }
1561             # These could go in the user section or here, but it seems like it will be
1562             # more commonly used for flairing posts
1563             sub template {
1564 0     0 0 0 my ($self, %param) = @_;
1565 0         0 my $data = {}; # POST data
1566 0         0 my $url_arg; # arguments that get interpolated into the URL
1567            
1568 0         0 my $result = $self->api_json_request(
1569             api => API_FLAIR,
1570             args => [$url_arg],
1571             data => $data
1572             );
1573             }
1574              
1575             # flair a post, not using an existing template, just manually providing the
1576             # text and CSS class
1577             sub flair_post {
1578 0     0 1 0 my ($self, %param) = @_;
1579 0   0     0 my $link_fullname = $param{link_id} || $param{post_id} || die "flair_post: need 'link_id'\n";
1580 0         0 $link_fullname = fullname($link_fullname, 't3');
1581 0   0     0 my $subreddit = $param{sub} || $param{subreddit} || die "flair_post: need 'subreddit'\n";
1582             # Initializing $text to '' here was accidentally preventing a concatenation
1583             # warning from Request
1584 0 0       0 my $text = $param{text} ? substr($param{text}, 0, 64) : '';
1585 0         0 my $css_class = $param{css_class}; # optional
1586              
1587 0         0 my $data = { link => $link_fullname };
1588 0 0       0 $data->{text} = $text if $text;
1589 0 0       0 $data->{css_class} = $css_class if $css_class;
1590              
1591 0         0 my $result = $self->api_json_request(
1592             api => API_FLAIR,
1593             args => [$subreddit],
1594             data => $data
1595             );
1596             }
1597             sub flair_link {
1598 0     0 1 0 my ($self, %param) = @_;
1599 0         0 return $self->flair_post(%param);
1600             }
1601              
1602             # flair a user, not using an existing template, just manually providing the
1603             # text and CSS class
1604             sub flair_user {
1605 0     0 1 0 my ($self, %param) = @_;
1606 0   0     0 my $username = $param{username} || die "flair_user: need 'link_id'\n";
1607 0 0       0 my $text = $param{text} ? substr($param{text}, 0, 64) : '';
1608 0         0 my $css_class = $param{css_class}; #optional
1609 0   0     0 my $subreddit = $param{sub} || $param{subreddit} || die "flair_user: need 'subreddit'\n";
1610              
1611 0         0 my $data = { name => $username };
1612 0 0       0 $data->{text} = $text if $text;
1613 0 0       0 $data->{css_class} = $css_class if $css_class;
1614              
1615 0         0 my $result = $self->api_json_request(
1616             api => API_FLAIR,
1617             args => [$subreddit],
1618             data => $data
1619             );
1620              
1621             }
1622              
1623             sub set_post_flair { # select_flair alias
1624             #sub select_flair {
1625 0     0 1 0 my ($self, %param) = @_;
1626             #return $self->set_post_flair(%param);
1627 0         0 return $self->select_flair(%param);
1628             }
1629             # select_flair can apply flair which appears styled in multi views (such as
1630             # r/all, your homepage, and both kinds of multis).
1631             # Flair applied through other methods has no style in multi views.
1632             # view sub newred | sub oldred | multi view
1633             # Apply manually new reddit x x
1634             # API x x
1635             # Automod applies x x! x
1636             #
1637             # -New reddit and multis always ignore CSS class
1638             # -Old reddit will have the new style IF it is applied by Automod and IF it has
1639             # no css_class. Otherwise it uses old styles like usual.
1640             # -If a css_class is added by any means, old reddit will lose new styles.
1641             # -If you alter the flair in any way through either the old or new interface,
1642             # old reddit will lose the new style.
1643             # -If text is altered with flair_link, old reddit will lose new styles.
1644             # - Multi view (same as r/all view) seems to show whatever new reddit does.
1645             # - text_color and background_color seem to have no effect on anything.
1646             #
1647             # Flair will use values from the flair selection as defaults. Some can only be
1648             # set through the new interface or the API.
1649             #
1650             # It looks like flair templates with a background_color attempt to hard code the
1651             # background color - that is, they use style="" tags. There is no way to do this
1652             # with old reddit, only API and new. The override_css option in /r/api/flairtemplate2 may be related.
1653             #sub set_post_flair { # select_flair alias
1654             sub select_flair {
1655 0     0 1 0 my ($self, %param) = @_;
1656 0         0 my $errmsg = "select_flair: 'subreddit' and 'flair_template_id' (or alias 'flair_id') are required.\n";
1657 0   0     0 my $sub = $param{sub} || $param{subreddit} || die $errmsg;
1658 0   0     0 my $flairid = $param{flair_template_id} || $param{flair_id} || die $errmsg;
1659 0   0     0 my $post_id = $param{link_id} || $param{post_id};
1660              
1661             # This doesn't use LINK_FLAIR or USER_FLAIR, it watches for link id or usern
1662 0 0 0     0 if (!$post_id and !$param{username}) {
    0          
1663 0         0 die "select_flair: either 'link_id' or 'username' is required.\n";
1664             } elsif ($post_id) {
1665 0         0 $post_id = fullname($post_id, 't3');
1666             }
1667              
1668 0         0 my $textcol = $param{text_color};
1669             # putting an actual color here will be a common mistake
1670 0 0       0 if ($textcol) {
1671 0         0 $textcol = lc $textcol;
1672 0 0 0     0 if ($textcol ne 'light' and $textcol ne 'dark') {
1673 0         0 die "select_flair: if provided, text_color must be 'light' or 'dark'.\n";
1674             }
1675             }
1676              
1677 0         0 my $data = {};
1678              
1679 0 0       0 $data->{background_color} = $param{background_color} if $param{background_color};
1680 0 0       0 $data->{css_class} = $param{css_class} if $param{css_class};
1681 0         0 $data->{flair_template_id} = $flairid;
1682 0 0       0 $data->{link} = $post_id if $post_id;
1683 0 0       0 $data->{name} = $param{username} if $param{username};
1684 0 0       0 $data->{return_rtjson} = $param{return_rtjson} if $param{return_rtjson};
1685 0 0       0 $data->{text_color} = $textcol if $textcol;
1686             # if given empty string Reddit ignores the parameter-- i.e. you can't do
1687             # tricks like invisibly flair something, like you could with v1
1688             # Also passing undef here gives a concatenation error in Request
1689 0   0     0 $data->{text} = $param{text} || '';
1690              
1691 0         0 my $result = $self->api_json_request(
1692             api => API_SELECTFLAIR,
1693             args => [$sub],
1694             data => $data
1695             );
1696              
1697 0         0 return $result;
1698             }
1699             sub select_user_flair {
1700 0     0 0 0 my ($self, %param) = @_;
1701 0         0 return $self->set_user_flair(%param);
1702             }
1703             sub set_user_flair {
1704 0     0 0 0 my $errmsg = "select_user_flair: keys 'subreddit', 'username', and 'flair_template_id' (or alias 'flair_id') are required.\n";
1705 0         0 my ($self, %param) = @_;
1706 0   0     0 my $sub = $param{subreddit} || die $errmsg;
1707 0   0     0 my $user = $param{username} || die $errmsg;
1708 0   0     0 my $flairid = $param{flair_template_id} || $param{flair_id} || die $errmsg;
1709 0         0 my $data = {};
1710              
1711 0         0 $data->{name} = $user;
1712 0         0 $data->{flair_template_id} = $flairid;
1713              
1714 0         0 my $result = $self->api_json_request(
1715             api => API_SELECTFLAIR,
1716             args => [$sub],
1717             data => $data
1718             );
1719              
1720 0         0 return $result;
1721             }
1722              
1723             # Return a hash reference with keys 'choices' and 'current'
1724             # 'choices' is array of hashes with flair options
1725             # 'current' is the post's current flair
1726             sub get_flair_options {
1727 0     0 1 0 my ($self, %param) = @_;
1728 0   0     0 my $sub = $param{sub} || $param{subreddit} || die "get_flair_options: 'subreddit' (or alias 'sub') is required.\n";
1729 0   0     0 my $post_id = $param{link_id} || $param{post_id};
1730 0   0     0 my $user = $param{user} || $param{name} || $param{username};
1731 0         0 my $data = {};
1732              
1733 0 0       0 if ($post_id) {
    0          
1734 0         0 $post_id = fullname($post_id, 't3');
1735 0         0 $data->{link} = $post_id;
1736             } elsif ($user) {
1737 0         0 $data->{name} = $user;
1738             } else {
1739 0         0 die "get_flair_options: Need 'post_id' or 'username'";
1740             }
1741              
1742 0         0 my $result = $self->api_json_request(
1743             api => API_FLAIROPTS,
1744             args => [$sub],
1745             data => $data,
1746             );
1747              
1748             # What's this? Fixing the booleans?
1749 0 0       0 if ($result->{choices}) {
1750 0         0 for (my $i=0; $result->{choices}[$i]; $i++) {
1751 0 0       0 $result->{choices}[$i]->{flair_text_editable} = $result->{choices}[$i]->{flair_text_editable} ? 1 : 0;
1752              
1753             }
1754             }
1755              
1756 0         0 return $result;
1757             }
1758             sub get_link_flair_options { # v2: default now
1759 0     0 1 0 my $self = shift;
1760 0   0     0 my $sub = shift || die "get_link_flair_options: Need arg 1 (subreddit)\n";
1761              
1762 0         0 my $result = $self->api_json_request(
1763             api => API_LINKFLAIRV2,
1764             args => [$sub],
1765             );
1766 0         0 return $result;
1767             }
1768             sub get_link_flair_options_v1 { # v1
1769 0     0 0 0 my $self = shift;
1770 0   0     0 my $sub = shift || die "get_link_flair_options: Need arg 1 (subreddit)\n";
1771              
1772 0         0 my $result = $self->api_json_request(
1773             api => API_LINKFLAIRV1,
1774             args => [$sub],
1775             );
1776 0         0 return $result;
1777             }
1778             sub get_user_flair_options { # v2: default now
1779 0     0 1 0 my $self = shift;
1780 0   0     0 my $sub = shift || die "get_link_flair_options: Need arg 1 (subreddit)\n";
1781              
1782 0         0 my $result = $self->api_json_request(
1783             api => API_USERFLAIRV2,
1784             args => [$sub],
1785             );
1786 0         0 return $result;
1787             }
1788             sub get_user_flair_options_v1 { # v1
1789 0     0 0 0 my $self = shift;
1790 0   0     0 my $sub = shift || die "get_link_flair_options: Need arg 1 (subreddit)\n";
1791              
1792 0         0 my $result = $self->api_json_request(
1793             api => API_USERFLAIRV1,
1794             args => [$sub],
1795             );
1796 0         0 return $result;
1797             }
1798             # uses flairtemplate_v2 endpoint, which is for new but works for old
1799             sub flairtemplate {
1800 0     0 1 0 my ($self, %param) = @_;
1801 0   0     0 my $sub = $param{sub} || $param{subreddit} || die "flairtemplate: 'subreddit' (or alias 'sub') is required.\n";
1802 0 0       0 my $bg = $param{background_color} if $param{background_color};
1803 0   0     0 my $flairid = $param{flair_template_id} || $param{flair_id} || $param{id} || undef;
1804             #my $type = $param{flair_type} || die $err;
1805 0 0       0 my $modonly = exists $param{mod_only} ? ($param{mod_only} ? 'true' : 'false') : 'false';
    0          
1806 0 0       0 my $editable= exists $param{text_editable} ? ($param{text_editable} ? 'true' : 'false') : 'false';
    0          
1807 0         0 my $textcol = $param{text_color};
1808             # putting an actual color here will be a common mistake
1809 0 0       0 if ($textcol) {
1810 0         0 $textcol = lc $textcol;
1811 0 0 0     0 if ($textcol ne 'light' and $textcol ne 'dark') {
1812 0         0 die "flairtemplate: if provided, text_color must be one of (light, dark).\n";
1813             }
1814             }
1815             # override_css is undocumented and not returned by get_link_flair_options
1816             # $override is unused here as yet
1817             #my $override= exists $param{override_css} ? ($param{override_css} ? 'true' : 'false') : 'false';
1818              
1819 0 0 0     0 if ($bg and substr($bg, 0, 1) ne '#') { $bg = "#$bg"; } #requires hash
  0         0  
1820              
1821 0         0 my $data = {};
1822 0 0       0 $data->{allowable_content} = $param{allowable_content} if $param{allowable_content};
1823 0 0       0 $data->{background_color} = $bg if $bg;
1824 0 0       0 $data->{css_class} = $param{css_class} if $param{css_class};
1825 0 0       0 $data->{max_emojis} = $param{max_emojis} if $param{max_emojis};
1826             # No documentation; presumably required for editing
1827 0 0       0 $data->{flair_template_id} = $flairid if $flairid;
1828             # api defaults to USER_FLAIR, we default to LINK_FLAIR
1829 0   0     0 $data->{flair_type} = $param{flair_type} || 'LINK_FLAIR';
1830 0 0       0 $data->{mod_only} = $modonly if exists $param{mod_only};
1831             # No documentation. Probably wants "true or "false".
1832 0 0       0 $data->{override_css} = $param{override_css} if $param{override_css};
1833 0 0       0 $data->{text} = $param{text} if $param{text};
1834 0 0       0 $data->{text_color} = $textcol if $textcol;
1835 0 0       0 $data->{text_editable} = $editable if exists $param{text_editable};
1836              
1837 0         0 my $result = $self->api_json_request(
1838             api => API_FLAIRTEMPLATE2,
1839             args => [$sub],
1840             data => $data,
1841             );
1842 0         0 return $result;
1843             }
1844              
1845             #==============================================================================
1846             # Subreddit management
1847             #==============================================================================
1848              
1849             sub get_wiki {
1850 0     0 1 0 my ($self, %param) = @_;
1851 0   0     0 my $page = $param{page} || croak "Need 'page'";
1852 0   0     0 my $sub = $param{sub} || $param{subreddit} || die "need subreddit\n";
1853              
1854 0         0 my $data = {};
1855 0 0       0 $data->{v} = $param{v} if $param{v};
1856 0 0       0 $data->{v2} = $param{v2} if $param{v2};
1857              
1858            
1859 0         0 my $result = $self->api_json_request(
1860             api => API_GETWIKI,
1861             args => [$sub, $page],
1862             data => $data,
1863             );
1864 0 0       0 return $param{data} ? $result->{data} : $result->{data}->{content_md};
1865             }
1866             sub get_wiki_data {
1867 0     0 1 0 my ($self, %param) = @_;
1868 0         0 $param{data} = 1;
1869 0         0 return $self->get_wiki(%param);
1870             }
1871              
1872             sub edit_wiki {
1873 0     0 1 0 my ($self, %param) = @_;
1874 0   0     0 my $page = $param{page} || croak "Need 'page'";
1875 0 0       0 my $content = defined $param{content} ? $param{content} : croak "Need 'content'";
1876             # Reddit maximum length is 524,288
1877 0 0       0 if (length $content > 524288) { croak "Maximum length for 'content' is 524288 bytes."; }
  0         0  
1878 0   0     0 my $sub = $param{sub} || $param{subreddit} || croak "Need 'sub' or 'subreddit'";
1879 0         0 my $previous = $param{previous};
1880 0         0 my $reason = $param{reason};
1881              
1882 0         0 my $data = {};
1883 0         0 $data->{page} = $page;
1884 0         0 $data->{content}= $content;
1885 0 0       0 if ($previous) { $data->{previous} = $previous; }
  0         0  
1886 0 0       0 if ($reason) { $data->{reason} = substr $reason, 0, 256; }
  0         0  
1887              
1888 0         0 my $result = $self->api_json_request(
1889             api => API_EDITWIKI,
1890             args => [$sub],
1891             data => $data,
1892             );
1893              
1894 0         0 return $result;
1895             }
1896              
1897             #===============================================================================
1898             # Comments
1899             #===============================================================================
1900             sub get_comments {
1901 0     0 1 0 my ($self, %param) = @_;
1902 0         0 my $permalink;
1903 0   0     0 my $sub = $param{sub} || $param{subreddit};
1904              
1905 0 0 0     0 if ($param{permalink}) {
    0 0        
    0 0        
    0          
1906 0         0 $permalink = $param{permalink};
1907             } elsif ($sub and $param{comment_id} and $param{link_id}) {
1908 0         0 my $id = id($param{link_id});
1909 0         0 my $cmtid = id($param{comment_id});
1910 0         0 $permalink = "/r/$sub/comments/$id//$cmtid";
1911             } elsif ($sub and $param{id}) {
1912 0         0 my $id = id($param{id});
1913 0         0 $permalink = "/r/$sub/comments/$id";
1914             } elsif ($param{url}) {
1915 0         0 $permalink = $param{url};
1916 0         0 $permalink =~ s/^https?:\/\/([a-zA-Z]{1,3}\.)?reddit\.com//i;
1917             } else {
1918 0         0 die "get_comments: Either 'permalink' OR 'url' OR 'subreddit' and 'link_id' OR 'subreddit' and 'link_id' and 'comment_id' are required.\n";
1919             }
1920              
1921 0         0 my $result = $self->json_request('GET', $permalink);
1922 0         0 my $link_id = $result->[0]{data}{children}[0]{data}{name};
1923             # result->[0] is a listing with 1 element, the link, even if you requested a cmt
1924 0         0 my $comments = $result->[1]{data}{children};
1925              
1926 0         0 my $return = [];
1927 0         0 for my $cmt (@$comments) {
1928 0 0       0 if ($cmt->{kind} eq 't1') {
    0          
1929 0         0 push @$return, Reddit::Client::Comment->new($self, $cmt->{data});
1930             } elsif ($cmt->{kind} eq 'more') {
1931 0         0 my $more = Reddit::Client::MoreComments->new($self, $cmt->{data});
1932 0         0 $more->{link_id} = $link_id;
1933 0         0 push @$return, $more;
1934             }
1935             }
1936 0         0 return $return;
1937             }
1938             # limit_children: get these comments and their descendants
1939             sub get_collapsed_comments {
1940 0     0 0 0 my ($self, %param) = @_;
1941 0   0     0 my $link_id = fullname($param{link_id},'t3') || die "load_more_comments: 'link_id' is required.\n";
1942 0   0     0 my $children = $param{children} || die "get_collapsed_comments: 'children' is required.\n";
1943 0 0       0 my $limit = exists $param{limit_children} ? ($param{limit_children} ? 'true' : 'false') : 'false';
    0          
1944 0         0 my $ids;
1945              
1946 0 0       0 if (ref $children eq 'ARRAY') {
1947 0         0 $ids = join ",", @$children;
1948 0 0       0 die "'children' must be non-empty array reference" unless $ids;
1949             } else {
1950 0         0 die "get_collapsed_comments: 'children' must be array reference\n";
1951             }
1952              
1953 0         0 my $data = {
1954             link_id => $link_id,
1955             children => $ids,
1956             limit_children => $limit,
1957             api_type => 'json', # This is the only GET endpoint that requires
1958             }; # api_type=json to be set.
1959              
1960 0 0       0 $data->{sort} = $param{sort} if $param{sort};
1961 0 0       0 $data->{id} = $param{id} if $param{id};
1962              
1963 0         0 my $result = $self->api_json_request(
1964             api => API_MORECHILDREN,
1965             data => $data,
1966             );
1967 0         0 my $comments = $result->{data}->{things};
1968              
1969 0         0 my $return = [];
1970 0         0 for my $cmt (@$comments) {
1971 0 0       0 if ($cmt->{kind} eq 't1') {
    0          
1972 0         0 push @$return, Reddit::Client::Comment->new($self, $cmt->{data});
1973             } elsif ($cmt->{kind} eq 'more') {
1974 0         0 my $more = Reddit::Client::MoreComments->new($self, $cmt->{data});
1975 0         0 $more->{link_id} = $link_id;
1976 0         0 push @$return, $more;
1977             }
1978             }
1979 0         0 return $return;
1980             }
1981              
1982             sub submit_comment {
1983 0     0 1 0 my ($self, %param) = @_;
1984 0   0     0 my $parent_id = $param{parent} || $param{parent_id} || croak 'Expected "parent"';
1985 0   0     0 my $comment = $param{text} || croak 'Expected "text"';
1986             # the replies option, it does nothing
1987             #my $replies = exists $param{inbox_replies} ? ($param{inbox_replies} ? "true" : "false") : "true";
1988              
1989 0 0 0     0 croak '$fullname must be a post or comment' if !ispost($parent_id) && !iscomment($parent_id);
1990 0         0 DEBUG('Submit comment under %s', $parent_id);
1991              
1992 0         0 my $result = $self->api_json_request(api => API_COMMENT, data => {
1993             thing_id => $parent_id,
1994             text => $comment,
1995             #sendreplies=>$replies,
1996             });
1997              
1998 0         0 return $result->{data}{things}[0]{data}{name};
1999             }
2000              
2001             sub comment {
2002 0     0 1 0 my($self, $parent, $text) = @_;
2003 0         0 return $self->submit_comment(parent_id=>$parent, text=>$text);
2004             }
2005              
2006             #===============================================================================
2007             # Private messages
2008             #===============================================================================
2009              
2010             sub send_message {
2011 0     0 1 0 my ($self, %param) = @_;
2012 0   0     0 my $to = $param{to} || croak 'Expected "to"';
2013 0   0     0 my $subject = $param{subject} || croak 'Expected "subject"';
2014 0   0     0 my $text = $param{text} || croak 'Expected "text"';
2015              
2016 0 0       0 croak '"subject" cannot be longer than 100 characters' if length $subject > 100;
2017            
2018             #$self->require_login;
2019 0         0 DEBUG('Submit message to %s: %s', $to, $subject);
2020              
2021 0         0 my $result = $self->api_json_request(api => API_MESSAGE, data => {
2022             to => $to,
2023             subject => $subject,
2024             text => $text,
2025             kind => SUBMIT_MESSAGE,
2026             });
2027              
2028 0         0 return $result;
2029             }
2030              
2031             #===============================================================================
2032             # Voting
2033             #===============================================================================
2034              
2035             sub vote {
2036 0     0 1 0 my ($self, $name, $direction) = @_;
2037 0 0       0 defined $name || croak 'Expected $name';
2038 0 0       0 defined $direction || croak 'Expected $direction';
2039 0 0 0     0 croak '$fullname must be a post or comment' if !ispost($name) && !iscomment($name);
2040 0 0       0 croak 'Invalid vote direction' unless "$direction" =~ /^(-1|0|1)$/;
2041 0         0 DEBUG('Vote %d for %s', $direction, $name);
2042 0         0 $self->api_json_request(api => API_VOTE, data => { dir => $direction, id => $name });
2043             }
2044              
2045             #===============================================================================
2046             # Saving and hiding
2047             #===============================================================================
2048              
2049             sub save {
2050 0     0 1 0 my $self = shift;
2051 0   0     0 my $name = shift || croak 'Expected $fullname';
2052 0 0 0     0 croak '$fullname must be a post or comment' if !ispost($name) && !iscomment($name);
2053 0         0 DEBUG('Save %s', $name);
2054 0         0 $self->api_json_request(api => API_SAVE, data => { id => $name });
2055             }
2056              
2057             sub unsave {
2058 0     0 1 0 my $self = shift;
2059 0   0     0 my $name = shift || croak 'Expected $fullname';
2060 0 0 0     0 croak '$fullname must be a post or comment' if !ispost($name) && !iscomment($name);
2061 0         0 DEBUG('Unsave %s', $name);
2062 0         0 $self->api_json_request(api => API_UNSAVE, data => { id => $name });
2063             }
2064              
2065             sub hide {
2066 0     0 1 0 my $self = shift;
2067 0   0     0 my $name = shift || croak 'Expected $fullname';
2068 0 0       0 croak '$fullname must be a post' if !ispost($name);
2069 0         0 DEBUG('Hide %s', $name);
2070 0         0 $self->api_json_request(api => API_HIDE, data => { id => $name });
2071             }
2072              
2073             sub unhide {
2074 0     0 1 0 my $self = shift;
2075 0   0     0 my $name = shift || croak 'Expected $fullname';
2076 0 0       0 croak '$fullname must be a post' if !ispost($name);
2077 0         0 DEBUG('Unhide %s', $name);
2078 0         0 $self->api_json_request(api => API_UNHIDE, data => { id => $name });
2079             }
2080              
2081             #==============================================================================
2082             # Multireddits
2083             #==============================================================================
2084              
2085             sub edit_multi {
2086 0     0 1 0 my ($self, %param) = @_;
2087 0         0 $param{edit} = 1;
2088 0         0 $self->create_multi(%param);
2089             }
2090             sub create_multi {
2091 0     0 1 0 my ($self, %param) = @_;
2092 0         0 my $data = {};
2093 0         0 my $model = {};
2094 0   0     0 my $username = $param{username} || $self->{username} || die "'username' is required.";
2095              
2096 0   0     0 $model->{display_name} = $param{name} || croak "Expected 'name'.";
2097 0 0       0 if (length($model->{display_name}) > 50) { croak "max length of 'name' is 50."; }
  0         0  
2098              
2099 0 0       0 $model->{description_md} = $param{description} if $param{description};
2100              
2101 0 0       0 if ($param{icon_name}) {
2102 0         0 $model->{icon_name} = $param{icon_name};
2103 0         0 my @iconnames = ('art and design', 'ask', 'books', 'business', 'cars', 'comics', 'cute animals', 'diy', 'entertainment', 'food and drink', 'funny', 'games', 'grooming', 'health', 'life advice', 'military', 'models pinup', 'music', 'news', 'philosophy', 'pictures and gifs', 'science', 'shopping', 'sports', 'style', 'tech', 'travel', 'unusual stories', 'video', '', 'None');
2104 0         0 my $match = 0;
2105 0         0 foreach my $i (@iconnames) {
2106 0 0       0 $match = 1 if $i eq $model->{icon_name};
2107             }
2108 0         0 my $iconstr = join ", ", @iconnames;
2109 0 0       0 if (!$match) {croak "if 'icon_name' is provided, it must be one of the following values: $iconstr. Note that the purpose of icon_str is unclear and you should not use it unless you know what you're doing."; }
  0         0  
2110             }
2111              
2112 0 0       0 if ($param{key_color}) {
2113 0         0 $model->{key_color} = "#".$param{key_color};
2114 0 0       0 if (length($model->{key_color}) != 7) { croak "'key_color' must be a 6-character color code"; }
  0         0  
2115             }
2116              
2117 0 0       0 if ($param{visibility}) {
2118 0         0 $model->{visibility} = $param{visibility};
2119 0 0 0     0 if ($model->{visibility} ne 'private' and
      0        
2120             $model->{visibility} ne 'public' and
2121             $model->{visibility} ne 'hidden') {
2122 0         0 croak "if provided, 'visibility' must be either 'public', 'private', or 'hidden'.";
2123             }
2124             }
2125              
2126 0 0       0 if ($param{weighting_scheme}) {
2127 0         0 $model->{weighting_scheme} = $param{weighting_scheme};
2128 0 0 0     0 if ($model->{weighting_scheme} ne 'classic' and $model->{weighting_scheme} ne 'fresh') { croak "if 'weighting_scheme' is provided, it must be either 'classic' or 'fresh'"; }
  0         0  
2129             }
2130            
2131 0 0 0     0 if ($param{subreddits} or $param{subs}) {
2132 0   0     0 $param{subreddits} = $param{subs} || $param{subreddits};
2133 0 0       0 if (ref $param{subreddits} ne 'ARRAY') { croak "'subreddits' must be an array reference."; }
  0         0  
2134              
2135 0         0 $model->{subreddits} = [ map { { name=> $_ } } @{$param{subreddits}} ];
  0         0  
  0         0  
2136             #print Dumper($model->{subreddits});
2137             }
2138              
2139             # Put a ribbon on it
2140 0         0 $data->{model} = JSON::encode_json($model);
2141 0         0 $data->{multipath} = "/user/$username/m/$model->{display_name}";
2142              
2143             my $result = $self->api_json_request(
2144             api => $param{edit} ? API_EDITMULTI : API_CREATEMULTI,
2145 0 0       0 args => [$username, $model->{display_name}],
2146             data => $data,
2147             );
2148              
2149 0         0 return $result->{data};
2150             }
2151              
2152             sub get_multi {
2153 0     0 1 0 my ($self, %param) = @_;
2154 0   0     0 my $name = $param{name} || croak "expected 'name'";
2155 0   0     0 my $username= $param{user} || $param{username} || $self->{username} || die "'username' is required.\n";
2156 0 0       0 my $expand = $param{expand} ? '?expand_srs=true' : '';
2157              
2158 0         0 my $result = $self->api_json_request(
2159             api => API_GETMULTI,
2160             args => [$username, $name, $expand],
2161             );
2162              
2163             # The result looks like a Subreddit object, but is not.
2164             # By returning just the data we lose only the 'kind' key,
2165             # which is just the string "LabeledMulti"
2166 0         0 return $result->{data};
2167             }
2168              
2169             sub delete_multi {
2170 0     0 1 0 my $self = shift;
2171 0   0     0 my $name = shift || croak "expected arg 1 (name)";
2172              
2173             my $result = $self->api_json_request(
2174             api => API_DELETEMULTI,
2175 0         0 args => [$self->{username}, $name],
2176             );
2177 0         0 return $result->{data};
2178             }
2179             #==============================================================================
2180             # Misc
2181             #==============================================================================
2182             sub get_origin {
2183 0     0 0 0 my $self = shift;
2184 0         0 return "https://$self->{subdomain}.reddit.com";
2185             }
2186              
2187             #==============================================================================
2188             # Internal and static
2189             #==============================================================================
2190              
2191             # Strip the type portion of a filname (i.e. t3_), if it exists
2192             sub id {
2193 0     0 1 0 my $id = shift;
2194 0         0 $id =~ s/^t\d_//;
2195 0         0 return $id;
2196             }
2197             # accept id or fullname, always return fullname
2198             sub fullname {
2199 0   0 0 1 0 my $id = shift || return;
2200 0   0     0 my $type = shift || die "fullname: 'type' is required";
2201 0 0       0 $id = $type."_".$id if substr($id, 0, 3) ne $type."_";
2202 0         0 return $id;
2203             }
2204             sub bool {
2205 0 0   0 0 0 return $_[0] ? "true" : "false";
2206             }
2207             sub ispost {
2208 0     0 0 0 my $name = shift;
2209 0         0 my $type = substr $name, 0, 2;
2210 0         0 return $type eq 't3';
2211             }
2212             sub iscomment {
2213 0     0 0 0 my $name = shift;
2214 0         0 my $type = substr($name, 0, 2);
2215 0         0 return $type eq 't1';
2216             }
2217             sub get_type {
2218 0     0 0 0 my $name = shift;
2219 0 0       0 return lc substr($name, 0, 2) if $name;
2220             }
2221             sub DEBUG {
2222 2 50   2 0 8 if ($DEBUG) {
2223 0           my ($format, @args) = @_;
2224 0           my $ts = strftime "%Y-%m-%d %H:%M:%S", localtime;
2225 0           my $msg = sprintf $format, @args;
2226 0           chomp $msg;
2227 0           printf STDERR "[%s] [ %s ]\n", $ts, $msg;
2228             }
2229             }
2230              
2231             sub subreddit {
2232 0     0 0   my $subject = shift;
2233 0           $subject =~ s/^\/r//; # trim leading /r
2234 0           $subject =~ s/^\///; # trim leading slashes
2235 0           $subject =~ s/\/$//; # trim trailing slashes
2236              
2237 0 0         if ($subject !~ /\//) { # no slashes in name - it's probably good
2238 0 0         if ($subject eq '') { # front page
2239 0           return '';
2240             } else { # subreddit
2241 0           return $subject;
2242             }
2243             } else { # fail
2244 0           return;
2245             }
2246             }
2247              
2248             # Remember that this returns a new hash and any key not from here will be
2249             # wiped out
2250             sub set_listing_defaults {
2251 0     0 0   my ($self, %param) = @_;
2252 0           my $query = {};
2253 0 0         $query->{before} = $param{before} if $param{before};
2254 0 0         $query->{after} = $param{after} if $param{after};
2255 0 0         $query->{only} = $param{only} if $param{only};
2256 0 0         $query->{count} = $param{count} if $param{count};
2257 0 0 0       $query->{show} = 'all' if $param{show} or $param{show_all};
2258 0 0         $query->{sort} = $param{sort} if $param{sort};
2259 0 0         $query->{sr_detail} = 'true' if $param{sr_detail};
2260             # 500?
2261 0 0 0       if (exists $param{limit}) { $query->{limit} = $param{limit} || 100; }
  0            
2262 0           else { $query->{limit} = DEFAULT_LIMIT; }
2263            
2264 0           return $query;
2265             }
2266              
2267             1;
2268              
2269             __END__