File Coverage

blib/lib/Reddit/Client.pm
Criterion Covered Total %
statement 334 1217 27.4
branch 1 462 0.2
condition 0 391 0.0
subroutine 112 217 51.6
pod 68 106 64.1
total 515 2393 21.5


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