File Coverage

blib/lib/LJ/Simple.pm
Criterion Covered Total %
statement 338 1409 23.9
branch 128 676 18.9
condition 49 137 35.7
subroutine 21 75 28.0
pod 61 70 87.1
total 597 2367 25.2


line stmt bran cond sub pod time code
1             package LJ::Simple;
2              
3 1     1   8144 use strict;
  1         2  
  1         40  
4 1     1   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  1         2  
  1         134  
5              
6             require Exporter;
7             require AutoLoader;
8              
9             @ISA = qw(Exporter AutoLoader);
10             @EXPORT_OK = qw();
11             @EXPORT = qw();
12             $VERSION = '0.15';
13              
14             ## Bring in modules we use
15 1     1   5 use strict; # Silly not to be strict
  1         5  
  1         24  
16 1     1   7197 use Socket; # Required for talking to the LJ server
  1         4083  
  1         641  
17 1     1   963 use POSIX; # For errno values and other POSIX functions
  1         6926  
  1         7  
18              
19             ## Helper function prototypes
20             sub Debug(@);
21             sub EncVal($$);
22             sub DecVal($);
23             sub SendRequest($$$$);
24             sub dump_list($$);
25             sub dump_hash($$);
26              
27             =pod
28              
29             =head1 NAME
30              
31             LJ::Simple - A perl module to access LiveJournal via its flat protocol
32              
33             =head1 SYNOPSIS
34              
35             C is an object based C module which is used to access
36             LiveJournal-based web logs. This module implements most of the
37             flat protocol LiveJournal uses; for details of this protocol please
38             see: L
39              
40             =head1 REQUIREMENTS
41              
42             This module requires nothing other than the modules which come with the
43             standard perl 5.6.1 distribution. The only modules it B are
44             C and C.
45              
46             If you have the C module available then the code will make use of
47             encrypted passwords automatically. However C is not required for
48             this module to work.
49              
50             =head1 DESCRIPTION
51              
52             C is a trival API to access LiveJournal. Currently it
53             allows you to:
54              
55             =over 2
56              
57             =item Login
58              
59             Log into the LiveJournal system
60              
61             =item Post
62              
63             Post a new journal entry in the LiveJournal system
64              
65             =item Synchronise
66              
67             Returns a list of journal entries created or modified from a given
68             date.
69              
70             =item Edit
71              
72             Edit the contents of an existing entry within the LiveJournal system
73              
74             =item Delete
75              
76             Delete an existing post from the LiveJournal system
77              
78             =back
79              
80             =head1 EXAMPLE
81              
82             The following simple examples shows you how to use the module to post a
83             simple LiveJournal entry.
84              
85             =head2 Using LJ::Simple::QuickPost()
86              
87             C is a routine which allows you to quickly post an entry into
88             LiveJournal; as such it lacks a lot of the abilities which using the object-based
89             interface provides. The C routine is explained in depth below, however
90             the following example shows how it can be used to easily post to LiveJournal:
91              
92             use LJ::Simple;
93            
94             LJ::Simple::QuickPost(
95             user => "test",
96             pass => "test",
97             entry => "Just a simple entry",
98             ) || die "$0: Failed to post entry: $LJ::Simple::error\n";
99              
100             =head2 Using the standard calls
101              
102             use LJ::Simple;
103              
104             # Log into the server
105             my $lj = new LJ::Simple ({
106             user => "test",
107             pass => "test",
108             site => undef,
109             });
110             (defined $lj)
111             || die "$0: Failed to log into LiveJournal: $LJ::Simple::error\n";
112            
113             # Prepare the event
114             my %Event=();
115             $lj->NewEntry(\%Event) ||
116             die "$0: Failed to create new entry: $LJ::Simple::error\n";
117            
118             # Put in the entry
119             my $entry=<
120             A simple entry made using LJ::Simple version $LJ::Simple::VERSION
121             EOF
122             $lj->SetEntry(\%Event,$entry)
123             || die "$0: Failed to set entry: $LJ::Simple::error\n";
124            
125             # Say we are happy
126             $lj->SetMood(\%Event,"happy")
127             || die "$0: Failed to set mood: $LJ::Simple::error\n";
128            
129             # Post the event
130             my ($item_id,$anum,$html_id)=$lj->PostEntry(\%Event);
131             (defined $item_id)
132             || die "$0: Failed to post journal entry: $LJ::Simple::error\n";
133              
134             =head1 VARIABLES
135              
136             There are various variables which can be used to control certain
137             aspects of the module. It is generally recommended that if you
138             wish to change these variables that you do so B you
139             create the initial object.
140              
141             The variable you are most likely to use is C<$LJ::Simple::error>
142             which holds error messages if any of the C calls
143             fail.
144              
145             =over 4
146              
147             =item $LJ::Simple::error
148              
149             Holds error messages, is set with a blank string at the
150             start of each method. Whilst the messages are relatively free-form,
151             there are some prefixes which are sometimes used:
152              
153             CODE: An error in the code calling the API
154             INTERNAL: An internal error in this module
155              
156             =item $LJ::Simple::debug
157              
158             If set to C<1>, debugging messages are sent to stderr.
159              
160             =item $LJ::Simple::protocol
161              
162             If set to C<1> the protocol used to talk to the remote server is sent to stderr.
163              
164             =item $LJ::Simple::raw_protocol
165              
166             If set to C<1> the raw protocol used to talk to the remote server is sent to stderr;
167             this is only useful if you are doing debugging on C itself as the protocol
168             is shown as the module gets it from the server; non-printable characters are converted
169             to their octal presentation form, I a newline becomes C<\012>.
170              
171             It should be noted that if C<$LJ::Simple::raw_protocol> is set along with
172             C<$LJ::Simple::protocol> then the raw protocol display takes precedence for data
173             returning from the LJ server.
174              
175             =item $LJ::Simple::UTF
176              
177             If set to C<1> the LiveJournal server is told to expect UTF-8 encoded characters.
178             If you enable this the module will attempt to use the utf8 perl module.
179              
180             The default is see if we have a version of Perl with UTF-8 support and use
181             it if its available.
182              
183             =item $LJ::Simple::challenge
184              
185             If set to C<1> we make use of the challenge-response system instead of using
186             plain or hashed passwords. This does add some overhead into processing requests
187             since every action has to be preceeded by a request for a challenge value from
188             the server.
189              
190             The default is to see if we have the C module available and if
191             so we make use of the challenge-response system. This can be disabled by
192             setting the variable to C<0>.
193              
194             =item $LJ::Simple::timeout
195              
196             The time - specified in seconds - to wait for data from the server. If
197             given a value of C the API will block until data is avaiable.
198              
199             =item $LJ::Simple::NonBlock
200              
201             By default this is set to C. When given a reference to a sub-routine this
202             module will call the given sub-routine at various stages of processing the responses
203             to the LiveJournal server. This is intended for GUI applications which need to process
204             event queues, update progress bars, I. When called the sub-routine is passed a
205             number of variables which maybe useful; the calling method is:
206              
207             &{sub}($mode,$status,$action,$bytes_in,$bytes_out,$time,$waiting)
208              
209             $mode - The mode sent to the LJ server
210             $status - The status of the request; ranges from 0 to 1
211             $action - The action performed
212             $bytes_in - The number of bytes read from the remote server
213             $bytes_out - The number of bytes written to the remote server
214             $time - The time taken so far in seconds
215             $waiting - Are we waiting for a response from the server ?
216              
217             It should be noted that if C<$waiting> is set to C<1> then it is B recommended
218             that the sub-routine calls C itself to provide at least some time delay. If
219             this is not done it is likely that this module will consume far more CPU than necessary.
220              
221             An example sub-routine follows:
222              
223             sub LJStatus {
224             my ($mode,$status,$action,$bytes_in,$bytes_out,$time,$waiting) = @_;
225             print "\$mode = $mode\n";
226             print "\$status = $status\n";
227             print "\$action = $action\n";
228             print "\$bytes_in = $bytes_in\n";
229             print "\$bytes_out = $bytes_out\n";
230             print "\$time = $time\n";
231             print "\$waiting = $waiting\n";
232             print "\n";
233             ($waiting) && select(undef,undef,undef,0.5);
234             }
235            
236             $LJ::Simple::NonBlock=\&LJStatus;
237              
238             =item $LJ::Simple::ProtoSub
239              
240             By default this points to a sub-routine within the module; this is called when
241             the protocol between the module and LiveJournal server is to be shown, in other
242             words when C<$LJ::Simple::protocol> is set to C<1>. The sub-routine called must
243             take two variables; it is called in the following way:
244              
245             &{sub}($direction,$data,$server,$ip_addr)
246              
247             $direction - The direction of the flow; 0 means from client to server
248             and 1 means from server to client
249             $data - The data which has flowed; there should not be any newlines
250             with the data, but do not rely on this.
251             $server - The name of the LJ server we are talking to
252             $ip_addr - The IP address of the LJ server we are talking to
253              
254             If both variables are C then data is about to flow. If just C<$direction> is
255             C then C<$data> holds an informational message.
256              
257             The standard sub-routine which is called is:
258              
259             sub DefaultProtoSub {
260             my ($direct,$data,$server,$ip_addr)=@_;
261             my $arrow="--> ";
262             if (!defined $direct) {
263             if (!defined $data) {
264             print STDERR "Connecting to $server [$ip_addr]\n";
265             print STDERR "Lines starting with \"-->\" is data SENT to the server\n";
266             print STDERR "Lines starting with \"<--\" is data RECEIVED from the server\n";
267             return;
268             }
269             $arrow="";
270             } else {
271             ($direct) && ($arrow="<-- ");
272             }
273             print STDERR "$arrow$data\n";
274             }
275            
276             $LJ::Simple::ProtoSub=\&DefaultProtoSub;
277              
278             =item $LJ::Simple::buffer
279              
280             The number of bytes to try and read in on each C call.
281              
282             =back
283              
284             =cut
285              
286             sub DefaultProtoSub {
287 0     0 0 0 my ($direct,$data,$server,$ip_addr)=@_;
288 0         0 my $arrow="--> ";
289 0 0       0 if (!defined $direct) {
290 0 0       0 if (!defined $data) {
291 0         0 print STDERR "Connecting to $server [$ip_addr]\n";
292 0         0 print STDERR "Lines starting with \"-->\" is data SENT to the server\n";
293 0         0 print STDERR "Lines starting with \"<--\" is data RECEIVED from the server\n";
294 0         0 return;
295             }
296 0         0 $arrow="";
297             } else {
298 0 0       0 ($direct) && ($arrow="<-- ");
299             }
300 0         0 print STDERR "$arrow$data\n";
301             }
302              
303              
304             ## Global variables - documented
305             # Debug ?
306             $LJ::Simple::debug=0;
307             # Show protocol ?
308             $LJ::Simple::protocol=0;
309             # Protocol handling code
310             $LJ::Simple::ProtoSub=\&DefaultProtoSub;
311             # Show raw protocol ?
312             $LJ::Simple::raw_protocol=0;
313             # Use UTF-8 ?
314             $LJ::Simple::UTF = undef;
315             # Use challenge-response ?
316             $LJ::Simple::challenge = undef;
317             # Use non-block sub-routine
318             $LJ::Simple::NonBlock = undef;
319             # Errors
320             $LJ::Simple::error="";
321             # Timeout for reading from sockets - default is 5 minutes
322             $LJ::Simple::timeout = 300;
323             # How much data to read from the socket in one read()
324             $LJ::Simple::buffer = 8192;
325              
326             ## Global variables - internal and undocumented
327             # Should we not fully run the QuickPost routine ?
328             $LJ::Simple::TestStopQuickPost = 0;
329              
330             ## Internal variables - private to this module
331             # Standard ports
332             my %StdPort = (
333             http => 80,
334             http_proxy => 3128,
335             );
336              
337             =pod
338              
339             =head1 AVAILABLE METHODS
340              
341             =head2 LJ::Simple::QuickPost()
342              
343             C is a routine which allows you to quick post to LiveJournal.
344             However it does this by hiding a lot of the details involved in using
345             C to do this. This routine will do all of the work involved in
346             logging into the LiveJournal server, preparing the entry and then posting it.
347             If at any stage there is a failure then C<0> is returned and C<$LJ::Simple::error>
348             will contain the reason why. If the entry was successfully posted to the LiveJournal
349             server then the routine will return C<1>.
350              
351             There are a number of options to the C routine:
352              
353             LJ::Simple::QuickPost(
354             user => Username
355             pass => Password
356             entry => Contents of the entry
357             subject => Subject line of the entry
358             mood => Current mood
359             music => Current music
360             html => HTML content ?
361             protect => Security settings of the entry
362             groups => Friends groups list
363             tags => Tags list
364             results => Hash to store results in
365             );
366              
367             Of these, only the C, C and C options are required; all of the other
368             options are optional. The option names are all case insensitive.
369              
370             =over 4
371              
372             =item user
373              
374             The username who owns the journal the entry should be posted to;
375             this option is B.
376              
377             =item pass
378              
379             The password of the C;
380             this option is B.
381              
382             =item entry
383              
384             The actual entry itself;
385             this option is B.
386              
387             =item subject
388              
389             The subject line of the post.
390              
391             =item mood
392              
393             The mood to associate with the post; the value is given to the C method
394             for processing.
395              
396             =item music
397              
398             The music to associate with the post.
399              
400             =item html
401              
402             This is a boolean value of either C<1> or C<0>. If you want to say that the entry
403             contains HTML and thus should be considered to be preformatted then set C to
404             C<1>. Otherwise you can either set it to C<0> or not give the option.
405              
406             =item protect
407              
408             By default the new entry will be public unless you give the C option. This
409             option should be given the protection level required for the post and can be one of
410             the following:
411              
412             public - The entry is public
413             friends - Entry is friends-only
414             groups - Entry is restricted to friends groups
415             private - Entry is restricted to the journal's owner
416              
417             If you set the C option to C you must also include the C
418             option - see below for details.
419              
420             =item groups
421              
422             If the C option is set to C then this option should contain a
423             list reference which contains the list of groups the entry should be restricted to.
424             This option is B if the C option is set to C.
425              
426             =item tags
427              
428             Set tags for the entry; this should contain a list reference which contains the
429             tags to be set.
430              
431             =item results
432              
433             The results of posting the entry should be returned; this should contain a
434             hash reference. The hash given will be filled with the result of posting the
435             article; the hash refered to B by this.
436              
437             The keys in the hash point to:
438              
439             ok - Return code of QuickPost
440             item_id - Item_id as returned by the LiveJournal server
441             anum - Anum as returned by the LiveJournal server
442             html_id - The item_id of the entry as used in HTML
443             url - A URL which could be used to access the entry
444              
445             It should be noted that when C fails, C will point to
446             a value of C<0> and all other entries in the hash will be C.
447              
448             =back
449              
450             Example code:
451              
452             # Simple test post
453             LJ::Simple::QuickPost(
454             user => "test",
455             pass => "test",
456             entry => "Just a simple entry",
457             ) || die "$0: Failed to post entry: $LJ::Simple::error\n";
458            
459             # A friends-only preformatted entry
460             LJ::Simple::QuickPost(
461             user => "test",
462             pass => "test",
463             entry => "

Friends-only, preformatted, entry

",
464             html => 1,
465             protect => "friends",
466             ) || die "$0: Failed to post entry: $LJ::Simple::error\n";
467            
468             # A entry restricted to several friends groups
469             LJ::Simple::QuickPost(
470             user => "test",
471             pass => "test",
472             entry => "Entry limited to friends groups",
473             protect => "groups",
474             groups => [qw( one_group another_group )],
475             ) || die "$0: Failed to post entry: $LJ::Simple::error\n";
476              
477             # Simple test post with tags and returning HTML
478             my %Results=();
479             LJ::Simple::QuickPost(
480             user => "test",
481             pass => "test",
482             entry => "Just a simple entry",
483             tags => [ "Just a test", "Testing" ],
484             results => \%Results,
485             ) || die "$0: Failed to post entry: $LJ::Simple::error\n";
486             print "URL = $Results{url}\n";
487              
488             =cut
489             sub QuickPost(@) {
490 13     13 1 460 my %opts=();
491 13         14 my @prot_opts=();
492 13         29 while($#_>-1) {
493 43         59 my $k=lc(shift(@_));
494 43         42 my $v=shift(@_);
495 43 100       61 (defined $v) || next;
496 42         85 $opts{$k}=$v;
497             }
498 13         17 foreach (qw( user pass entry )) {
499 34 100       60 (exists $opts{$_}) && next;
500 3         6 $LJ::Simple::error="CODE: QuickPost() called without the required $_ option";
501 3         6 return 0;
502             }
503 10 100 100     32 if ((exists $opts{html}) && ($opts{html}!~/^[01]$/)) {
504 1         1 $LJ::Simple::error="CODE: QuickPost() not given either 0 or 1 for html option";
505 1         3 return 0;
506             }
507 9 100 66     26 if ((exists $opts{protect}) && ($opts{protect} eq "groups")) {
508 3 100       8 if (!exists $opts{groups}) {
509 1         1 $LJ::Simple::error="CODE: QuickPost() given protect=groups, but no groups option";
510 1         3 return 0;
511             }
512 2 100       7 if (ref($opts{groups}) ne "ARRAY") {
513 1         2 $LJ::Simple::error="CODE: QuickPost() not given a list reference for the groups option";
514 1         4 return 0;
515             }
516 1         2 @prot_opts=@{$opts{groups}};
  1         3  
517             }
518 7 100 100     23 if ((exists $opts{tags}) && (ref($opts{tags}) ne "ARRAY")) {
519 1         3 $LJ::Simple::error="CODE: QuickPost() not given a list reference for the tags option";
520 1         3 return 0;
521             }
522 6 100 100     20 if ((exists $opts{results}) && (ref($opts{results}) ne "HASH")) {
523 1         1 $LJ::Simple::error="CODE: QuickPost() not given a hash reference for the results option";
524 1         5 return 0;
525             }
526              
527             # Kludge so we can test the input validation
528 5 50       17 ($LJ::Simple::TestStopQuickPost) && return 1;
529            
530 0         0 my $lj = new LJ::Simple({
531             user => $opts{user},
532             pass => $opts{pass},
533             });
534 0 0       0 (defined $lj) || return 0;
535              
536 0         0 my %Event=();
537 0 0       0 $lj->NewEntry(\%Event) || return 0;
538 0 0       0 $lj->SetEntry(\%Event,$opts{entry}) || return 0;
539 0 0 0     0 (exists $opts{subject}) &&
540             ($lj->SetSubject(\%Event,$opts{subject}) || return 0);
541 0 0 0     0 (exists $opts{mood}) &&
542             ($lj->SetMood(\%Event,$opts{mood}) || return 0);
543 0 0 0     0 (exists $opts{music}) &&
544             ($lj->Setprop_current_music(\%Event,$opts{music}) || return 0);
545 0 0 0     0 (exists $opts{html}) &&
546             ($lj->Setprop_preformatted(\%Event,$opts{html}) || return 0);
547 0 0 0     0 (exists $opts{protect}) &&
548             ($lj->SetProtect(\%Event,$opts{protect},@prot_opts) || return 0);
549 0         0 (exists $opts{tags}) &&
550 0 0 0     0 ($lj->Setprop_taglist(\%Event,@{$opts{tags}}) || return 0);
551              
552 0         0 my $RetCode = 0;
553 0         0 my ($item_id,$anum,$html_id)=$lj->PostEntry(\%Event);
554 0 0       0 (defined $item_id) && ($RetCode=1);
555 0 0       0 if (exists $opts{results}) {
556 0         0 my $user=$lj->user();
557 0         0 my $server=$lj->{lj}->{host};
558 0         0 my $port=$lj->{lj}->{port};
559 0         0 %{$opts{results}}=(
  0         0  
560             ok => $RetCode,
561             item_id => $item_id,
562             anum => $anum,
563             html_id => $html_id,
564             url => "http://$server:$port/users/$user/$html_id.html",
565             );
566             }
567 0         0 return $RetCode;
568             }
569              
570             =pod
571              
572             =head2 Object creation
573              
574             =over 4
575              
576             =item login
577              
578             Logs into the LiveJournal system.
579              
580             ## Simplest logon method
581             my $lj = new LJ::Simple ( {
582             user => "username",
583             pass => "password",
584             } );
585            
586             ## Login with options
587             my $lj = new LJ::Simple ( {
588             user => "username",
589             pass => "password",
590             site => "hostname[:port]",
591             proxy => "hostname[:port]",
592             moods => 0 | 1,
593             pics => 0 | 1,
594             fast => 0 | 1,
595             } );
596              
597             ## Login by using login()
598             my $lj = LJ::Simple->login ( {
599             user => "username",
600             pass => "password",
601             site => "hostname[:port]",
602             proxy => "hostname[:port]",
603             moods => 0 | 1,
604             pics => 0 | 1,
605             fast => 0 | 1,
606             } );
607              
608             Where:
609              
610             user is the username to use
611             pass is the password associated with the username
612             site is the remote site to use
613             proxy is the HTTP proxy site to use; see below.
614             moods is set to 0 if we do not want to download the mood
615             list. Defaults to 1
616             pics is set to 0 if we do not want to download the user
617             picture information. Defaults to 1
618             fast is set to 1 if we want to perform a fast login.
619             Default is 0. See below for details of this.
620              
621             Sites defined in C or C are a hostname with an
622             optional port number, separated by a C<:>, i.e.:
623              
624             www.livejournal.com
625             www.livejournal.com:80
626              
627             If C is given C then the code assumes that you wish to
628             connect to C. If no port is given then port
629             C<80> is the default.
630              
631             If C is given C then the code will go directly to the
632             C<$site> unless a suitable environment variable is set.
633             If no port is given then port C<3128> is the default.
634              
635             C also supports the use the environment variables C
636             and C to store the HTTP proxy server details. The format of these
637             environment variables is assumed to be:
638              
639             http://server[:port]/
640              
641             Where C is the name of the proxy server and the optional C the
642             proxy server is on - port C<3128> is used if no port is explicitly given.
643              
644             It should be noted that the proxy environment variables are B checked
645             if the C value is B given to the C object creation.
646             Thus to disable looking at the proxy environment variables use
647             Cundef> in C or C.
648              
649             If C is set to C<0> then the mood list will not be pulled from
650             the LiveJournal server and the following functions will be affected:
651              
652             o moods() will always return undef (error)
653             o Setprop_current_mood_id() will not validate the mood_id
654             given to it.
655             o SetMood() will not attempt to convert the string it is
656             given into a given mood_id
657              
658             If C is set to C<0> then the data on the user pictures will
659             not be pulled from the LiveJournal server and the following
660             functions will be affected:
661              
662             o pictures() will always return undef (error)
663             o Setprop_picture_keyword() will blindly set the picture keyword
664             you give it - no validation will be performed.
665             o DefaultPicURL() will always return undef (error)
666              
667             If C is set to C<1> then we will perform a I. Essentially
668             all this does is to set up the various entries in the object hash which
669             the routines called after C expect to see; at no time does it talk to
670             the LiveJournal servers. What this means is that it is very fast. However it
671             also means that when you use parts of the API which B talk to the LiveJournal
672             servers its quite possible that you will get back errors associated with
673             authentication errors, network outages, I. In other words, in C mode
674             the login will always succeed, no matter what the state the LiveJournal
675             server we're talking is in. It should be noted that the following functions
676             will be affected if you enable the I:
677              
678             o moods() will always return undef (error)
679             o Setprop_current_mood_id() will not validate the mood_id
680             given to it
681             o SetMood() will not attempt to convert the string it is
682             given into a given mood_id
683             o pictures() will always return undef (error)
684             o Setprop_picture_keyword() will blindly set the picture keyword
685             you give it - no validation will be performed
686             o communities() will always return an empty list
687             o MemberOf() will always return 0 (error)
688             o UseJournal() will not validate the shared journal name you
689             give it
690             o groups() will always return undef (error)
691             o MapGroupToId() will always undef (error)
692             o MapIdToGroup() will always undef (error)
693             o SetProtectGroups() will always 0 (error)
694             o message() will always return undef (error)
695             o The key of "groups" in the list of hashes returned by
696             GetFriends() will always point to an empty list
697             o CheckFriends() will return undef (error) if you give it a
698             list of groups
699              
700             On success this sub-routine returns an C object. On
701             failure it returns C with the reason for the failure being
702             placed in C<$LJ::Simple::error>.
703              
704             Example code:
705              
706             ## Simple example, going direct to www.livejournal.com:80
707             my $lj = new LJ::Simple ({ user => "someuser", pass => "somepass" });
708             (defined $lj) ||
709             die "$0: Failed to access LiveJournal - $LJ::Simple::error\n";
710              
711             ## More complex example, going via a proxy server on port 3000 to a
712             ## a LiveJournal system available on port 8080 on the machine
713             ## www.somesite.com.
714             my $lj = new LJ::Simple ({
715             user => "someuser",
716             pass => "somepass",
717             site => "www.somesite.com:8080",
718             proxy => "proxy.internal:3000",
719             });
720             (defined $lj) ||
721             die "$0: Failed to access LiveJournal - $LJ::Simple::error\n";
722              
723             ## Another complex example, this time saying that we do not want
724             ## the mood list or user pictures downloaded
725             my $lj = new LJ::Simple ({
726             user => "someuser",
727             pass => "somepass",
728             pics => 0,
729             moods => 0,
730             });
731             (defined $lj) ||
732             die "$0: Failed to access LiveJournal - $LJ::Simple::error\n";
733            
734             ## Final example - this one shows the use of the fast logon
735             my $lj = new LJ::Simple ({
736             user => "someuser",
737             pass => "somepass",
738             fast => 1,
739             });
740             (defined $lj) ||
741             die "$0: Failed to access LiveJournal - $LJ::Simple::error\n";
742              
743             =cut
744             ##
745             ## Log into the LiveJournal system. Given that the LJ stuff is just
746             ## layered over HTTP, its not essential to do this. However it does
747             ## mean that we can check the auth details, get some useful info for
748             ## later, etc.
749             ##
750             sub login($$) {
751             # Handle the OOP stuff
752 11     11 1 2504 my $this=shift;
753 11         22 $LJ::Simple::error="";
754 11 100       32 if ($#_ != 0) {
755 2         3 $LJ::Simple::error="CODE: Incorrect usage of login() for argv - see docs";
756 2         24 return undef;
757             }
758             # Get the hash
759 9         17 my $hr = shift;
760 9   33     47 my $class = ref($this) || $this;
761 9         16 my $self = {};
762 9         28 bless $self,$class;
763 9 50 33     109 if ((!exists $hr->{user})||($hr->{user} eq "") ||
      33        
      33        
764             (!exists $hr->{pass})||($hr->{pass} eq "")) {
765 0         0 $LJ::Simple::error="CODE: Incorrect usage of login() - see docs";
766 0         0 return undef;
767             }
768 9         60 $self->{auth}={
769             user => $hr->{user},
770             pass => $hr->{pass},
771             challenge => {},
772             };
773 9 100       37 if (! defined $LJ::Simple::UTF) {
    50          
774 1         2 eval { require utf8 };
  1         893  
775 1 50       10 if (!$@) {
776 1         1 $LJ::Simple::UTF=1;
777 1         4 Debug("UTF-8 support found");
778             } else {
779 0         0 $LJ::Simple::UTF=0;
780 0         0 Debug("No UTF-8 support found");
781             }
782             } elsif ($LJ::Simple::UTF) {
783 8         16 eval { require utf8 };
  8         71  
784 8 50       20 if (!$@) {
785 8         25 Debug("Using UTF-8 as requested");
786             } else {
787 0         0 $LJ::Simple::error="CODE: no UTF-8 support in your version of perl";
788 0         0 return undef;
789             }
790             }
791 9         15 eval { require Digest::MD5 };
  9         196  
792 9 50       18 if (!$@) {
793 9         19 Debug("Using Digest::MD5");
794 9         70 my $md5=Digest::MD5->new;
795 9         48 $md5->add($hr->{pass});
796 9         59 $self->{auth}->{hash}=$md5->hexdigest;
797 9         39 delete $self->{auth}->{pass};
798 9 100       58 (!defined $LJ::Simple::challenge) && ($LJ::Simple::challenge=1);
799             } else {
800 0 0 0     0 if ((defined $LJ::Simple::challenge)&&($LJ::Simple::challenge)) {
801 0         0 $LJ::Simple::error="Challenge-response auth requested, no Digest::MD5 found";
802 0         0 return undef;
803             }
804 0         0 $LJ::Simple::challenge=0;
805             }
806 9 100 100     61 if ((exists $hr->{site})&&(defined $hr->{site})&&($hr->{site} ne "")) {
      66        
807 1         2 my $site_port=$StdPort{http};
808 1 50       4 if ($hr->{site}=~/\s*(.*?):([0-9]+)\s*$/) {
809 0         0 $hr->{site} = $1;
810 0         0 $site_port = $2;
811             }
812 1         5 $self->{lj}={
813             host => $hr->{site},
814             port => $site_port,
815             }
816             } else {
817 8         70 $self->{lj}={
818             host => "www.livejournal.com",
819             port => $StdPort{http},
820             }
821             }
822 9 50 66     56 if ((exists $hr->{proxy})&&(defined $hr->{proxy})&&($hr->{proxy} ne "")) {
    100 33        
823 0         0 my $proxy_port=$StdPort{http_proxy};
824 0 0       0 if ($hr->{proxy}=~/\s*(.*?):([0-9]+)\s*$/) {
825 0         0 $hr->{proxy} = $1;
826 0         0 $proxy_port = $2;
827             }
828 0         0 $self->{proxy}={
829             host => $hr->{proxy},
830             port => $proxy_port,
831             };
832             } elsif (!exists $hr->{proxy}) {
833             # Getting proxy details from the environment; assumes that the proxy is
834             # given as http://site[:port]/
835             # The first matching env is used.
836 8         21 foreach my $env (qw( http_proxy HTTP_PROXY )) {
837 16 100       59 (exists $ENV{$env}) || next;
838 2 50       17 ($ENV{$env}=~/^(?:http:\/\/)([^:\/]+)(?::([0-9]+)){0,1}/o) || next;
839 2         12 $self->{proxy}={
840             host => $1,
841             port => $2,
842             };
843 2 100       9 (defined $self->{proxy}->{port}) || ($self->{proxy}->{port}=$StdPort{http_proxy});
844             }
845             } else {
846 1         5 $self->{proxy}=undef;
847             }
848              
849             # Set fastserver to 0 until we know better
850 9         22 $self->{fastserver}=0;
851              
852 9 100 66     46 if ((exists $hr->{fast}) && ($hr->{fast}==1)) {
853             ## Doing fast login, so return object
854 4         13 Debug(dump_hash($self,""));
855 4         19 return $self;
856             }
857            
858 5         7 my $GetMoods=1;
859 5 100 66     22 if ((exists $hr->{moods}) && ($hr->{moods}==0)) {
860 1         3 $GetMoods=0;
861             }
862 5         6 my $GetPics=1;
863 5 100 66     21 if ((exists $hr->{pics}) && ($hr->{pics}==0)) {
864 1         2 $GetPics=0;
865             }
866              
867             # Perform the actual login
868 5 50       36 $self->SendRequest("login", {
869             "moods" => $GetMoods,
870             "getpickws" => $GetPics,
871             "getpickurls" => $GetPics,
872             },undef) || return undef;
873              
874             # Now see if we can set fastserver
875 0 0 0     0 if ( (exists $self->{request}->{lj}->{fastserver}) &&
876             ($self->{request}->{lj}->{fastserver} == 1) ) {
877 0         0 $self->{fastserver}=1;
878             }
879              
880             # Moods
881 0         0 $self->{moods}=undef;
882 0         0 $self->{mood_map}=undef;
883             # Shared access journals
884 0         0 $self->{access}=undef;
885             # User groups
886 0         0 $self->{groups}=undef;
887             # Images defined
888 0         0 $self->{pictures}=undef;
889             # Default URL
890 0         0 $self->{defaultpicurl}=undef;
891             # Message from LJ
892 0         0 $self->{message}=undef;
893              
894             # Handle moods, etc.
895 0         0 my ($k,$v)=(undef,undef);
896 0         0 while(($k,$v) = each %{$self->{request}->{lj}}) {
  0         0  
897              
898             # Message from LJ
899 0 0       0 if ($k eq "message") {
    0          
    0          
    0          
    0          
    0          
    0          
900 0         0 $self->{message}=$v;
901              
902             # Moods
903             } elsif ($k=~/^mood_([0-9]+)_([a-z]+)/o) {
904 0         0 my ($id,$type)=($1,$2);
905 0 0       0 if (!defined $self->{moods}) {
906 0         0 $self->{moods}={};
907             }
908 0 0       0 if (!exists $self->{moods}->{$id}) {
909 0         0 $self->{moods}->{$id}={};
910             }
911 0 0       0 if ($type eq "id") {
    0          
912 0         0 $self->{moods}->{$id}->{id}=$v;
913             } elsif ($type eq "name") {
914 0         0 $self->{moods}->{$id}->{name}=$v
915             }
916              
917             # Picture key words
918             } elsif ($k=~/^(pickw_count)/o) {
919 0 0       0 if (!defined $self->{pictures}) {
920 0         0 $self->{pictures}={};
921             }
922             } elsif ($k eq "defaultpicurl") {
923 0         0 $self->{defaultpicurl}=$v;
924             } elsif ($k=~/^(pickw[^_]*)_([0-9]+)/o) {
925 0         0 my ($type,$id)=($1,$2);
926 0 0       0 if (!defined $self->{pictures}) {
927 0         0 $self->{pictures}={};
928             }
929 0 0       0 if (!exists $self->{pictures}->{$id}) {
930 0         0 $self->{pictures}->{$id}={};
931             }
932 0 0       0 if ($type eq "pickwurl") {
    0          
933 0         0 $self->{pictures}->{$id}->{url}=$v;
934             } elsif ($type eq "pickw") {
935 0         0 $self->{pictures}->{$id}->{name}=$v
936             }
937              
938             # Shared access journals
939             } elsif ($k=~/^access_([0-9]+)/) {
940 0 0       0 if (!defined $self->{access}) {
941 0         0 $self->{access}={};
942             }
943 0         0 $self->{access}->{$v}=1;
944              
945             # Groups
946             } elsif ($k=~/^frgrp_([0-9]+)_(.*)/) {
947 0         0 my ($id,$type)=($1,$2);
948 0 0       0 if (!defined $self->{groups}) {
949 0         0 $self->{groups}={
950             src => {}, # Source data
951             id => {}, # Id -> name mapping
952             name => {}, # Real data, name keyed
953             };
954             }
955 0 0       0 if (!exists $self->{groups}->{src}->{$id}) {
956 0         0 $self->{groups}->{src}->{$id}={};
957             }
958 0 0       0 if ($type eq "sortorder") {
    0          
959 0         0 $self->{groups}->{src}->{$id}->{sort}=$v;
960             } elsif ($type eq "name") {
961 0         0 $self->{groups}->{src}->{$id}->{name}=$v
962             }
963             }
964             }
965              
966             ## We now handle the group hash fully. Note in the case
967             ## of groups having the same name, only the first will
968             ## go into the name hash.
969 0         0 ($k,$v)=(undef,undef);
970 0         0 while(($k,$v)=each %{$self->{groups}->{src}}) {
  0         0  
971 0         0 $self->{groups}->{id}->{$k}=$v->{name};
972 0 0       0 if (!exists $self->{groups}->{name}->{$v->{name}}) {
973 0         0 $self->{groups}->{name}->{$v->{name}} = {
974             id => $k,
975             name => $v->{name},
976             sort => $v->{sort},
977             };
978             }
979             }
980              
981             ##
982             ## And now we handle the mood map fully
983             ##
984 0 0       0 if ($GetMoods) {
985 0         0 $self->{mood_map}={};
986 0         0 foreach (values %{$self->{moods}}) {
  0         0  
987 0         0 $self->{mood_map}->{lc($_->{name})}=$_->{id};
988             }
989             }
990              
991 0         0 Debug(dump_hash($self,""));
992            
993             ## Logged in, so return self.
994 0         0 return $self;
995             }
996              
997             ## Define reference from new to login
998             *new="";
999             *new=\&login;
1000              
1001              
1002             =pod
1003              
1004             =back
1005              
1006             =head2 Getting data from the LiveJournal login
1007              
1008             =over 4
1009              
1010             =item $lj->message()
1011              
1012             Returns back a message set in the LiveJournal system. Either
1013             returns back the message or C if no message is set.
1014              
1015             Example code:
1016              
1017             my $msg = $lj->message();
1018             (defined $msg) &&
1019             print "LJ Message: $msg\n";
1020              
1021             =cut
1022             sub message($) {
1023 1     1 1 66 my $self=shift;
1024 1         4 return $self->{message};
1025             }
1026              
1027             =pod
1028              
1029             =item $lj->moods($hash_ref)
1030              
1031             Takes a reference to a hash and fills it with information about
1032             the moods returned back by the server. Either returns back the
1033             same hash reference or C on error.
1034              
1035             Note that if the LiveJournal
1036             object was created with either C set to C<0> or
1037             with C set to C<1> then this function will always return
1038             an error.
1039              
1040             The hash the given reference is pointed to is emptied before
1041             it is used and after a successful call the hash given will
1042             contain:
1043              
1044             %hash = (
1045             list => [ list of mood names, alphabetical ]
1046             moods => {
1047             mood_name => mood_id
1048             }
1049             idents => {
1050             mood_id => mood_name
1051             }
1052             )
1053              
1054              
1055             Example code:
1056              
1057             my %Moods=();
1058             if (!defined $lj->moods(\%Moods)) {
1059             die "$0: LJ error - $LJ::Simple::error";
1060             }
1061             foreach (@{$Moods{list}}) {
1062             print "$_ -> $Moods{moods}->{$_}\n";
1063             }
1064            
1065              
1066             =cut
1067             sub moods($$) {
1068 1     1 1 103 my $self=shift;
1069 1         91 my ($hr) = @_;
1070 1         3 $LJ::Simple::error="";
1071 1 50       6 if (ref($hr) ne "HASH") {
1072 0         0 $LJ::Simple::error="CODE: moods() not given a hash reference";
1073 0         0 return undef;
1074             }
1075 1 50       5 if (!defined $self->{moods}) {
1076 1         2 $LJ::Simple::error="Unable to return moods - not requested at login";
1077 1         4 return undef;
1078             }
1079 0         0 %{$hr}=(
  0         0  
1080             list => [],
1081             moods => {},
1082             idents => {},
1083             );
1084 0         0 my ($k,$v);
1085 0         0 while(($k,$v)=each %{$self->{moods}}) {
  0         0  
1086 0         0 push(@{$hr->{list}},$v->{name});
  0         0  
1087 0         0 $hr->{moods}->{$v->{name}}=$v->{id};
1088 0         0 $hr->{idents}->{$v->{id}}=$v->{name};
1089             }
1090 0         0 $hr->{list} = [ (sort { $a cmp $b } @{$hr->{list}}) ];
  0         0  
  0         0  
1091 0         0 return $hr;
1092             }
1093              
1094             =pod
1095              
1096             =item $lj->communities()
1097              
1098             Returns a list of shared access communities the user logged in can
1099             post to. Returns an empty list if no communities are available
1100              
1101             Example code:
1102              
1103             my @communities = $lj->communities();
1104             print join("\n",@communities),"\n";
1105              
1106             =cut
1107             sub communities($) {
1108 1     1 1 62 my $self=shift;
1109 1         3 $LJ::Simple::error="";
1110 1 50       16 (defined $self->{access}) || return ();
1111 0         0 return sort {$a cmp $b} (keys %{$self->{access}});
  0         0  
  0         0  
1112             }
1113              
1114              
1115             =pod
1116              
1117             =item $lj->MemberOf($community)
1118              
1119             Returns C<1> if the user is a member of the named community. Returns
1120             C<0> otherwise.
1121              
1122             Example code:
1123              
1124             if ($lj->MemberOf("some_community")) {
1125             :
1126             :
1127             :
1128             }
1129              
1130             =cut
1131             sub MemberOf($$) {
1132 1     1 1 59 my $self=shift;
1133 1         2 my ($community)=@_;
1134 1         3 $LJ::Simple::error="";
1135 1 50       5 (defined $self->{access}) || return 0;
1136 0         0 return (exists $self->{access}->{$community});
1137             }
1138              
1139             =pod
1140              
1141             =item $lj->groups($hash_ref)
1142              
1143             Takes a reference to a hash and fills it with information about
1144             the friends groups the user has configured for themselves. Either
1145             returns back the hash reference or C on error.
1146              
1147             The hash the given reference points to is emptied before it is
1148             used and after a successful call the hash given will contain
1149             the following:
1150              
1151             %hash = (
1152             "name" => {
1153             "Group name" => {
1154             id => "Number of the group",
1155             sort => "Sort order",
1156             name => "Group name (copy of key)",
1157             },
1158             },
1159             "id" => {
1160             "Id" => "Group name",
1161             },
1162             );
1163              
1164             Example code:
1165              
1166             my %Groups=();
1167             if (!defined $lj->groups(\%Groups)) {
1168             die "$0: LJ error - $LJ::Simple::error";
1169             }
1170             my ($id,$name)=(undef,undef);
1171             while(($id,$name)=each %{$Groups{id}}) {
1172             my $srt=$Groups{name}->{$name}->{sort};
1173             print "$id\t=> $name [$srt]\n";
1174             }
1175              
1176             =cut
1177             sub groups($$) {
1178 1     1 1 59 my $self=shift;
1179 1         2 my ($hr) = @_;
1180 1         2 $LJ::Simple::error="";
1181 1 50       5 if (ref($hr) ne "HASH") {
1182 0         0 $LJ::Simple::error="CODE: groups() not given a hash reference";
1183 0         0 return undef;
1184             }
1185 1 50       4 if (!defined $self->{groups}) {
1186 1         2 $LJ::Simple::error="Unable to return groups - none defined";
1187 1         3 return undef;
1188             }
1189 0         0 %{$hr}=(
  0         0  
1190             name => {},
1191             id => {},
1192             );
1193 0         0 my ($k,$v);
1194 0         0 while(($k,$v)=each %{$self->{groups}->{id}}) {
  0         0  
1195 0         0 $hr->{id}->{$k}=$v;
1196             }
1197 0         0 while(($k,$v)=each %{$self->{groups}->{name}}) {
  0         0  
1198 0         0 $hr->{name}->{$k}={};
1199 0         0 my ($lk,$lv);
1200 0         0 while(($lk,$lv)=each %{$self->{groups}->{name}->{$k}}) {
  0         0  
1201 0         0 $hr->{name}->{$k}->{$lk}=$lv;
1202             }
1203             }
1204 0         0 return $hr;
1205             }
1206              
1207              
1208             =pod
1209              
1210             =item $lj->MapGroupToId($group_name)
1211              
1212             Used to map a given group name to its identity. On
1213             success returns the identity for the group name. On
1214             failure it returns C and sets
1215             C<$LJ::Simple::error>.
1216              
1217             =cut
1218             sub MapGroupToId($$) {
1219 1     1 1 69 my $self=shift;
1220 1         3 my ($grp)=@_;
1221 1         2 $LJ::Simple::error="";
1222 1 50       4 if (!defined $self->{groups}) {
1223 1         2 $LJ::Simple::error="Unable to map group to id - none defined";
1224 1         5 return undef;
1225             }
1226 0 0       0 if (!exists $self->{groups}->{name}->{$grp}) {
1227 0         0 $LJ::Simple::error="No such group";
1228 0         0 return undef;
1229             }
1230 0         0 return $self->{groups}->{name}->{$grp}->{id};
1231             }
1232              
1233              
1234             =pod
1235              
1236             =item $lj->MapIdToGroup($id)
1237              
1238             Used to map a given identity to its group name. On
1239             success returns the group name for the identity. On
1240             failure it returns C and sets
1241             C<$LJ::Simple::error>.
1242              
1243             =cut
1244             sub MapIdToGroup($$) {
1245 1     1 1 62 my $self=shift;
1246 1         3 my ($id)=@_;
1247 1         3 $LJ::Simple::error="";
1248 1 50       5 if (!defined $self->{groups}) {
1249 1         3 $LJ::Simple::error="Unable to map group to id - none defined";
1250 1         2 return undef;
1251             }
1252 0 0       0 if (!exists $self->{groups}->{id}->{$id}) {
1253 0         0 $LJ::Simple::error="No such group ident";
1254 0         0 return undef;
1255             }
1256 0         0 return $self->{groups}->{id}->{$id};
1257             }
1258              
1259             =pod
1260              
1261              
1262             =item $lj->pictures($hash_ref)
1263              
1264             Takes a reference to a hash and fills it with information about
1265             the pictures the user has configured for themselves. Either
1266             returns back the hash reference or C on error. Note that
1267             the user has to have defined picture keywords for this to work.
1268              
1269             Note that if the LiveJournal
1270             object was created with either C set to C<0> or
1271             with C set to C<1> then this function will always return
1272             an error.
1273              
1274             The hash the given reference points to is emptied before it is
1275             used and after a successful call the hash given will contain
1276             the following:
1277              
1278             %hash = (
1279             "keywords" => "URL of picture",
1280             );
1281              
1282             Example code:
1283              
1284             my %pictures=();
1285             if (!defined $lj->pictures(\%pictures)) {
1286             die "$0: LJ error - $LJ::Simple::error";
1287             }
1288             my ($keywords,$url)=(undef,undef);
1289             while(($keywords,$url)=each %pictures) {
1290             print "\"$keywords\"\t=> $url\n";
1291             }
1292              
1293              
1294             =cut
1295             sub pictures($$) {
1296 1     1 1 69 my $self=shift;
1297 1         2 my ($hr)=@_;
1298 1         3 $LJ::Simple::error="";
1299 1 50       4 if (!defined $self->{pictures}) {
1300 1         3 $LJ::Simple::error="Unable to return pictures - none defined";
1301 1         3 return undef;
1302             }
1303 0 0       0 if (ref($hr) ne "HASH") {
1304 0         0 $LJ::Simple::error="CODE: pictures() not given a hash reference";
1305 0         0 return undef;
1306             }
1307 0         0 %{$hr}=();
  0         0  
1308 0         0 foreach (values %{$self->{pictures}}) {
  0         0  
1309 0         0 $hr->{$_->{name}}=$_->{url};
1310             }
1311 0         0 return $hr;
1312             }
1313              
1314             =pod
1315              
1316             =item $lj->DefaultPicURL()
1317              
1318             Returns the URL of the default picture used by the user.
1319              
1320             Note that if the LiveJournal
1321             object was created with either C set to C<0> or
1322             with C set to C<1> then this function will always return
1323             an error.
1324              
1325             Example code:
1326              
1327             print $lj->DefaultPicURL(),"\n";
1328              
1329             =cut
1330             sub DefaultPicURL($) {
1331 0     0 1 0 my $self=shift;
1332 0         0 $LJ::Simple::error="";
1333 0 0       0 if (!defined $self->{defaultpicurl}) {
1334 0         0 $LJ::Simple::error="Unable to return default picture URL - none defined";
1335 0         0 return undef;
1336             }
1337 0         0 return $self->{defaultpicurl};
1338             }
1339              
1340             =pod
1341              
1342             =item $lj->user()
1343              
1344             Returns the username used to log into LiveJournal
1345              
1346             Example code:
1347            
1348             my $user = $lj->user();
1349              
1350             =cut
1351             sub user($) {
1352 0     0 1 0 my $self=shift;
1353 0         0 $LJ::Simple::error="";
1354 0         0 return $self->{auth}->{user};
1355             }
1356              
1357              
1358             =pod
1359              
1360             =item $lj->fastserver()
1361              
1362             Used to tell if the user which was logged into the LiveJournal system can use the
1363             fast servers or not. Returns C<1> if the user can use the fast servers, C<0>
1364             otherwise.
1365              
1366             Example code:
1367              
1368             if ($lj->fastserver()) {
1369             print STDERR "Using fast server for ",$lj->user(),"\n";
1370             }
1371              
1372             =cut
1373             sub fastserver($) {
1374 0     0 1 0 my $self=shift;
1375 0         0 $LJ::Simple::error="";
1376 0         0 return $self->{fastserver};
1377             }
1378              
1379             =pod
1380              
1381             =back
1382              
1383             =head2 Tags
1384              
1385             =over 4
1386              
1387             =item $lj->GetTags()
1388              
1389             Returns a list of the tags the user has defined. The list returned
1390             contains at least one entry, the number of entries in the list.
1391             This value can range from 0 to however
1392             many tags are in the list. In the event of a failure this value is
1393             undefined.
1394              
1395             The list of tags is a list of hash references which contain data
1396             about the tag; each hash referenced will contain the following:
1397              
1398             {
1399             name => The name of the tag
1400             uses => Number of times has the tag been used in total
1401             security => Visibility of the tag; this can be "public", "private",
1402             "friends" or "group"
1403             display => If defined this indicates that the tag is visible to
1404             the S2 style system. If set to undef the tag is usable,
1405             just not exposed to S2
1406             }
1407              
1408             The list of tags is returned ordered by the tag names.
1409              
1410             Example code:
1411              
1412             # Print out the names of the tags
1413             my ($count,@Tags)=$lj->GetTags();
1414             (defined $count) || die "$0: Failed to get list of tags - $LJ::Simple::error\n";
1415             print "Total tags: $count\n";
1416             map { print "$_->{name}\n"; } (@Tags);
1417              
1418             =cut
1419             sub GetTags($) {
1420 0     0 1 0 my $self=shift;
1421 0         0 $LJ::Simple::error="";
1422 0         0 my %Event=();
1423 0         0 my %Resp=();
1424 0 0       0 $self->SendRequest("getusertags",\%Event,\%Resp) || return undef;
1425 0         0 my %Tags=();
1426 0         0 while(my ($name,$val) = each %Resp) {
1427 0 0       0 ($name=~/tag_([0-9]+)_(.*)/o) || next;
1428 0         0 my ($id,$key)=($1,$2);
1429 0 0       0 (exists $Tags{$id}) || ($Tags{$id}={});
1430 0         0 $Tags{$id}->{$key}=$val;
1431             }
1432 0         0 my @Return=();
1433 0         0 foreach my $tag_id (keys %Tags) {
1434 0         0 push(@Return,{});
1435 0         0 my $dest=$Return[$#Return];
1436 0         0 my $src=$Tags{$tag_id};
1437 0 0       0 map { $dest->{$_} = (exists $src->{$_})?$src->{$_}:undef } (qw( name uses security display ));
  0         0  
1438             }
1439 0         0 return(scalar(@Return),(sort {lc($a->{name}) cmp lc($b->{name})} @Return));
  0         0  
1440             }
1441              
1442              
1443             =pod
1444              
1445             =back
1446              
1447             =head2 Dealing with friends
1448              
1449             =over 4
1450              
1451             =item $lj->GetFriendOf()
1452              
1453             Returns a list of the other LiveJournal users who list the current
1454             user as a friend. The list returned contains at least one entry, the
1455             number of entries in the list. This value can range from 0 to however
1456             many users are in the list. In the event of a failure this value is
1457             undefined.
1458              
1459             The list of friends is a list of hash references which contain data
1460             about the users who list the current user as a friend. Each hash
1461             referenced will contain the following:
1462              
1463             {
1464             user => The LiveJournal username
1465             name => The full name of the user
1466             fg => The foreground colour which represents the user
1467             bg => The background colour which represents the user
1468             status => The status of the user
1469             type => The type of the user
1470             }
1471              
1472             Both the C and C values are stored in the format of "C<#>III"
1473             where the I, I, I values are given as two digit hexadecimal numbers which
1474             range from C<00> to C.
1475              
1476             The C of a user can be one of C, C, C or C.
1477              
1478             The C of a user can either be C which means that the user is a normal
1479             LiveJournal user or it can be C which means that the user is actually a
1480             community which the current LJ user is a member of.
1481              
1482             It should be noted that any of the values in the hash above can be undefined if
1483             that value was not returned from the LiveJournal server.
1484              
1485             The returned list is ordered by the LiveJournal login names of the users.
1486              
1487             Example code:
1488              
1489             my ($num_friends_of,@FriendOf)=$lj->GetFriendOf();
1490             (defined $num_friends_of) ||
1491             die "$0: Failed to get friends of user - $LJ::Simple::error\n";
1492             print "LJ login\tReal name\tfg\tbg\tStatus\tType\n";
1493             foreach (@FriendOf) {
1494             print "$_->{user}\t",
1495             "$_->{name}\t",
1496             "$_->{fg}\t",
1497             "$_->{bg}\t",
1498             "$_->{status}\t",
1499             "$_->{type}\n";
1500             }
1501              
1502             =cut
1503             sub GetFriendOf($) {
1504 0     0 1 0 my $self=shift;
1505 0         0 $LJ::Simple::error="";
1506 0         0 my %Event=();
1507 0         0 my %Resp=();
1508 0 0       0 $self->SendRequest("friendof",\%Event,\%Resp) || return undef;
1509 0         0 my %Friends=();
1510 0         0 my ($k,$v);
1511 0         0 while(($k,$v)=each %Resp) {
1512 0 0       0 ($k=~/^friendof_([0-9]+)_(.*)/) || next;
1513 0         0 my ($id,$type)=($1,$2);
1514 0 0       0 if (!exists $Friends{$id}) {
1515 0         0 $Friends{$id}={
1516             user => undef,
1517             name => undef,
1518             bg => undef,
1519             fg => undef,
1520             status => "active",
1521             type => "user",
1522             };
1523             }
1524 0         0 $Friends{$id}->{$type}=$v;
1525             }
1526 0         0 my @lst=sort {$a->{user} cmp $b->{user}} (values %Friends);
  0         0  
1527 0         0 return ($#lst+1,@lst);
1528             }
1529              
1530              
1531             =pod
1532              
1533             =item $lj->GetFriends()
1534              
1535             Returns a list of the other LiveJournal user who are listed as friends of
1536             the current user. The list returned contains a least one entry, the
1537             number of entries in the list. This value can range from 0 to however
1538             many users are in the list. In the event of a failure this value is
1539             undefined.
1540              
1541             The list of friends is a list of hash references which contain data
1542             about the users who list the current user as a friend. Each hash
1543             referenced will contain the following:
1544              
1545             {
1546             user => The LiveJournal username
1547             name => The full name of the user
1548             fg => The foreground colour which represents the user
1549             bg => The background colour which represents the user
1550             dob => The date of birth for the user
1551             birthday => The birthday of the user
1552             groups => The list of friends groups this user is in
1553             groupmask => The actual group mask for this user
1554             status => The status of the user
1555             type => The type of the user
1556             }
1557              
1558             Both the C and C values are stored in the format of "C<#>III"
1559             where the I, I, I values are given as two digit hexadecimal numbers which
1560             range from C<00> to C.
1561              
1562             The C value is stored as a Unix timestamp; that is seconds since epoch. If the
1563             user has no date of birth defined B they have only given their birthday then this
1564             value will be C.
1565              
1566             The C value is the date of the user's next birthday given as a Unix timestamp.
1567              
1568             The C value is a reference to a list of the friends group this user is a member
1569             of. It should be noted that to have any items in the list the user must be a
1570             member of a friends group and the C method must B have been called
1571             with the fast login option.
1572              
1573             The C value is the actual group mask for the user. This is used to build
1574             the C list. It is a 32-bit number where each bit represents membership of a
1575             given friends group. Bits 0 and 31 are reserved; all other bits can be used. The bit
1576             a group corresponds to is taken by bit-shifting 1 by the group id number.
1577              
1578             The C of a user can be one of C, C, C or C.
1579              
1580             The C of a user can either be C which means that the user is a normal
1581             LiveJournal user or it can be C which means that the user is actually a
1582             community which the current LJ user is a member of.
1583              
1584             It should be noted that any of the values in the hash above can be undefined if
1585             that value was not returned from the LiveJournal server.
1586              
1587             The returned list is ordered by the LiveJournal login names of the users.
1588              
1589             Example code:
1590              
1591             use POSIX;
1592            
1593             my ($num_friends,@Friends)=$lj->GetFriends();
1594             (defined $num_friends) ||
1595             die "$0: Failed to get friends - $LJ::Simple::error\n";
1596            
1597             my $f=undef;
1598             foreach $f (@Friends) {
1599             foreach (qw(dob birthday)) {
1600             (defined $f->{$_}) || next;
1601             $f->{$_}=strftime("%Y/%m/%d",localtime($f->{$_}));
1602             }
1603             my ($k,$v)=(undef,undef);
1604             while(($k,$v)=each %{$f}) {
1605             (!defined $v) && ($f->{$k}="[undefined]");
1606             }
1607             print "$f->{user}\n";
1608             print " Name : $f->{name}\n";
1609             print " Colors : fg->$f->{fg} bg->$f->{bg}\n";
1610             print " DOB : $f->{dob}\n";
1611             print " Next birthday: $f->{birthday}\n";
1612             print " Status : $f->{status}\n";
1613             print " Type : $f->{type}\n";
1614             if ($#{$f->{groups}}>-1) {
1615             print " Friend groups:\n";
1616             print " + ",join("\n + ",@{$f->{groups}}),"\n";
1617             } else {
1618             print " Friend groups: [none]\n";
1619             }
1620             print "\n";
1621             }
1622              
1623             =cut
1624             sub GetFriends($) {
1625 0     0 1 0 my $self=shift;
1626 0         0 $LJ::Simple::error="";
1627 0         0 my %Event=(
1628             includegroups => 1,
1629             includebdays => 1,
1630             );
1631 0         0 my %Resp=();
1632 0 0       0 $self->SendRequest("getfriends",\%Event,\%Resp) || return undef;
1633 0         0 my %Friends=();
1634 0         0 my ($k,$v);
1635 0         0 while(($k,$v)=each %Resp) {
1636 0 0       0 ($k=~/^friend_([0-9]+)_(.*)/) || next;
1637 0         0 my ($id,$type)=($1,$2);
1638 0 0       0 if (!exists $Friends{$id}) {
1639 0         0 $Friends{$id}={
1640             user => undef,
1641             name => undef,
1642             bg => undef,
1643             fg => undef,
1644             dob => undef,
1645             birthday => undef,
1646             groups => [],
1647             groupmask => undef,
1648             status => "active",
1649             type => "user",
1650             };
1651             }
1652 0 0       0 if ($type eq "birthday") {
1653 0 0       0 ($v=~/([0-9]+)-([0-9]{2})-([0-9]{2})/o) || next;
1654 0         0 my @tm=(0,0,0,$3,$2,$1-1900);
1655 0 0       0 if ($tm[5]>0) {
1656 0         0 $Friends{$id}->{dob}=mktime(@tm);
1657 0 0       0 if (!defined $Friends{$id}->{dob}) {
1658 0         0 $LJ::Simple::error="Failed to convert time $v into Unix timestamp";
1659 0         0 return undef;
1660             }
1661             }
1662 0         0 $tm[5]=(localtime(time()))[5];
1663 0         0 $Friends{$id}->{birthday}=mktime(@tm);
1664 0 0       0 if (!defined $Friends{$id}->{birthday}) {
1665 0         0 $LJ::Simple::error="Failed to convert time $v into Unix timestamp";
1666 0         0 return undef;
1667             }
1668             } else {
1669 0         0 $Friends{$id}->{$type}=$v;
1670             }
1671             }
1672 0 0       0 if (defined $self->{groups}) {
1673 0         0 my $id=undef;
1674 0         0 foreach $id (values %Friends) {
1675 0 0       0 (defined $id->{groupmask}) || next;
1676 0         0 foreach (values %{$self->{groups}->{name}}) {
  0         0  
1677 0         0 my $bit=1 << $_->{id};
1678 0 0       0 if (($id->{groupmask} & $bit) == $bit) {
1679 0         0 push(@{$id->{groups}},$_->{name});
  0         0  
1680             }
1681             }
1682             }
1683             }
1684 0         0 my @lst=sort {$a->{user} cmp $b->{user}} (values %Friends);
  0         0  
1685 0         0 return ($#lst+1,@lst);
1686             }
1687              
1688              
1689             =pod
1690              
1691             =item $lj->CheckFriends(@groups)
1692              
1693             This routine is used to poll the LiveJournal server to see if your friends list
1694             has been updated or not. This routine returns a list. The first item in the
1695             list is a value which holds C<1> if there has been an update
1696             to your friends list and C<0> if not. The second item in the list holds the number
1697             of seconds you must wait before calling C again.
1698             In the event of an error C is returned in the first item of the list.
1699              
1700             The routine can be given an optional list of friends group to check instead of
1701             just looking at all of the friends for the user.
1702              
1703             Example code:
1704              
1705             while(1) {
1706             my ($new_friends,$next_update)=$lj->CheckFriends();
1707             (defined $new_friends) ||
1708             die "$0: Failed to check friends - $LJ::Simple::error\n";
1709             ($new_friends) && print "Friends list updated\n";
1710             sleep($next_update+1);
1711             }
1712              
1713             =cut
1714             sub CheckFriends($@) {
1715 0     0 1 0 my $self=shift;
1716 0         0 my (@groups)=@_;
1717 0         0 my %Event=();
1718 0         0 my %Resp=();
1719 0 0       0 if ($#groups>-1) {
1720 0 0       0 if (!defined $self->{groups}) {
1721 0         0 $LJ::Simple::error="Groups not requested at login";
1722 0         0 return 0;
1723             }
1724 0         0 my $g;
1725 0         0 my $mask=0;
1726 0         0 foreach $g (@groups) {
1727 0 0       0 if (!exists $self->{groups}->{name}->{$g}) {
1728 0         0 $LJ::Simple::error="Group \"$g\" does not exist";
1729 0         0 return 0;
1730             }
1731 0         0 $mask=$mask | (1 << $self->{groups}->{name}->{$g}->{id});
1732             }
1733 0         0 $Event{mask}=$mask;
1734             }
1735 0 0       0 if (exists $self->{checkfriends}) {
1736 0         0 $Event{lastupdate}=$self->{checkfriends}->{lastupdate};
1737 0         0 my $currtime=time();
1738 0 0       0 if ($currtime<$self->{checkfriends}->{interval}) {
1739 0         0 $LJ::Simple::error="Insufficent time left between CheckFriends() call";
1740 0         0 return undef;
1741             }
1742             } else {
1743 0         0 $self->{checkfriends}={};
1744             }
1745 0 0       0 $self->SendRequest("checkfriends",\%Event,\%Resp) || return undef;
1746 0         0 $self->{checkfriends}->{lastupdate}=$Resp{lastupdate};
1747 0         0 $self->{checkfriends}->{interval}=time() + $Resp{interval};
1748 0         0 return ($Resp{new},$Resp{interval});
1749             }
1750              
1751              
1752             =pod
1753              
1754             =item $lj->GetDayCounts($hash_ref,$journal)
1755              
1756             This routine is given a reference to hash which it fills with information
1757             on the journal entries posted to the LiveJournal we are currently associated
1758             with. On success the reference to the hash will be returned. On error
1759             C is returned.
1760              
1761             There is an optional argument - C<$journal> - which can be used to gather this
1762             data for a shared journal the user has access to. If not required then this
1763             value should be C or an empty string.
1764              
1765             The key to the hash is a date, given as seconds since epoch (I C)
1766             and the value is the number of entries made on that day. Only dates which have
1767             journal entries made against them will have values in the hash; thus it can be
1768             assumed that if a date is B in the hash then no journal entries were made
1769             on that day.
1770              
1771             The hash will be emptied before use.
1772              
1773             Example code:
1774              
1775             use POSIX;
1776             (defined $lj->GetDayCounts(\%gdc_hr,undef))
1777             || die "$0: Failed to get day counts - $LJ::Simple::error\n";
1778            
1779             foreach (sort {$a<=>$b} keys %gdc_hr) {
1780             printf("%s %03d\n",strftime("%Y/%m/%d",localtime($_)),$gdc_hr{$_});
1781             }
1782              
1783             =cut
1784             sub GetDayCounts($$$) {
1785 0     0 1 0 my $self=shift;
1786 0         0 my ($hr,$journal)=@_;
1787 0         0 $LJ::Simple::error="";
1788 0 0       0 if (ref($hr) ne "HASH") {
1789 0         0 my $r=ref($hr);
1790 0         0 $LJ::Simple::error="CODE: GetDayCounts() given \"$r\", not a hash reference";
1791 0         0 return undef;
1792             }
1793 0         0 %{$hr}=();
  0         0  
1794 0         0 my %Event=();
1795 0         0 my %Resp=();
1796 0 0 0     0 if ((defined $journal) && ($journal ne "")) {
1797 0         0 $Event{usejournal}=$journal;
1798             }
1799 0 0       0 $self->SendRequest("getdaycounts",\%Event,\%Resp) || return undef;
1800 0         0 my ($k,$v);
1801 0         0 while(($k,$v)=each %Resp) {
1802 0 0       0 ($k=~/([0-9]+)-([0-9]+)-([0-9]+)/o) || next;
1803 0 0       0 ($v==0) && next;
1804 0         0 my $timet=mktime(0,0,0,$3,$2-1,$1-1900);
1805 0 0       0 if (!defined $timet) {
1806 0         0 $LJ::Simple::error="Failed to convert date $k into Unix timestamp";
1807 0         0 return undef;
1808             }
1809 0 0       0 if (exists $hr->{$timet}) {
1810 0         0 $hr->{$timet}=$hr->{$timet}+$v;
1811             } else {
1812 0         0 $hr->{$timet}=$v;
1813             }
1814             }
1815 0         0 return $hr;
1816             }
1817              
1818              
1819             =pod
1820              
1821             =item $lj->GetFriendGroups($hash_ref)
1822              
1823             This routine is given a reference to a hash which it fills with information
1824             on the friends groups the user has defined. On success the reference to the
1825             hash will be returned. On error C is returned.
1826              
1827             The hash key is the id number of the friends group as it is possible to
1828             have multiple friends groups with the same name. Each hash value is a hash
1829             reference which points to the following hash:
1830              
1831             {
1832             id => Id of the group; used to create permission masks
1833             name => Name of the group
1834             sort => Sort order number from 0 to 255
1835             public => Public group ? 1 for yes, 0 for no
1836             }
1837              
1838             The hash given will be emptied before use.
1839              
1840             Example code:
1841              
1842             my %fg=();
1843             (defined $lj->GetFriendGroups(\%fg)) ||
1844             die "$0: Failed to get groups - $LJ::Simple::error\n";
1845            
1846             my $format="| %-4s | %-2s | %-6s | %-40s |\n";
1847             my $line=sprintf($format,"","","","");
1848             $line=~s/\|/+/go;
1849             $line=~s/ /-/go;
1850             print $line;
1851             printf($format,"Sort","Id","Public","Group");
1852             print $line;
1853            
1854             foreach (sort {$fg{$a}->{sort}<=>$fg{$b}->{sort}} keys %fg) {
1855             my $hr=$fg{$_};
1856             my $pub="No";
1857             $hr->{public} && ($pub="Yes");
1858             printf($format,$hr->{sort},$hr->{id},$pub,$hr->{name});
1859             }
1860            
1861             print $line;
1862              
1863             In case you're wondering, the above code outputs something similar to
1864             the following:
1865              
1866             +------+----+--------+------------------------------------------+
1867             | Sort | Id | Public | Group |
1868             +------+----+--------+------------------------------------------+
1869             | 5 | 1 | Yes | Good Friends |
1870             | 10 | 2 | No | Communities |
1871             +------+----+--------+------------------------------------------+
1872              
1873             =cut
1874             sub GetFriendGroups($$) {
1875 0     0 1 0 my $self=shift;
1876 0         0 my ($hr)=@_;
1877 0         0 $LJ::Simple::error="";
1878 0 0       0 if (ref($hr) ne "HASH") {
1879 0         0 my $r=ref($hr);
1880 0         0 $LJ::Simple::error="CODE: GetFriendGroups() given \"$r\", not a hash reference";
1881 0         0 return undef;
1882             }
1883 0         0 %{$hr}=();
  0         0  
1884 0         0 my %Event=();
1885 0         0 my %Resp=();
1886 0 0       0 $self->SendRequest("getfriendgroups",\%Event,\%Resp) || return undef;
1887 0         0 my ($k,$v);
1888 0         0 while(($k,$v)=each %Resp) {
1889 0 0       0 $k=~/^frgrp_([0-9]+)_(.*)$/o || next;
1890 0         0 my ($id,$name)=($1,$2);
1891 0 0       0 if (!exists $hr->{$id}) {
1892 0         0 $hr->{$id}={
1893             id => $id,
1894             public => 0,
1895             };
1896             }
1897 0 0       0 ($name eq "sortorder") && ($name="sort");
1898 0         0 $hr->{$id}->{$name}=$v;
1899             }
1900 0         0 return $hr;
1901             }
1902              
1903             =pod
1904              
1905             =back
1906              
1907             =head2 The creation and editing of entries
1908              
1909             =over 4
1910              
1911             =item $lj->NewEntry($event)
1912              
1913             Prepares for a new journal entry to be sent into the LiveJournal system.
1914             Takes a reference to a hash which will be emptied and prepared for use
1915             by the other routines used to prepare a journal entry for posting.
1916              
1917             On success returns C<1>, on failure returns C<0>
1918              
1919             Example code:
1920              
1921             my %Entry=();
1922             $lj->NewEntry(\%Entry)
1923             || die "$0: Failed to prepare new post - $LJ::Simple::error\n";
1924              
1925             =cut
1926             sub NewEntry($$) {
1927 0     0 1 0 my $self=shift;
1928 0         0 my ($event)=@_;
1929 0         0 $LJ::Simple::error="";
1930 0 0       0 if (ref($event) ne "HASH") {
1931 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
1932 0         0 return 0;
1933             }
1934             ## Build the event hash - put defaults in
1935 0         0 my $ltime=time();
1936 0         0 my @ltime=localtime($ltime);
1937 0         0 %{$event}=(
  0         0  
1938             __new_entry => 1,
1939             event => undef,
1940             lineenddings => "unix",
1941             subject => undef,
1942             year => $ltime[5]+1900,
1943             mon => $ltime[4]+1,
1944             day => $ltime[3],
1945             hour => $ltime[2],
1946             min => $ltime[1],
1947             __timet => $ltime,
1948             );
1949 0         0 return 1;
1950             }
1951              
1952              
1953             =pod
1954              
1955             =item $lj->SetDate($event,$time_t)
1956              
1957             Sets the date for the event being built from the given C (i.e. seconds
1958             since epoch) value. Bare in mind that you may need to call
1959             C<$lj-ESetprop_backdate(\%Event,1)> to backdate the journal entry if the journal being
1960             posted to has events more recent than the date being set here. Returns C<1> on
1961             success, C<0> on failure.
1962              
1963             If the value given for C is C then the current time is used.
1964             If the value given for C is negative then it is taken to be relative
1965             to the current time, i.e. a value of C<-3600> is an hour earlier than the
1966             current time.
1967              
1968             Note that C is called to convert the C value into
1969             the year, month, day, hours and minute values required by LiveJournal.
1970             Thus the time given to LiveJournal will be the local time as shown on
1971             the machine the code is running on.
1972              
1973             Example code:
1974              
1975             ## Set date to current time
1976             $lj->SetDate(\%Event,undef)
1977             || die "$0: Failed to set date of entry - $LJ::Simple::error\n";
1978              
1979             ## Set date to Wed Aug 14 11:56:42 2002 GMT
1980             $lj->SetDate(\%Event,1029326202)
1981             || die "$0: Failed to set date of entry - $LJ::Simple::error\n";
1982              
1983             ## Set date to an hour ago
1984             $lj->SetDate(\%Event,-3600)
1985             || die "$0: Failed to set date of entry - $LJ::Simple::error\n";
1986              
1987             =cut
1988             sub SetDate($$$) {
1989 0     0 1 0 my $self=shift;
1990 0         0 my ($event,$timet)=@_;
1991 0         0 $LJ::Simple::error="";
1992 0 0       0 if (ref($event) ne "HASH") {
1993 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
1994 0         0 return 0;
1995             }
1996 0 0       0 (defined $timet) || ($timet=time());
1997 0 0       0 if ($timet<0) {
1998 0         0 $timet=time() + $timet;
1999             }
2000 0         0 my @ltime=localtime($timet);
2001 0         0 $event->{__timet}=$timet;
2002 0         0 $event->{year}=$ltime[5]+1900;
2003 0         0 $event->{mon}=$ltime[4]+1;
2004 0         0 $event->{day}=$ltime[3];
2005 0         0 $event->{hour}=$ltime[2];
2006 0         0 $event->{min}=$ltime[1];
2007 0         0 return 1;
2008             }
2009              
2010              
2011             =pod
2012              
2013             =item $lj->SetMood($event,$mood)
2014              
2015             Given a mood this routine sets the mood for the journal entry. Unlike the
2016             more direct C<$lj-ESetprop_current_mood()> and C<$lj-ESetprop_current_mood_id(\%Event,)>
2017             routines, this routine will attempt to first attempt to find the mood given
2018             to it in the mood list returned by the LiveJournal server. If it is unable to
2019             find a suitable mood then it uses the text given.
2020              
2021             Note that if the LiveJournal
2022             object was created with either C set to C<0> or
2023             with C set to C<1> then this function will not attempt to find the
2024             mood name given in C<$mood> in the mood list.
2025              
2026             Returns C<1> on success, C<0> otherwise.
2027              
2028             Example code:
2029              
2030             $lj->SetMood(\%Event,"happy")
2031             || die "$0: Failed to set mood - $LJ::Simple::error\n";
2032              
2033             =cut
2034             sub SetMood($$$) {
2035 0     0 1 0 my $self=shift;
2036 0         0 my ($event,$mood) = @_;
2037 0         0 $LJ::Simple::error="";
2038 0 0       0 if (ref($event) ne "HASH") {
2039 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2040 0         0 return 0;
2041             }
2042 0 0       0 if (!defined $mood) {
2043 0         0 $LJ::Simple::error="CODE: given undef value for a mood";
2044 0         0 return 0;
2045             }
2046             ## Simple opt - none of the mood names have a space in them
2047 0 0 0     0 if (($mood!~/\s/)&&(defined $self->{mood_map})) {
2048 0         0 my $lc_mood=lc($mood);
2049 0 0       0 if (exists $self->{mood_map}->{$lc_mood}) {
2050 0         0 return $self->Setprop_current_mood_id($event,$self->{mood_map}->{$lc_mood})
2051             }
2052             }
2053 0         0 return $self->Setprop_current_mood($event,$mood);
2054             }
2055              
2056              
2057              
2058             =pod
2059              
2060             =item $lj->UseJournal($event,$journal)
2061              
2062             The journal entry will be posted into the shared journal given
2063             as an argument rather than the default journal for the user.
2064              
2065             Returns C<1> on success, C<0> otherwise.
2066              
2067             Example code:
2068              
2069             $lj->UseJournal(\%Event,"some_community")
2070             || die "$0: Failed to - $LJ::Simple::error\n";
2071              
2072             =cut
2073             sub UseJournal($$$) {
2074 0     0 1 0 my $self=shift;
2075 0         0 my ($event,$journal) = @_;
2076 0         0 $LJ::Simple::error="";
2077 0 0       0 if (ref($event) ne "HASH") {
2078 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2079 0         0 return 0;
2080             }
2081 0 0       0 if (!defined $journal) {
2082 0         0 $LJ::Simple::error="CODE: Given undefined value for journal";
2083 0         0 return 0;
2084             }
2085 0 0 0     0 if ((defined $self->{access})&&(!exists $self->{access}->{$journal})) {
2086 0         0 $LJ::Simple::error="user unable to post to journal \"$journal\"";
2087 0         0 return 0;
2088             }
2089 0         0 $event->{usejournal}=$journal;
2090 0         0 return 1;
2091             }
2092              
2093              
2094             =pod
2095              
2096             =item $lj->SetSubject($event,$subject)
2097              
2098             Sets the subject for the journal entry. The subject has the following
2099             limitations:
2100              
2101             o Limited to a length of 255 characters
2102             o No newlines are allowed
2103              
2104             Returns C<1> on success, C<0> otherwise.
2105              
2106             Example code:
2107              
2108             $lj->SetSubject(\%Event,"Some subject")
2109             || die "$0: Failed to set subject - $LJ::Simple::error\n";
2110              
2111             =cut
2112             sub SetSubject($$$) {
2113 0     0 1 0 my $self=shift;
2114 0         0 my ($event,$subject) = @_;
2115 0         0 $LJ::Simple::error="";
2116 0 0       0 if (ref($event) ne "HASH") {
2117 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2118 0         0 return 0;
2119             }
2120 0 0       0 (defined $subject) || ($subject="");
2121 0 0       0 if (length($subject)>255) {
2122 0         0 my $len=length($subject);
2123 0         0 $LJ::Simple::error="Subject length limited to 255 characters [given $len]";
2124 0         0 return 0;
2125             }
2126 0 0       0 if ($subject=~/[\r\n]/) {
2127 0         0 $LJ::Simple::error="New lines not allowed in subject";
2128 0         0 return 0;
2129             }
2130 0         0 $event->{subject}=$subject;
2131 0         0 return 1;
2132             }
2133              
2134              
2135             =pod
2136              
2137             =item $lj->SetEntry($event,@entry)
2138              
2139             Sets the entry for the journal; takes a list of strings. It should be noted
2140             that this list will be Ced together with a newline between each
2141             list entry.
2142              
2143             If the list is null or C then any existing entry is removed.
2144              
2145             Returns C<1> on success, C<0> otherwise.
2146              
2147             Example code:
2148              
2149             # Single line entry
2150             $lj->SetEntry(\%Event,"Just a simple entry")
2151             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2152            
2153             # Three lines of text
2154             my @stuff=(
2155             "Line 1",
2156             "Line 2",
2157             "Line 3",
2158             );
2159             $lj->SetEntry(\%Event,@stuff)
2160             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2161              
2162             # Clear the entry
2163             $lj->SetEntry(\%Event,undef)
2164             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2165             $lj->SetEntry(\%Event)
2166             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2167              
2168             =cut
2169             sub SetEntry($$@) {
2170 0     0 1 0 my $self=shift;
2171 0         0 my ($event,@entry) = @_;
2172 0         0 $LJ::Simple::error="";
2173 0 0       0 if (ref($event) ne "HASH") {
2174 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2175 0         0 return 0;
2176             }
2177 0 0 0     0 if ((!defined $entry[0]) || ($#entry == -1)) {
2178 0         0 $event->{event}=undef;
2179             } else {
2180 0         0 $event->{event}=join("\n",@entry);
2181             }
2182 0         0 return 1;
2183             }
2184              
2185              
2186             =pod
2187              
2188             =item $lj->AddToEntry($event,@entry)
2189              
2190             Adds a string to the existing journal entry being worked on. The new data
2191             will be appended to the existing entry with a newline separating them.
2192             It should be noted that as with C<$lj-ESetEntry()> the list given to
2193             this routine will be Ced together with a newline between each
2194             list entry.
2195              
2196             If C<$lj-ESetEntry()> has not been called then C<$lj-EAddToEntry()> acts
2197             in the same way as C<$lj-ESetEntry()>.
2198              
2199             If C<$lj-ESetEntry()> has already been called then calling C<$lj-EAddToEntry()>
2200             with a null list or a list which starts with C is a NOP.
2201              
2202             Returns C<1> on success, C<0> otherwise.
2203              
2204             Example code:
2205              
2206             # Single line entry
2207             $lj->AddToEntry(\%Event,"Some more text")
2208             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2209            
2210             # Three lines of text
2211             my @stuff=(
2212             "Line 5",
2213             "Line 6",
2214             "Line 7",
2215             );
2216             $lj->AddToEntry(\%Event,@stuff)
2217             || die "$0: Failed to set entry - $LJ::Simple::error\n";
2218              
2219             =cut
2220             sub AddToEntry($$@) {
2221 0     0 1 0 my $self=shift;
2222 0         0 my ($event,@entry) = @_;
2223 0         0 $LJ::Simple::error="";
2224 0 0       0 if (ref($event) ne "HASH") {
2225 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2226 0         0 return 0;
2227             }
2228 0 0       0 if (!defined $event->{event}) {
2229 0 0 0     0 if ((!defined $entry[0]) || ($#entry == -1)) {
2230 0         0 $event->{event}=undef;
2231             } else {
2232 0         0 $event->{event}=join("\n",@entry);
2233             }
2234             } else {
2235 0 0 0     0 if ((!defined $entry[0]) || ($#entry == -1)) {
2236 0         0 return 1;
2237             }
2238 0         0 $event->{event}=join("\n",$event->{event},@entry);
2239             }
2240 0         0 return 1;
2241             }
2242              
2243              
2244             =pod
2245              
2246             =back
2247              
2248             =head2 Setting of journal entry security levels
2249              
2250             =over 4
2251              
2252             =item $lj->SetProtect($event,$type,@args)
2253              
2254             A wrapper function which calls the underlying C routines
2255             for the caller. This takes two or more arguments; the first argument is
2256             the hash reference of the current event. The second argument is the
2257             type of security we are setting. Subsequent arguments are related to
2258             the security type. Available types and their arguments are:
2259              
2260             +---------+------------------+------------------------------------+
2261             | Type | Additional args | Security |
2262             +---------+------------------+------------------------------------+
2263             | public | None | Public - the default |
2264             | friends | None | Friends only |
2265             | groups | A list of groups | Restricted to groups of friends |
2266             | private | None | Private - only the user can access |
2267             +---------+------------------+------------------------------------+
2268              
2269             On success this routine returns C<1>; otherwise it returns C<0> and
2270             sets C<$LJ::Simple::error> to the reason why.
2271              
2272             Example code:
2273              
2274             ## Make entry public (the default)
2275             $lj->SetProtect(\%Event,"public")
2276             || die "$0: Failed to make entry public - $LJ::Simple::error\n";
2277            
2278             ## Make entry friends only
2279             $lj->SetProtect(\%Event,"friends")
2280             || die "$0: Failed to make entry friends only - $LJ::Simple::error\n";
2281            
2282             ## Make entry only readable by friends in the groups "close" and "others"
2283             $lj->SetProtect(\%Event,"groups","close","others")
2284             || die "$0: Failed to make entry public - $LJ::Simple::error\n";
2285            
2286             ## Make entry private so only the journal owner can view it
2287             $lj->SetProtect(\%Event,"private")
2288             || die "$0: Failed to make entry private - $LJ::Simple::error\n";
2289              
2290             =cut
2291             sub SetProtect($$$@) {
2292 0     0 1 0 my $self=shift;
2293 0         0 my ($event,$type,@args)=@_;
2294 0         0 $LJ::Simple::error="";
2295 0 0       0 if (ref($event) ne "HASH") {
2296 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2297 0         0 return 0;
2298             }
2299 0 0       0 if (!defined $type) {
2300 0         0 $LJ::Simple::error="CODE: given undefined value for type";
2301 0         0 return 0;
2302             }
2303 0 0       0 if ($type eq "public") {
    0          
    0          
    0          
2304 0         0 return $self->SetProtectPublic($event);
2305             } elsif ($type eq "friends") {
2306 0         0 return $self->SetProtectFriends($event);
2307             } elsif ($type eq "groups") {
2308 0         0 return $self->SetProtectGroups($event,@args);
2309             } elsif ($type eq "private") {
2310 0         0 return $self->SetProtectPrivate($event);
2311             } else {
2312 0         0 $LJ::Simple::error="CODE: type \"$type\" not recognised by SetProtect()";
2313 0         0 return 0;
2314             }
2315             };
2316              
2317             =pod
2318              
2319             =item $lj->SetProtectPublic($event)
2320              
2321             Sets the current post so that anyone can read the journal entry. Note that this
2322             is the default for a new post created by C - this method is most
2323             useful when working with an existing post. Returns C<1> on success, C<0>
2324             otherwise.
2325              
2326             Example code:
2327              
2328             $lj->SetProtectPublic(\%Event)
2329             || die "$0: Failed to make entry public - $LJ::Simple::error\n";
2330              
2331             =cut
2332             sub SetProtectPublic($$) {
2333 0     0 1 0 my $self=shift;
2334 0         0 my ($event)=@_;
2335 0         0 $LJ::Simple::error="";
2336 0 0       0 if (ref($event) ne "HASH") {
2337 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2338 0         0 return 0;
2339             }
2340 0         0 $event->{security}="public";
2341 0 0       0 (exists $event->{allowmask}) && delete $event->{allowmask};
2342 0         0 return 1;
2343             }
2344              
2345              
2346             =pod
2347              
2348              
2349             =pod
2350              
2351             =item $lj->SetProtectFriends($event)
2352              
2353             Sets the current post so that only friends can read the journal entry. Returns
2354             C<1> on success, C<0> otherwise.
2355              
2356             Example code:
2357              
2358             $lj->SetProtectFriends(\%Event)
2359             || die "$0: Failed to protect via friends - $LJ::Simple::error\n";
2360              
2361             =cut
2362             sub SetProtectFriends($$) {
2363 0     0 1 0 my $self=shift;
2364 0         0 my ($event)=@_;
2365 0         0 $LJ::Simple::error="";
2366 0 0       0 if (ref($event) ne "HASH") {
2367 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2368 0         0 return 0;
2369             }
2370 0         0 $event->{security}="usemask";
2371 0         0 $event->{allowmask}=1;
2372 0         0 return 1;
2373             }
2374              
2375              
2376             =pod
2377              
2378             =item $lj->SetProtectGroups($event,$group1, $group2, ... $groupN)
2379              
2380             Takes a list of group names and sets the current entry so that only those
2381             groups can read the journal entry. Returns
2382             C<1> on success, C<0> otherwise.
2383              
2384             Example code:
2385              
2386             $lj->SetProtectGroups(\%Event,"foo","bar")
2387             || die "$0: Failed to protect via group - $LJ::Simple::error\n";
2388              
2389             =cut
2390             sub SetProtectGroups($$@) {
2391 1     1 1 64 my $self=shift;
2392 1         3 my ($event,@grps) = @_;
2393 1         3 $LJ::Simple::error="";
2394 1 50       12 if (ref($event) ne "HASH") {
2395 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2396 0         0 return 0;
2397             }
2398 1 50       4 if (!defined $self->{groups}) {
2399 1         9 $LJ::Simple::error="Groups not requested at login";
2400 1         4 return 0;
2401             }
2402 0 0       0 if ($#grps==-1) {
2403 0         0 $LJ::Simple::error="No group names given";
2404 0         0 return 0;
2405             }
2406 0         0 $event->{security}="usemask";
2407 0         0 my $g;
2408 0         0 my $mask=0;
2409 0         0 foreach $g (@grps) {
2410 0 0       0 if (!defined $g) {
2411 0         0 $LJ::Simple::error="Group list contains undefined value";
2412 0         0 return 0;
2413             }
2414 0 0       0 if (!exists $self->{groups}->{name}->{$g}) {
2415 0         0 $LJ::Simple::error="Group \"$g\" does not exist";
2416 0         0 return 0;
2417             }
2418 0         0 $mask=$mask | (1 << $self->{groups}->{name}->{$g}->{id});
2419             }
2420 0         0 $event->{allowmask}=$mask;
2421 0         0 return 1;
2422             }
2423              
2424             =pod
2425              
2426             =item $lj->SetProtectPrivate($event)
2427              
2428             Sets the current post so that the owner of the journal only can read the
2429             journal entry. Returns C<1> on success, C<0> otherwise.
2430              
2431             Example code:
2432              
2433             $lj->SetProtectPrivate(\%Event)
2434             || die "$0: Failed to protect via private - $LJ::Simple::error\n";
2435              
2436             =cut
2437             sub SetProtectPrivate($$) {
2438 0     0 1 0 my $self=shift;
2439 0         0 my ($event) = @_;
2440 0         0 $LJ::Simple::error="";
2441 0 0       0 if (ref($event) ne "HASH") {
2442 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2443 0         0 return 0;
2444             }
2445 0         0 $event->{security}="private";
2446 0 0       0 (exists $event->{allowmask}) &&
2447             delete $event->{allowmask};
2448 0         0 return 1;
2449             }
2450              
2451              
2452             ##
2453             ## Helper function used to set meta data
2454             ##
2455             sub Setprop_general($$$$$$) {
2456 0     0 0 0 my ($self,$event,$prop,$caller,$type,$data)=@_;
2457 0         0 $LJ::Simple::error="";
2458 0 0       0 if (ref($event) ne "HASH") {
2459 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2460 0         0 return 0;
2461             }
2462 0 0       0 if (!defined $prop) {
2463 0         0 $LJ::Simple::error="CODE: given undefined value for property";
2464 0         0 return 0;
2465             }
2466 0 0       0 if (!defined $caller) {
2467 0         0 $LJ::Simple::error="CODE: given undefined value for caller setting $prop";
2468 0         0 return 0;
2469             }
2470 0 0       0 if (!defined $type) {
2471 0         0 $LJ::Simple::error="CODE: given undefined value for type by $caller setting $prop";
2472 0         0 return 0;
2473             }
2474 0 0       0 if (!defined $data) {
2475 0         0 $LJ::Simple::error="CODE: given undefined value for data by $caller setting $prop";
2476 0         0 return 0;
2477             }
2478 0         0 my $nd=undef;
2479 0 0       0 if ($type eq "bool") {
    0          
    0          
2480 0 0 0     0 if (($data == 1)||($data == 0)) {
2481 0         0 $nd=$data;
2482             } else {
2483 0         0 $LJ::Simple::error="INTERNAL: Invalid value [$data] for type bool [from $caller]";
2484 0         0 return 0;
2485             }
2486             } elsif ($type eq "char") {
2487 0         0 $nd=$data;
2488             } elsif ($type eq "num") {
2489 0 0       0 if ($data!~/^[0-9]+$/o) {
2490 0         0 $LJ::Simple::error="INTERNAL: Invalid value [$data] for type num [from $caller]";
2491 0         0 return 0;
2492             }
2493 0         0 $nd=$data;
2494             } else {
2495 0         0 $LJ::Simple::error="INTERNAL: Unknown type \"$type\" [from $caller]";
2496 0         0 return 0;
2497             }
2498 0 0       0 if (!defined $nd) {
2499 0         0 $LJ::Simple::error="INTERNAL: Setprop_general did not set \$nd [from $caller]";
2500 0         0 return 0;
2501             }
2502 0         0 $event->{"prop_$prop"}=$nd;
2503 0         0 return 1;
2504             }
2505              
2506             =pod
2507              
2508             =back
2509              
2510             =head2 Setting journal entry properties
2511              
2512             =over 4
2513              
2514             =item $lj->Setprop_taglist($event,@tags)
2515              
2516             Set the tags for the entry; C<@tags> is a list of the tags to give the
2517             entry.
2518              
2519             Example code:
2520              
2521             $lj->Setprop_taglist(\%Event,qw( gabe pets whatever )) ||
2522             die "$0: Failed to set back date property - $LJ::Simple::error\n";
2523              
2524             =cut
2525             sub Setprop_taglist($$@) {
2526 0     0 1 0 my ($self,$event,@tags)=@_;
2527 0         0 $LJ::Simple::error="";
2528 0         0 return $self->Setprop_general($event,"taglist","Setprop_taglist","char",join(", ",@tags));
2529             }
2530              
2531             =pod
2532              
2533             =item $lj->Setprop_backdate($event,$onoff)
2534              
2535             Used to indicate if the journal entry being written should be back dated or not. Back dated
2536             entries do not appear on the friends view of your journal entries. The C<$onoff>
2537             value takes either C<1> for switching the property on or C<0> for switching the
2538             property off. Returns C<1> on success, C<0> on failure.
2539              
2540             You will need to set this value if the journal entry you are sending has a
2541             date earlier than other entries in your journal.
2542              
2543             Example code:
2544              
2545             $lj->Setprop_backdate(\%Event,1) ||
2546             die "$0: Failed to set back date property - $LJ::Simple::error\n";
2547              
2548             =cut
2549             sub Setprop_backdate($$$) {
2550 0     0 1 0 my ($self,$event,$onoff)=@_;
2551 0         0 $LJ::Simple::error="";
2552 0         0 return $self->Setprop_general($event,"opt_backdated","Setprop_backdate","bool",$onoff);
2553             }
2554              
2555              
2556             =pod
2557              
2558             =item $lj->Setprop_current_mood($event,$mood)
2559              
2560             Used to set the current mood for the journal being written. This takes a string which
2561             describes the mood.
2562              
2563             It is better to use C<$lj-ESetMood()> as that will automatically use a
2564             mood known to the LiveJournal server if it can.
2565              
2566             Returns C<1> on success, C<0> on failure.
2567              
2568             Example code:
2569              
2570             $lj->Setprop_current_mood(\%Event,"Happy, but tired") ||
2571             die "$0: Failed to set current_mood property - $LJ::Simple::error\n";
2572              
2573             =cut
2574             sub Setprop_current_mood($$$) {
2575 0     0 1 0 my ($self,$event,$mood)=@_;
2576 0         0 $LJ::Simple::error="";
2577 0 0       0 if ($mood=~/[\r\n]/) {
2578 0         0 $LJ::Simple::error="Mood may not contain a new line";
2579 0         0 return 0;
2580             }
2581 0         0 return $self->Setprop_general($event,"current_mood","Setprop_current_mood","char",$mood);
2582             }
2583              
2584             =pod
2585              
2586             =item $lj->Setprop_current_mood_id($event,$id)
2587              
2588             Used to set the current mood_id for the journal being written. This takes a number which
2589             refers to a mood_id the LiveJournal server knows about.
2590              
2591             Note that if the LiveJournal
2592             object was created with either C set to C<0> or
2593             with C set to C<1> then this function will not attempt to validate
2594             the C given to it.
2595              
2596             It is better to use C<$lj-ESetMood()> as that will automatically use a
2597             mood known to the LiveJournal server if it can.
2598              
2599             Returns C<1> on success, C<0> on failure.
2600              
2601             Example code:
2602              
2603             $lj->Setprop_current_mood_id(\%Event,15) ||
2604             die "$0: Failed to set current_mood_id property - $LJ::Simple::error\n";
2605              
2606             =cut
2607             sub Setprop_current_mood_id($$$) {
2608 0     0 1 0 my ($self,$event,$data)=@_;
2609 0         0 $LJ::Simple::error="";
2610 0 0       0 if (defined $self->{moods}) {
2611 0 0       0 if (!exists $self->{moods}->{$data}) {
2612 0         0 $LJ::Simple::error="The mood_id $data is not known by the LiveJournal server";
2613 0         0 return 0;
2614             }
2615             }
2616 0         0 return $self->Setprop_general($event,"current_moodid","Setprop_current_mood_id","num",$data);
2617             }
2618              
2619              
2620             =pod
2621              
2622             =item $lj->Setprop_current_music($event,$music)
2623              
2624             Used to set the current music for the journal entry being written. This takes
2625             a string.
2626              
2627             Returns C<1> on success, C<0> on failure.
2628              
2629             Example code:
2630              
2631             $lj->Setprop_current_music(\%Event,"Collected euphoric dance") ||
2632             die "$0: Failed to set current_music property - $LJ::Simple::error\n";
2633              
2634             =cut
2635             sub Setprop_current_music($$$) {
2636 0     0 1 0 my ($self,$event,$data)=@_;
2637 0         0 $LJ::Simple::error="";
2638 0         0 return $self->Setprop_general($event,"current_music","Setprop_current_music","char",$data);
2639             }
2640              
2641             =pod
2642              
2643             =item $lj->Setprop_preformatted($event,$onoff)
2644              
2645             Used to set if the text for the journal entry being written is preformatted in HTML
2646             or not. This takes a boolean value of C<1> for true and C<0> for false.
2647              
2648             Returns C<1> on success, C<0> on failure.
2649              
2650             Example code:
2651              
2652             $lj->Setprop_preformatted(\%Event,1) ||
2653             die "$0: Failed to set property - $LJ::Simple::error\n";
2654              
2655             =cut
2656             sub Setprop_preformatted($$$) {
2657 0     0 1 0 my ($self,$event,$data)=@_;
2658 0         0 $LJ::Simple::error="";
2659 0         0 return $self->Setprop_general($event,"opt_preformatted","Setprop_preformatted","bool",$data);
2660             }
2661              
2662              
2663             =pod
2664              
2665             =item $lj->Setprop_nocomments($event,$onoff)
2666              
2667             Used to set if the journal entry being written can be commented on or not. This takes
2668             a boolean value of C<1> for true and C<0> for false. Thus if you use a value
2669             of C<1> (true) then comments will not be allowed.
2670              
2671             Returns C<1> on success, C<0> on failure.
2672              
2673             Example code:
2674              
2675             $lj->Setprop_nocomments(\%Event,1) ||
2676             die "$0: Failed to set property - $LJ::Simple::error\n";
2677              
2678             =cut
2679             sub Setprop_nocomments($$$) {
2680 0     0 1 0 my ($self,$event,$data)=@_;
2681 0         0 $LJ::Simple::error="";
2682 0         0 return $self->Setprop_general($event,"opt_nocomments","Setprop_nocomments","bool",$data);
2683             }
2684              
2685              
2686             =pod
2687              
2688             =item $lj->Setprop_picture_keyword($event,$keyword)
2689              
2690             Used to set the picture keyword for the journal entry being written. This takes
2691             a string. We check to make sure that the picture keyword exists.
2692              
2693             Note that if the LiveJournal
2694             object was created with either C set to C<0> or
2695             with C set to C<1> then this function will B validate
2696             the picture keyword before setting it.
2697              
2698             Returns C<1> on success, C<0> on failure.
2699              
2700             Example code:
2701              
2702             $lj->Setprop_picture_keyword(\%Event,"Some photo") ||
2703             die "$0: Failed to set property - $LJ::Simple::error\n";
2704              
2705             =cut
2706             sub Setprop_picture_keyword($$$) {
2707 0     0 1 0 my ($self,$event,$data)=@_;
2708 0         0 $LJ::Simple::error="";
2709 0 0       0 if (defined $self->{pictures}) {
2710 0         0 my $match=0;
2711 0         0 foreach (values %{$self->{pictures}}) {
  0         0  
2712 0 0       0 if ($_->{name} eq $data) {
2713 0         0 $match=1;
2714 0         0 last;
2715             }
2716             }
2717 0 0       0 if (!$match) {
2718 0         0 $LJ::Simple::error="Picture keyword not associated with journal";
2719 0         0 return 0;
2720             }
2721             }
2722 0         0 return $self->Setprop_general($event,"picture_keyword","Setprop_picture_keyword","char",$data);
2723             }
2724              
2725              
2726             =pod
2727              
2728             =item $lj->Setprop_noemail($event,$onoff)
2729              
2730             Used to say that comments on the journal entry being written should not be emailed.
2731             This takes boolean value of C<1> for true and C<0> for false.
2732              
2733             Returns C<1> on success, C<0> on failure.
2734              
2735             Example code:
2736              
2737             $lj->Setprop_noemail(\%Event,1) ||
2738             die "$0: Failed to set property - $LJ::Simple::error\n";
2739              
2740             =cut
2741             sub Setprop_noemail($$$) {
2742 0     0 1 0 my ($self,$event,$data)=@_;
2743 0         0 $LJ::Simple::error="";
2744 0         0 return $self->Setprop_general($event,"opt_noemail","Setprop_noemail","bool",$data);
2745             }
2746              
2747              
2748             =pod
2749              
2750             =item $lj->Setprop_unknown8bit($event,$onoff)
2751              
2752             Used say that there is 8-bit data which is not in UTF-8 in the journal entry
2753             being written. This takes a boolean value of C<1> for true and C<0> for false.
2754              
2755             Returns C<1> on success, C<0> on failure.
2756              
2757             Example code:
2758              
2759             $lj->Setprop_unknown8bit(\%Event,1) ||
2760             die "$0: Failed to set property - $LJ::Simple::error\n";
2761              
2762             =cut
2763             sub Setprop_unknown8bit($$$) {
2764 0     0 1 0 my ($self,$event,$data)=@_;
2765 0         0 $LJ::Simple::error="";
2766 0         0 return $self->Setprop_general($event,"unknown8bit","Setprop_unknown8bit","bool",$data);
2767             }
2768              
2769              
2770             =pod
2771              
2772             =back
2773              
2774             =head2 Posting, editing and deleting journal entries
2775              
2776             =over 4
2777              
2778             =item $lj->PostEntry($event)
2779              
2780             Submit a journal entry into the LiveJournal system. This requires you to have
2781             set up the journal entry with C<$lj-ENewEntry()> and to have at least called
2782             C<$lj-ESetEntry()>.
2783              
2784             On success a list containing the following is returned:
2785              
2786             o The item_id as returned by the LiveJournal server
2787             o The anum as returned by the LiveJournal server
2788             o The item_id of the posted entry as used in HTML - that is the
2789             value of C<($item_id * 256) + $anum)>
2790              
2791             On failure C is returned.
2792              
2793             # Build the new entry
2794             my %Event;
2795             $lj->NewEntry(\%Event) ||
2796             die "$0: Failed to create new journal entry - $LJ::Simple::error\n";
2797              
2798             # Set the journal entry
2799             $lj->SetEntry(\%Event,"foo") ||
2800             die "$0: Failed set journal entry - $LJ::Simple::error\n";
2801              
2802             # And post it
2803             my ($item_id,$anum,$html_id)=$lj->PostEntry(\%Event);
2804             defined $item_id ||
2805             die "$0: Failed to submit new journal entry - $LJ::Simple::error\n";
2806              
2807             =cut
2808             ##
2809             ## PostEntry - actually submit a journal entry.
2810             ##
2811             sub PostEntry($$) {
2812 0     0 1 0 my $self=shift;
2813 0         0 my ($event)=@_;
2814 0         0 $LJ::Simple::error="";
2815 0 0       0 if (ref($event) ne "HASH") {
2816 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2817 0         0 return undef;
2818             }
2819 0 0       0 if (!exists $event->{"__new_entry"}) {
2820 0         0 $LJ::Simple::error="CODE: NewEntry not called";
2821 0         0 return undef;
2822             }
2823              
2824             ## Blat any key in $event which starts with a double underscore
2825 0 0       0 map {/^__/ && delete $event->{$_}} (keys %{$event});
  0         0  
  0         0  
2826              
2827 0 0       0 if (!defined $event->{event}) {
2828 0         0 $LJ::Simple::error="CODE: No journal entry set - call SetEntry() or AddToEntry() first";
2829 0         0 return undef;
2830             }
2831              
2832             ## Blat any entry in $self->{event} with an undef value
2833 0 0       0 map {defined $event->{$_} || delete $event->{$_}} (keys %{$event});
  0         0  
  0         0  
2834              
2835             ## Finally send the actual request
2836 0         0 my %Resp=();
2837 0 0       0 $self->SendRequest("postevent",$event,\%Resp) || return undef;
2838              
2839 0 0       0 if (!exists $Resp{itemid}) {
2840 0         0 $LJ::Simple::error="LJ server did not return itemid";
2841 0         0 return undef;
2842             }
2843 0 0       0 if (!exists $Resp{anum}) {
2844 0         0 $LJ::Simple::error="LJ server did not return anum";
2845 0         0 return undef;
2846             }
2847              
2848 0         0 return ($Resp{itemid},$Resp{anum},($Resp{itemid} * 256) + $Resp{anum});
2849             }
2850              
2851             =pod
2852              
2853             =item $lj->EditEntry($event)
2854              
2855             Edit an entry from the LiveJournal system which has the givem C.
2856             The entry should have been fetched from LiveJournal using the
2857             C<$lj-EGetEntries()> function and then adjusted using the various
2858             C<$lj-ESet...()> functions.
2859              
2860             It should be noted that this function can be used to delete a journal entry
2861             by setting the entry to a blank string, I by using
2862             C<$lj-ESetEntry(\%Event,undef)>
2863              
2864             Returns C<1> on success, C<0> on failure.
2865              
2866             Example:
2867              
2868             # Fetch the most recent event
2869             my %Events = ();
2870             (defined $lj->GetEntries(\%Events,undef,"one",-1)) ||
2871             die "$0: Failed to get entries - $LJ::Simple::error\n";
2872            
2873             # Mark it as private
2874             foreach (values %Entries) {
2875             $lj->SetProtectPrivate($_);
2876             $lj->EditEntry($_) ||
2877             die "$0: Failed to edit entry - $LJ::Simple::error\n";
2878             }
2879            
2880             # Alternatively we could just delete it...
2881             my $event=(values %Entries)[0];
2882             $lj->SetEntry($event,undef);
2883             $lj->EditEntry($event) ||
2884             die "$0: Failed to edit entry - $LJ::Simple::error\n";
2885              
2886             =cut
2887             sub EditEntry($$) {
2888 0     0 1 0 my $self=shift;
2889 0         0 my ($event)=@_;
2890 0         0 $LJ::Simple::error="";
2891 0 0       0 if (ref($event) ne "HASH") {
2892 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
2893 0         0 return 0;
2894             }
2895 0 0       0 if (!exists $event->{"__itemid"}) {
2896 0         0 $LJ::Simple::error="CODE: Not an existing entry; use GetEntry()";
2897 0         0 return 0;
2898             }
2899 0         0 $event->{itemid}=$event->{"__itemid"};
2900              
2901             ## Blat any key in $event which starts with a double underscore
2902 0 0       0 map {/^__/ && delete $event->{$_}} (keys %{$event});
  0         0  
  0         0  
2903              
2904 0 0       0 if (!defined $event->{event}) {
2905 0         0 $LJ::Simple::error="CODE: No journal entry set";
2906 0         0 return 0;
2907             }
2908              
2909             ## Blat any entry in $event with an undef value
2910 0 0       0 map {defined $event->{$_} || delete $event->{$_}} (keys %{$event});
  0         0  
  0         0  
2911              
2912             ## Make the request
2913 0         0 return $self->SendRequest("editevent",$event,undef);
2914             }
2915              
2916             =pod
2917              
2918             =item $lj->DeleteEntry($item_id)
2919              
2920             Delete an entry from the LiveJournal system which has the given C.
2921             On success C<1> is returned; on failure C<0> is returned.
2922              
2923             Example:
2924              
2925             $lj->DeleteEntry($some_item_id) ||
2926             die "$0: Failed to delete journal entry - $LJ::Simple::error\n";
2927              
2928             =cut
2929             sub DeleteEntry($$) {
2930 0     0 1 0 my $self=shift;
2931 0         0 my ($item_id) = @_;
2932 0         0 $LJ::Simple::error="";
2933 0 0       0 if (!defined $item_id) {
2934 0         0 $LJ::Simple::error="CODE: DeleteEntry() given undefined item_id";
2935 0         0 return 0;
2936             }
2937 0 0       0 if ($item_id!~/^[0-9]+$/) {
2938 0         0 $LJ::Simple::error="CODE: DeleteEntry() given invalid item_id";
2939 0         0 return 0;
2940             }
2941 0         0 my %Event=(
2942             itemid => $item_id,
2943             event => "",
2944             );
2945 0         0 return $self->SendRequest("editevent",\%Event,undef);
2946             }
2947              
2948             =pod
2949              
2950             =back
2951              
2952             =head2 Retriving journal entries
2953              
2954             =over 4
2955              
2956             =item $lj->SyncItems($timestamp)
2957              
2958             This routine returns a list of all of the items (journal entries, to-do items,
2959             comments) which have been created or updated on LiveJournal. There is an optional
2960             timestamp value for specifying the time you last synchronised with the server.
2961             This timestamp value can either be a Unix-style C value or a previously
2962             returned timestamp from this routine. If not used specify the undefined value
2963             C.
2964              
2965             When specifying the time you must take into account the fact that the modification
2966             or creation times of the entries in the LiveJournal database are stored as the
2967             time local to the computer running the database rather than GMT. Due to this
2968             it is safest to use the time from the latest item downloaded from the LiveJournal
2969             from a previous C call.
2970              
2971             On success this routine will return a list which contains first the number of
2972             valid items in the list and then a list of hashes which contain the details
2973             of the items found. This routine can return an empty list which signifies that
2974             no new items could be found. On failure C is returned.
2975              
2976             The format of the returned list is as follows. The list of hashes is ordered
2977             by the timestamps of the entries, oldest to newest.
2978              
2979             @list = (
2980             number of items returned,
2981             {
2982             item_id => Item_id of the entry changed
2983             type => Type of entry
2984             action => What happened to the entry
2985             time_t => Time of change in Unix time (see note below)
2986             timestamp => Timestamp from server
2987             },
2988             );
2989              
2990             The C of entry can be one of the following letters:
2991              
2992             L: Journal entries
2993             C: Comments
2994             T: To-do items
2995              
2996             It should be noted that currently the LiveJournal system will only ever
2997             return C types due to the C and C types not having been implemented
2998             in the LiveJournal code yet.
2999              
3000             The C of the entry can be either C for a new entry,
3001             C for an entry which has been modified or C for a deleted entry.
3002              
3003             The C value is probably going to be wrong; as far as the author of
3004             this code can tell, you can not get the timezone of the server which is
3005             serving out the request. This means that converting the timestamps
3006             returned by the server from their format of C into
3007             a Unix C value is inaccurate at best since C is defined
3008             as the number of seconds since 00:00 1st January 1970 B. Functions
3009             like C which can be used to create C values have to
3010             assume that the data they are being given is valid for the timezone the
3011             machine it is running on is actually in. Given the nature of the net
3012             this is rarely the case. I I wish that the LJ developers had stored
3013             timestamps in pure C in the database... and if they have done they
3014             should provide a way for developers to get access to this as its B
3015             more useful IMHO.
3016              
3017             Given the above you're probably wondering why I included the C
3018             value. Well, whilst the value isn't much use when it really comes down
3019             to it, it B useful when it comes to sorting the list of entries as
3020             all of the entries from the same server will be inaccurate to the same
3021             amount.
3022              
3023             The C from server takes the format of C
3024              
3025             It should be noted that this routine can take a long time to return
3026             if there are large numbers of entries to be returned. This is especially
3027             true if you give C as the timestamp.
3028              
3029             Example code:
3030              
3031             # All entries in the last day or so; this is fudged due to timezone
3032             # differences (WTF didn't they store stuff in GMT ?)
3033             my ($num_of_items,@lst)=$lj->SyncItems(time() - (86400 * 2));
3034            
3035             (defined $num_of_items) ||
3036             die "$0: Failed to sync - $LJ::Simple::error\n";
3037              
3038             my $hr=undef;
3039             print "Number of items: $num_of_items\n";
3040             print "Item_id\tType\tAction\tTime_t\t\tTimestamp\n";
3041             foreach $hr (@lst) {
3042             print "$hr->{item_id}\t" .
3043             "$hr->{type}\t" .
3044             "$hr->{action}\t" .
3045             "$hr->{time_t}\t" .
3046             "$hr->{timestamp}\n";
3047             }
3048              
3049             There is also an example of how to work with all of the entries of a LiveJournal
3050             shown in the C script which accompanies the C
3051             distribution. This example script looks at a LiveJournal and makes sure that every
3052             journal entry is at the very least marked as being friends-only.
3053              
3054             =cut
3055             sub SyncItems($$) {
3056 0     0 1 0 my $self=shift;
3057 0         0 my ($timet)=@_;
3058 0         0 $LJ::Simple::error="";
3059 0 0       0 if (!defined $timet) {
3060 0         0 $LJ::Simple::error="CODE: Invalid timestamp - undefined value not allowed";
3061 0         0 return undef;
3062             }
3063 0 0       0 if ($LJ::Simple::debug) {
3064 0         0 my $ts=undef;
3065 0 0       0 if (defined $timet) {
3066 0         0 $ts="\"$timet\"";
3067             } else {
3068 0         0 $ts="undef";
3069             }
3070 0         0 Debug "SyncItems($ts)";
3071             }
3072 0         0 my %Event=();
3073 0         0 my %Resp=();
3074 0 0       0 if (defined $timet) {
3075 0 0       0 if ($timet=~/^[0-9]+$/) {
3076 0         0 my @tm=localtime($timet);
3077 0 0       0 if ($#tm==-1) {
3078 0         0 $LJ::Simple::error="CODE: Invalid timestamp";
3079 0         0 return undef;
3080             }
3081 0         0 $Event{lastsync}=strftime("%Y-%m-%d %H:%M:%S",@tm);
3082             } else {
3083 0         0 $Event{lastsync}=$timet;
3084             }
3085             }
3086 0 0       0 $self->SendRequest("syncitems",\%Event,\%Resp) || return undef;
3087 0         0 my %Mh=();
3088 0         0 my $sync_count;
3089             my $sync_total;
3090 0         0 my $latest=0;
3091 0         0 my $latest_ts;
3092 0         0 my ($key,$val);
3093 0         0 while(($key,$val)=each %Resp) {
3094 0 0       0 if ($key=~/sync_([0-9]+)_(.*)$/o) {
    0          
    0          
3095 0         0 my ($id,$name)=($1,$2);
3096 0 0       0 (exists $Mh{$id}) || ($Mh{$id}={});
3097 0 0       0 if ($name eq "item") {
    0          
    0          
3098 0         0 my ($type,$item_id)=split(/-/,$val,2);
3099 0         0 $Mh{$id}->{item_id}=$item_id;
3100 0         0 $Mh{$id}->{type}=$type;
3101             } elsif ($name eq "action") {
3102 0         0 $Mh{$id}->{action}=$val;
3103             } elsif ($name eq "time") {
3104 0         0 $Mh{$id}->{timestamp}=$val;
3105 0 0       0 if ($val!~/([0-9]+)-([0-9]+)-([0-9]+)\s([0-9]+):([0-9]+):([0-9]+)/io) {
3106 0         0 $LJ::Simple::error="INTERNAL: failed to parse timestamp \"$val\"";
3107 0         0 return undef;
3108             }
3109 0         0 $Mh{$id}->{time_t}=mktime($6,$5,$4,$3,$2-1,$1-1900,0,0,0);
3110 0 0       0 if (!defined $Mh{$id}->{time_t}) {
3111 0         0 $LJ::Simple::error="INTERNAL: failed to create time_t from \"$val\"";
3112 0         0 return undef;
3113             }
3114 0 0       0 if ($Mh{$id}->{time_t}>$latest) {
3115 0         0 $latest_ts=$val;
3116 0         0 $latest=$Mh{$id}->{time_t};
3117             }
3118             } else {
3119 0         0 $LJ::Simple::error="INTERNAL: Unrecognised sync_[0-9]_* \"$key\"";
3120 0         0 return undef;
3121             }
3122             } elsif ($key eq "sync_total") {
3123 0         0 $sync_total=$val;
3124             } elsif ($key eq "sync_count") {
3125 0         0 $sync_count=$val;
3126             }
3127             }
3128 0         0 Debug "sync_count=$sync_count\n";
3129 0         0 Debug "sync_total=$sync_total\n";
3130 0         0 my @lst=();
3131 0         0 push(@lst,values %Mh);
3132 0 0       0 if ($sync_count != $sync_total) {
3133 0         0 my ($num,@nl)=$self->SyncItems($latest_ts);
3134 0 0       0 (defined $num) || return undef;
3135 0         0 push(@lst,@nl);
3136             }
3137 0         0 @lst=sort { $a->{time_t} <=> $b->{time_t} } @lst;
  0         0  
3138 0         0 map { $_->{kv}=join(":",$_->{item_id},$_->{type},$_->{action},$_->{time_t}) } @lst;
  0         0  
3139 0         0 my %seen=();
3140 0   0     0 @lst=grep((!exists $seen{$_->{kv}}) && ($seen{$_->{kv}}=1),@lst);
3141 0         0 my $tot=$#lst+1;
3142 0         0 return ($tot,@lst);
3143             }
3144              
3145             =pod
3146              
3147             =item $lj->GetEntries($hash_ref,$journal,$type,@opt)
3148              
3149             This routine allows you to pull events from the user's LiveJournal. There are
3150             several different ways this routine can work depending on the value given in
3151             the C<$type> argument.
3152              
3153             This routine will currently only allow you to get a B
3154             thanks to restrictions imposed by LiveJournal servers. If you want to perform work
3155             on I journal entry within a LiveJournal account then you should look at the
3156             C routine documented above.
3157              
3158             The first argument - C<$hash_ref> is a reference to a hash which will be filled
3159             with the details of the journal entries downloaded. The key to this hash is the
3160             C of the journal entries. The value is a hash reference which points to
3161             a hash of the same type created by C and used by C and
3162             C. The most sensible way to access this hash is to use the various
3163             C routines.
3164              
3165             The second argument - C<$journal> - is an optional argument set if the journal
3166             to be accessed is a shared journal. If this is set then the name of shared journal
3167             will be propogated into the entries returned in the hash reference C<$hash_ref> as
3168             if C<$lj->UseJournal($event,$journal)> was called. If not required set this to C.
3169              
3170             The third argument - C<$type> - specifies how the journal entries are to be
3171             pulled down. The contents of the fourth argument - C<@opt> - will depend on the
3172             value in the C<$type> variable. Thus:
3173              
3174             +-------+------------+------------------------------------------+
3175             | $type | @opt | Comments |
3176             +-------+------------+------------------------------------------+
3177             | day | $timestamp | Download a single day. $timestamp is a |
3178             | | | Unix timestamp for the required day |
3179             +-------+------------+------------------------------------------+
3180             | lastn |$num,$before| Download a number of entries. $num has a |
3181             | | | maximum value of 50. If $num is undef |
3182             | | | then the default of 20 is used. $before |
3183             | | | is an optional value which specifies a |
3184             | | | date before which all entries must occur.|
3185             | | | The date is specified as a Unix |
3186             | | | timestamp. If not specified the value |
3187             | | | should be undef. |
3188             +-------+------------+------------------------------------------+
3189             | one | $item_id | The unique ItemID for the entry to be |
3190             | | | downloaded. A value of -1 means to |
3191             | | | download the most recent entry |
3192             +-------+------------+------------------------------------------+
3193             | sync | $date | Get journal entries since the given date.|
3194             | | | The date should be specified as a Unix |
3195             | | | timestamp. |
3196             +-------+------------+------------------------------------------+
3197              
3198             If the operation is successful then C<$hash_ref> is returned. On failure
3199             C is returned and C<$LJ::Simple::error> is updated with the
3200             reason for the error.
3201              
3202             Example code:
3203              
3204             The following code only uses a single C<$type> from the above list; C.
3205             However the hash of hashes returned is the same in every C<$type> used. The
3206             code below shows how to pull down the last journal entry posted and then uses
3207             all of the various C routines to decode the hash returned.
3208              
3209             use POSIX;
3210            
3211             my %Entries=();
3212             (defined $lj->GetEntries(\%Entries,undef,"one",-1)) ||
3213             die "$0: Failed to get entries - $LJ::Simple::error\n";
3214            
3215             my $Entry=undef;
3216             my $Format="%-20s: %s\n";
3217              
3218             foreach $Entry (values %Entries) {
3219            
3220             # Get URL
3221             my $url=$lj->GetURL($Entry);
3222             (defined $url) && print "$url\n";
3223            
3224             # Get ItemId
3225             my ($item_id,$anum,$html_id)=$lj->GetItemId($Entry);
3226             (defined $item_id) && printf($Format,"Item_id",$item_id);
3227            
3228             # Get the subject
3229             my $subj=$lj->GetSubject($Entry);
3230             (defined $subj) && printf($Format,"Subject",$subj);
3231            
3232             # Get the date entry was posted
3233             my $timet=$lj->GetDate($Entry);
3234             if (defined $timet) {
3235             printf($Format,"Date",
3236             strftime("%Y-%m-%d %H:%M:%S",localtime($timet)));
3237             }
3238            
3239             # Is entry protected ?
3240             my $EntProt="";
3241             my ($protect,@prot_opt)=$lj->GetProtect($Entry);
3242             if (defined $protect) {
3243             if ($protect eq "public") {
3244             $EntProt="public";
3245             } elsif ($protect eq "friends") {
3246             $EntProt="friends only";
3247             } elsif ($protect eq "groups") {
3248             $EntProt=join("","only groups - ",join(", ",@prot_opt));
3249             } elsif ($protect eq "private") {
3250             $EntProt="private";
3251             }
3252             printf($Format,"Journal access",$EntProt);
3253             }
3254            
3255             ## Properties
3256             # Backdated ?
3257             my $word="no";
3258             my $prop=$lj->Getprop_backdate($Entry);
3259             if ((defined $prop) && ($prop==1)) { $word="yes" }
3260             printf($Format,"Backdated",$word);
3261            
3262             # Preformatted ?
3263             $word="no";
3264             $prop=$lj->Getprop_preformatted($Entry);
3265             if ((defined $prop) && ($prop==1)) { $word="yes" }
3266             printf($Format,"Preformatted",$word);
3267            
3268             # No comments allowed ?
3269             $word="no";
3270             $prop=$lj->Getprop_nocomments($Entry);
3271             if ((defined $prop) && ($prop==1)) { $word="yes" }
3272             printf($Format,"No comments",$word);
3273            
3274             # Do not email comments ?
3275             $word="no";
3276             $prop=$lj->Getprop_noemail($Entry);
3277             if ((defined $prop) && ($prop==1)) { $word="yes" }
3278             printf($Format,"No emailed comments",$word);
3279            
3280             # Unknown 8-bit ?
3281             $word="no";
3282             $prop=$lj->Getprop_unknown8bit($Entry);
3283             if ((defined $prop) && ($prop==1)) { $word="yes" }
3284             printf($Format,"Any 8 bit, non UTF-8",$word);
3285            
3286             # Current music
3287             $word="[None]";
3288             $prop=$lj->Getprop_current_music($Entry);
3289             if ((defined $prop) && ($prop ne "")) { $word=$prop }
3290             printf($Format,"Current music",$word);
3291            
3292             # Current mood [text]
3293             $word="[None]";
3294             $prop=$lj->Getprop_current_mood($Entry);
3295             if ((defined $prop) && ($prop ne "")) { $word=$prop }
3296             printf($Format,"Current mood",$word);
3297            
3298             # Current mood [id]
3299             $word="[None]";
3300             $prop=$lj->Getprop_current_mood_id($Entry);
3301             if ((defined $prop) && ($prop ne "")) { $word=$prop }
3302             printf($Format,"Current mood_id",$word);
3303            
3304             # Picture keyword
3305             $word="[None]";
3306             $prop=$lj->Getprop_picture_keyword($Entry);
3307             if ((defined $prop) && ($prop ne "")) { $word=$prop }
3308             printf($Format,"Picture keyword",$word);
3309            
3310             # Finally output the actual journal entry
3311             printf($Format,"Journal entry","");
3312             my $text=$lj->GetEntry($Entry);
3313             (defined $text) &&
3314             print " ",join("\n ",split(/\n/,$text)),"\n\n";
3315             }
3316              
3317             =cut
3318             sub GetEntries($$@) {
3319 0     0 1 0 my $self=shift;
3320 0         0 my ($hr,$journal,$type,@opts)=@_;
3321 0         0 $LJ::Simple::error="";
3322 0 0       0 if (ref($hr) ne "HASH") {
3323 0         0 $LJ::Simple::error="CODE: GetEntries() not given a hash reference";
3324 0         0 return undef;
3325             }
3326 0 0       0 if (!defined $type) {
3327 0         0 $LJ::Simple::error="CODE: GetEntries() given undefined value for type";
3328 0         0 return undef;
3329             }
3330 0         0 %{$hr}=();
  0         0  
3331 0         0 my %Event=();
3332 0         0 my %Resp=();
3333 0 0       0 if (defined $journal) {
3334 0         0 $Event{usejournal}=$journal;
3335             }
3336 0         0 my $ctype=lc($type);
3337 0 0       0 if ($ctype eq "day") {
    0          
    0          
    0          
3338 0 0       0 if ($#opts<0) {
3339 0         0 $LJ::Simple::error="CODE: GetEntries($type) requires year,month,day in \@opts";
3340 0         0 return undef;
3341             }
3342 0         0 my ($timestamp)=@opts;
3343 0 0       0 if ($timestamp!~/^[0-9]+$/) {
3344 0         0 $LJ::Simple::error="CODE: GetEntries($type) given invalid timestamp";
3345 0         0 return undef;
3346             }
3347 0         0 my @tm=localtime($timestamp);
3348 0 0       0 if ($#tm==-1) {
3349 0         0 $LJ::Simple::error="CODE: GetEntries($type) given invalid timestamp";
3350 0         0 return undef;
3351             }
3352 0         0 $Event{selecttype}=$ctype;
3353 0         0 $Event{year}=$tm[5]+1900;
3354 0         0 $Event{month}=$tm[4]+1;
3355 0         0 $Event{day}=$tm[3];
3356             } elsif ($ctype eq "lastn") {
3357 0 0       0 if ($#opts<1) {
3358 0         0 $LJ::Simple::error="CODE: GetEntries($type) requires num and beforedate in \@opts";
3359 0         0 return undef;
3360             }
3361 0         0 $Event{selecttype}=$ctype;
3362 0         0 my ($num,$beforedate)=@opts;
3363 0 0       0 if (defined $num) {
3364 0 0       0 if ($num!~/^[0-9]{1,2}$/) {
3365 0         0 $LJ::Simple::error="CODE: GetEntries($type) requires valid number for num";
3366 0         0 return undef;
3367             }
3368 0 0       0 if ($num>50) {
3369 0         0 $LJ::Simple::error="Maximum number of journal entries returned is 50";
3370 0         0 return undef;
3371             }
3372             } else {
3373 0         0 $num=20;
3374             }
3375 0         0 $Event{howmany}=$num;
3376 0 0       0 if (defined $beforedate) {
3377 0 0       0 if ($beforedate!~/^[0-9]+$/) {
3378 0         0 $LJ::Simple::error="Invalid Unix timestamp";
3379 0         0 return undef;
3380             }
3381 0         0 my @tm=localtime($beforedate);
3382 0 0       0 if ($#tm==-1) {
3383 0         0 $LJ::Simple::error="CODE: GetEntries($type) given invalid timestamp";
3384 0         0 return undef;
3385             }
3386 0         0 $Event{beforedate}=strftime("%Y-%m-%d %H:%M:%S",@tm);
3387             }
3388             } elsif ($ctype eq "one") {
3389 0 0       0 if ($#opts<0) {
3390 0         0 $LJ::Simple::error="CODE: GetEntries($type) requires item_id in \@opts";
3391 0         0 return undef;
3392             }
3393 0         0 my ($item_id)=@opts;
3394 0 0       0 if ($item_id!~/^-*[0-9]+$/) {
3395 0         0 $LJ::Simple::error="Invalid item_id";
3396 0         0 return undef;
3397             }
3398 0 0       0 if ($item_id<-1) {
3399 0         0 $LJ::Simple::error="Invalid item_id";
3400 0         0 return undef;
3401             }
3402 0         0 $Event{selecttype}=$ctype;
3403 0         0 $Event{itemid}=$item_id;
3404             } elsif ($ctype eq "sync") {
3405 0 0       0 if ($#opts<0) {
3406 0         0 $LJ::Simple::error="CODE: GetEntries($type) requires timestamp in \@opts";
3407 0         0 return undef;
3408             }
3409 0         0 my ($lastsync)=@opts;
3410 0 0       0 if ($lastsync!~/^[0-9]+$/) {
3411 0         0 $LJ::Simple::error="Invalid Unix timestamp";
3412 0         0 return undef;
3413             }
3414 0         0 my @tm=localtime($lastsync);
3415 0 0       0 if ($#tm==-1) {
3416 0         0 $LJ::Simple::error="CODE: GetEntries($type) given invalid timestamp";
3417 0         0 return undef;
3418             }
3419 0         0 $Event{lastsync}=strftime("%Y-%m-%d %H:%M:%S",@tm);
3420 0         0 $Event{selecttype}="syncitems";
3421             } else {
3422 0         0 $LJ::Simple::error="CODE: GetEntries() does not understand type $type\n";
3423 0         0 return undef;
3424             }
3425 0 0       0 $self->SendRequest("getevents",\%Event,\%Resp) || return undef;
3426 0         0 my %Ev=();
3427 0         0 my %Pr=();
3428 0         0 my ($k,$v);
3429 0         0 while(($k,$v)=each %Resp) {
3430 0         0 my ($num,$key,$hash)=(undef,undef,undef);
3431 0 0       0 if ($k=~/^events_([0-9]+)_(.*)$/) {
    0          
3432 0         0 ($num,$key,$hash)=($1,$2,\%Ev);
3433             } elsif ($k=~/^prop_([0-9]+)_(.*)$/) {
3434 0         0 ($num,$key,$hash)=($1,$2,\%Pr);
3435             }
3436 0 0       0 if (defined $hash) {
3437 0 0       0 (exists $hash->{$num}) || ($hash->{$num}={});
3438 0         0 $hash->{$num}->{$key}=$v;
3439             }
3440             }
3441 0         0 my $ehr=undef;
3442 0         0 foreach $ehr (values %Ev) {
3443 0         0 my $itemid=$ehr->{itemid};
3444 0         0 $hr->{$itemid}={};
3445 0         0 my $nhr=$hr->{$itemid};
3446 0         0 %{$nhr}=(
  0         0  
3447             __htmlid => ($ehr->{itemid} * 256) + $ehr->{anum},
3448             __anum => $ehr->{anum},
3449             __itemid => $itemid,
3450             event => $ehr->{event},
3451             lineenddings => "unix",
3452             );
3453 0 0       0 (defined $journal) && ($nhr->{usejournal}=$journal);
3454 0 0       0 (exists $ehr->{subject}) && ($nhr->{subject}=$ehr->{subject});
3455 0 0       0 (exists $ehr->{allowmask}) && ($nhr->{allowmask}=$ehr->{allowmask});
3456 0 0       0 (exists $ehr->{security}) && ($nhr->{security}=$ehr->{security});
3457 0 0       0 if ($ehr->{eventtime}=~/([0-9]+)-([0-9]+)-([0-9]+)\s([0-9]+):([0-9]+):([0-9]+)/o) {
3458 0         0 $nhr->{year}=int($1);
3459 0         0 $nhr->{mon}=int($2);
3460 0         0 $nhr->{day}=int($3);
3461 0         0 $nhr->{hour}=int($4);
3462 0         0 $nhr->{min}=int($5);
3463 0         0 my $timet=mktime($6,$5,$4,$3,$2-1,$1-1900);
3464 0 0       0 if (!defined $timet) {
3465 0         0 $LJ::Simple::error="Failed to mktime() from \"$ehr->{eventtime}\" for itemid $hr->{$ehr->{itemid}}->{__htmlid}";
3466 0         0 return undef;
3467             }
3468 0         0 $nhr->{__timet}=$timet;
3469             } else {
3470 0         0 $LJ::Simple::error="Failed to parse eventtime \"$ehr->{eventtime}\" for itemid $hr->{$ehr->{itemid}}->{__htmlid}";
3471 0         0 return undef;
3472             }
3473             }
3474 0         0 my $phr=undef;
3475 0         0 foreach $phr (values %Pr) {
3476 0 0       0 if (!exists $hr->{$phr->{itemid}}) {
3477 0         0 $LJ::Simple::error="Protocol error: properties returned for itemid not seen";
3478 0         0 return undef;
3479             }
3480 0         0 my $nhr=$hr->{$phr->{itemid}};
3481 0         0 my $k=join("_","prop",$phr->{name});
3482 0 0       0 if (!exists $nhr->{$k}) {
3483 0         0 $nhr->{$k}=$phr->{value};
3484             }
3485             }
3486 0         0 return $hr;
3487             }
3488              
3489             =pod
3490              
3491             =back
3492              
3493             =head2 Getting information from an entry
3494              
3495             =over 4
3496              
3497             =item $lj->GetDate($event)
3498              
3499             Gets the date for the event given. The date is returned as a C (i.e. seconds
3500             since epoch) value. Returns C on failure.
3501              
3502             Example code:
3503              
3504             use POSIX; # For strftime()
3505            
3506             ## Get date
3507             my $timet=$lj->GetDate(\%Event);
3508             (defined $timet)
3509             || die "$0: Failed to set date of entry - $LJ::Simple::error\n";
3510            
3511             # Get time list using localtime()
3512             my @tm=localtime($timet);
3513             ($#tm<0) &&
3514             die "$0: Failed to run localtime() on time_t $timet\n";
3515            
3516             # Format date in the normal way used by LJ "YYYY-MM-DD hh:mm:ss"
3517             my $jtime=strftime("%Y-%m-%d %H:%M:%S",@tm);
3518              
3519             =cut
3520             sub GetDate($$) {
3521 0     0 1 0 my $self=shift;
3522 0         0 my ($event)=@_;
3523 0         0 $LJ::Simple::error="";
3524 0 0       0 if (ref($event) ne "HASH") {
3525 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3526 0         0 return undef;
3527             }
3528 0 0       0 if (!exists $event->{__timet}) {
3529 0         0 $LJ::Simple::error="No time value stored";
3530 0         0 return undef;
3531             }
3532 0         0 return $event->{__timet};
3533             }
3534              
3535              
3536             =pod
3537              
3538             =item $lj->GetItemId($event)
3539              
3540             Returns a list which contains the real C, C and HTMLised C which
3541             can be used to contruct a URL suitable for accessing the item via the web.
3542             Returns C on failure. Note that you must only use this
3543             routine on entries which have been returned by the C
3544             routine.
3545              
3546             Example code:
3547              
3548             my ($item_id,$anum,$html_id)=$lj->GetItemId(\%Event);
3549             (defined $item_id)
3550             || die "$0: Failed to get item id - $LJ::Simple::error\n";
3551              
3552             =cut
3553             sub GetItemId($$) {
3554 0     0 1 0 my $self=shift;
3555 0         0 my ($event)=@_;
3556 0         0 $LJ::Simple::error="";
3557 0 0       0 if (ref($event) ne "HASH") {
3558 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3559 0         0 return undef;
3560             }
3561 0 0       0 if (!exists $event->{__itemid}) {
3562 0         0 $LJ::Simple::error="item_id does not exist - must use GetEntries()";
3563 0         0 return undef;
3564             }
3565 0 0       0 if (!exists $event->{__anum}) {
3566 0         0 $LJ::Simple::error="anum does not exist - must use GetEntries()";
3567 0         0 return undef;
3568             }
3569 0 0       0 if (!exists $event->{__htmlid}) {
3570 0         0 $LJ::Simple::error="HTML id does not exist - must use GetEntries()";
3571 0         0 return undef;
3572             }
3573 0         0 return ($event->{__itemid},$event->{__anum},$event->{__htmlid});
3574             }
3575              
3576              
3577             =pod
3578              
3579             =item $lj->GetURL($event)
3580              
3581             Returns the URL which can be used to access the journal entry via a web
3582             browser. Returns C on failure. Note that you must only use this
3583             routine on entries which have been returned by the C
3584             routine.
3585              
3586             Example code:
3587              
3588             my $url=$lj->GetURL(\%Event);
3589             (defined $url)
3590             || die "$0: Failed to get URL - $LJ::Simple::error\n";
3591             system("netscape -remote 'openURL($url)'");
3592              
3593             =cut
3594             sub GetURL($$) {
3595 0     0 1 0 my $self=shift;
3596 0         0 my ($event)=@_;
3597 0         0 $LJ::Simple::error="";
3598 0 0       0 if (ref($event) ne "HASH") {
3599 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3600 0         0 return undef;
3601             }
3602 0 0       0 if (!exists $event->{__htmlid}) {
3603 0         0 $LJ::Simple::error="HTML id does not exist - must use GetEntries()";
3604 0         0 return undef;
3605             }
3606 0         0 my $user=$self->user();
3607 0         0 my $server=$self->{lj}->{host};
3608 0         0 my $port=$self->{lj}->{port};
3609 0         0 my $htmlid=$event->{__htmlid};
3610 0         0 return "http://$server:$port/talkpost.bml\?journal=$user\&itemid=$htmlid";
3611             }
3612              
3613             =pod
3614              
3615             =item $lj->GetSubject($event)
3616              
3617             Gets the subject for the journal entry. Returns the subject if it is
3618             available, C otherwise.
3619              
3620             Example code:
3621              
3622             my $subj=$lj->GetSubject(\%Event)
3623             if (defined $subj) {
3624             print "Subject: $subj\n";
3625             }
3626              
3627             =cut
3628             sub GetSubject($$) {
3629 0     0 1 0 my $self=shift;
3630 0         0 my ($event) = @_;
3631 0         0 $LJ::Simple::error="";
3632 0 0       0 if (ref($event) ne "HASH") {
3633 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3634 0         0 return undef;
3635             }
3636 0 0       0 if (!exists $event->{subject}) {
3637 0         0 $LJ::Simple::error="No subject set";
3638 0         0 return undef;
3639             }
3640 0         0 return $event->{subject};
3641             }
3642              
3643              
3644             =pod
3645              
3646             =item $lj->GetEntry($event)
3647              
3648             Gets the entry for the journal. Returns either a single string which contains
3649             the entire journal entry or C on failure.
3650              
3651             Example code:
3652              
3653             my $ent = $lj->GetEntry(\%Event);
3654             (defined $ent)
3655             || die "$0: Failed to get entry - $LJ::Simple::error\n";
3656             print "Entry: $ent\n";
3657              
3658             =cut
3659             sub GetEntry($$) {
3660 0     0 1 0 my $self=shift;
3661 0         0 my ($event) = @_;
3662 0         0 $LJ::Simple::error="";
3663 0 0       0 if (ref($event) ne "HASH") {
3664 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3665 0         0 return undef;
3666             }
3667 0 0       0 if (!exists $event->{event}) {
3668 0         0 $LJ::Simple::error="No journal entry set";
3669 0         0 return undef;
3670             }
3671 0         0 return $event->{event};
3672             }
3673              
3674              
3675             =pod
3676              
3677             =item $lj->GetProtect($event)
3678              
3679             Gets the protection information on the event given. Returns a list with
3680             details of the protection set on the post. On failure C is returned.
3681              
3682             There are several different types of protection which can be returned for a
3683             journal entry. These include public, friends only, specific friends groups
3684             and private. The list returned will always have the type of protection listed
3685             first followed by any details of that protection. Thus the list can contain:
3686              
3687             ("public")
3688             A publically accessable journal entry
3689            
3690             ("friends")
3691             Only friends may read the entry
3692            
3693             ("groups","group1" ...)
3694             Only users listed in the friends groups given after the "groups"
3695             may read the entry
3696            
3697             ("private")
3698             Only the owner of the journal may read the entry
3699              
3700             Example code:
3701              
3702             my ($protect,@prot_opt)=$lj->GetProtect(\%Event);
3703             (defined $protect) ||
3704             die "$0: Failed to get entry protection type - $LJ::Simple::error\n";
3705             if ($protect eq "public") {
3706             print "Journal entry is public\n";
3707             } elsif ($protect eq "friends") {
3708             print "Journal entry only viewable by friends\n";
3709             } elsif ($protect eq "groups") {
3710             print "Journal entry only viewable by friends in the following groups:\n";
3711             print join(", ",@prot_opt),"\n";
3712             } elsif ($protect eq "private") {
3713             print "Journal entry only viewable by the journal owner\n";
3714             }
3715              
3716             =cut
3717             sub GetProtect($$) {
3718 0     0 1 0 my $self=shift;
3719 0         0 my ($event)=@_;
3720 0         0 $LJ::Simple::error="";
3721 0 0       0 if (ref($event) ne "HASH") {
3722 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3723 0         0 return undef;
3724             }
3725 0 0 0     0 if ((!exists $event->{security})||($event->{security} eq "")) {
3726 0         0 return "public";
3727             }
3728 0 0       0 if ($event->{security} eq "private") {
3729 0         0 return "private";
3730             }
3731 0 0       0 if ($event->{security} ne "usemask") {
3732 0         0 $LJ::Simple::error="INTERNAL: security contains unknown value \"$event->{security}\"";
3733 0         0 return undef;
3734             }
3735 0 0       0 if (($event->{allowmask} & 1) == 1) {
3736 0         0 return "friends";
3737             }
3738 0         0 my @lst=("groups");
3739 0         0 my $g=undef;
3740 0         0 foreach $g (keys %{$self->{groups}->{name}}) {
  0         0  
3741 0         0 my $bit=1 << $self->{groups}->{name}->{$g}->{id};
3742 0 0       0 if (($event->{allowmask} & $bit) == $bit) {
3743 0         0 push(@lst,$g);
3744             }
3745             }
3746 0         0 return @lst;
3747             }
3748              
3749              
3750             ##
3751             ## Helper function used to get meta data
3752             ##
3753             sub Getprop_general($$$$$) {
3754 0     0 0 0 my ($self,$event,$prop,$caller,$type)=@_;
3755 0         0 $LJ::Simple::error="";
3756 0 0       0 if (ref($event) ne "HASH") {
3757 0         0 $LJ::Simple::error="CODE: Not given a hash reference";
3758 0         0 return undef;
3759             }
3760 0         0 my $key=join("_","prop",$prop);
3761 0 0       0 if (!exists $event->{$key}) {
3762 0 0       0 if ($type eq "bool") {
3763 0         0 return 0;
3764             }
3765 0         0 return "";
3766             }
3767 0         0 return $event->{$key};
3768             }
3769              
3770             =pod
3771              
3772             =item $lj->Getprop_backdate($event)
3773              
3774             Indicates if the journal entry is back dated or not. Back dated
3775             entries do not appear on the friends view of your journal entries. Returns
3776             C<1> if the entry is backdated, C<0> if it is not. C is returned in the
3777             event of an error.
3778              
3779             Example code:
3780              
3781             my $prop=$lj->Getprop_backdate(\%Event);
3782             (defined $prop) ||
3783             die "$0: Failed to get property - $LJ::Simple::error\n";
3784             if ($prop) {
3785             print STDERR "Journal is backdated\n";
3786             } else {
3787             print STDERR "Journal is not backdated\n";
3788             }
3789            
3790              
3791             =cut
3792             sub Getprop_backdate($$) {
3793 0     0 1 0 my ($self,$event)=@_;
3794 0         0 $LJ::Simple::error="";
3795 0         0 return $self->Getprop_general($event,"opt_backdated","Getprop_backdate","bool");
3796             }
3797              
3798              
3799             =pod
3800              
3801             =item $lj->Getprop_current_mood($event)
3802              
3803             Used to get the current mood for the journal being written. This returns the
3804             mood if one exists, an empty string if none exists or C in the event
3805             of an error.
3806              
3807             Example code:
3808              
3809             my $prop=$lj->Getprop_current_mood(\%Event);
3810             (defined $prop) ||
3811             die "$0: Failed to get property - $LJ::Simple::error\n";
3812             if ($prop ne "") {
3813             print STDERR "Journal has mood of $prop\n";
3814             } else {
3815             print STDERR "Journal has no mood set\n";
3816             }
3817              
3818              
3819             =cut
3820             sub Getprop_current_mood($$) {
3821 0     0 1 0 my ($self,$event)=@_;
3822 0         0 $LJ::Simple::error="";
3823 0         0 return $self->Getprop_general($event,"current_mood","Getprop_current_mood","char");
3824             }
3825              
3826             =pod
3827              
3828             =item $lj->Getprop_current_mood_id($event)
3829              
3830             Used to get the current mood_id for the journal being written. Will return
3831             the mood_id if one is set, a null string is one is not set and C in
3832             the event of an error.
3833              
3834             Example code:
3835              
3836             my $prop=$lj->Getprop_current_mood_id(\%Event);
3837             (defined $prop) ||
3838             die "$0: Failed to get property - $LJ::Simple::error\n";
3839             if ($prop ne "") {
3840             print STDERR "Journal has mood_id of $prop\n";
3841             } else {
3842             print STDERR "Journal has no mood_id set\n";
3843             }
3844              
3845              
3846             =cut
3847             sub Getprop_current_mood_id($$) {
3848 0     0 1 0 my ($self,$event)=@_;
3849 0         0 $LJ::Simple::error="";
3850 0         0 return $self->Getprop_general($event,"current_moodid","Getprop_current_mood_id","num");
3851             }
3852              
3853              
3854             =pod
3855              
3856             =item $lj->Getprop_current_music($event)
3857              
3858             Used to get the current music for the journal entry being written. Returns
3859             the music if one is set, a null string is one is not set and C in
3860             the event of an error.
3861              
3862             Example code:
3863              
3864             my $prop=$lj->Getprop_current_music(\%Event);
3865             (defined $prop) ||
3866             die "$0: Failed to get property - $LJ::Simple::error\n";
3867             if ($prop) {
3868             print STDERR "Journal has the following music: $prop\n";
3869             } else {
3870             print STDERR "Journal has no music set for it\n";
3871             }
3872              
3873             =cut
3874             sub Getprop_current_music($$) {
3875 0     0 1 0 my ($self,$event)=@_;
3876 0         0 $LJ::Simple::error="";
3877 0         0 return $self->Getprop_general($event,"current_music","Getprop_current_music","char");
3878             }
3879              
3880             =pod
3881              
3882             =item $lj->Getprop_preformatted($event)
3883              
3884             Used to see if the text for the journal entry being written is preformatted in HTML
3885             or not. This returns true (C<1>) if so, false (C<0>) if not.
3886              
3887             Example code:
3888              
3889             $lj->Getprop_preformatted(\%Event) &&
3890             print "Journal entry is preformatted\n";
3891              
3892             =cut
3893             sub Getprop_preformatted($$) {
3894 0     0 1 0 my ($self,$event)=@_;
3895 0         0 $LJ::Simple::error="";
3896 0         0 return $self->Getprop_general($event,"opt_preformatted","Getprop_preformatted","bool");
3897             }
3898              
3899              
3900             =pod
3901              
3902             =item $lj->Getprop_nocomments($event)
3903              
3904             Used to see if the journal entry being written can be commented on or not.
3905             This returns true (C<1>) if so, false (C<0>) if not.
3906              
3907             Example code:
3908              
3909             $lj->Getprop_nocomments(\%Event) &&
3910             print "Journal entry set to disallow comments\n";
3911              
3912             =cut
3913             sub Getprop_nocomments($$) {
3914 0     0 1 0 my ($self,$event)=@_;
3915 0         0 $LJ::Simple::error="";
3916 0         0 return $self->Getprop_general($event,"opt_nocomments","Getprop_nocomments","bool");
3917             }
3918              
3919              
3920             =pod
3921              
3922             =item $lj->Getprop_picture_keyword($event)
3923              
3924             Used to get the picture keyword for the journal entry being written. Returns
3925             the picture keyword if one is set, a null string is one is not set and C in
3926             the event of an error.
3927              
3928             Example code:
3929              
3930             my $prop=$lj->Getprop_picture_keyword(\%Event);
3931             (defined $prop) ||
3932             die "$0: Failed to get property - $LJ::Simple::error\n";
3933             if ($prop) {
3934             print STDERR "Journal has picture keyword $prop set\n";
3935             } else {
3936             print STDERR "Journal has no picture keyword set\n";
3937             }
3938              
3939              
3940             =cut
3941             sub Getprop_picture_keyword($$) {
3942 0     0 1 0 my ($self,$event)=@_;
3943 0         0 $LJ::Simple::error="";
3944 0         0 return $self->Getprop_general($event,"picture_keyword","Getprop_picture_keyword","char");
3945             }
3946              
3947              
3948             =pod
3949              
3950             =item $lj->Getprop_noemail($event)
3951              
3952             Used to see if comments on the journal entry being written should be emailed or
3953             not. This returns true (C<1>) if so comments should B be emailed and false
3954             (C<0>) if they should be emailed.
3955              
3956             Example code:
3957              
3958             $lj->Getprop_noemail(\%Event) &&
3959             print "Comments to journal entry not emailed\n";
3960              
3961             =cut
3962             sub Getprop_noemail($$) {
3963 0     0 1 0 my ($self,$event)=@_;
3964 0         0 $LJ::Simple::error="";
3965 0         0 return $self->Getprop_general($event,"opt_noemail","Getprop_noemail","bool");
3966             }
3967              
3968              
3969             =pod
3970              
3971             =item $lj->Getprop_unknown8bit($event)
3972              
3973             Used see if there is 8-bit data which is not in UTF-8 in the journal entry
3974             being written. This returns true (C<1>) if so, false (C<0>) if not.
3975              
3976             Example code:
3977              
3978             $lj->Getprop_unknown8bit(\%Event) &&
3979             print "Journal entry contains 8-bit data not in UTF-8 format\n";
3980              
3981             =cut
3982             sub Getprop_unknown8bit($$) {
3983 0     0 1 0 my ($self,$event)=@_;
3984 0         0 $LJ::Simple::error="";
3985 0         0 return $self->Getprop_general($event,"unknown8bit","Getprop_unknown8bit","bool");
3986             }
3987              
3988              
3989              
3990             ##### Start of helper functions
3991              
3992             ##
3993             ## A helper function which takes a key and value pair;
3994             ## both are encoded for HTTP transit.
3995             ##
3996             sub EncVal($$) {
3997 30     30 0 48 my ($key,$val)=@_;
3998 30 50       54 (defined $key) || ($key="");
3999 30 50       50 (defined $val) || ($val="");
4000 30         85 $key=~s/([^a-z0-9])/sprintf("%%%x",ord($1))/egsi;
  12         64  
4001 30         47 $key=~s/ /\+/go;
4002 30         52 $val=~s/([^a-z0-9])/sprintf("%%%02x",ord($1))/egsi;
  40         131  
4003 30         41 $val=~s/ /\+/go;
4004 30         101 return "$key=$val";
4005             }
4006              
4007             ##
4008             ## A helper function which takes an encoded value from HTTP
4009             ## transit and decodes it
4010             ##
4011             sub DecVal($) {
4012 28     28 0 42 my ($val)=@_;
4013 28 50       56 (defined $val) || ($val="");
4014 28         69 $val=~s/\+/ /go;
4015 28         38 $val=~s/%([0-9A-F]{2})/pack("C", hex($1))/egsi;
  0         0  
4016 28         157 return "$val";
4017             }
4018              
4019             ##
4020             ## Actually make the LJ request; could be called directly, but isn't
4021             ## documented.
4022             ##
4023             ## The first argument is the the mode to use. The list of currently
4024             ## supported modes is:
4025             ## o login
4026             ## o postevent
4027             ##
4028             ## The second argument is a hash reference to arguments specific to the
4029             ## mode.
4030             ##
4031             ## The third argument is a reference to a hash which contain the response
4032             ## from the LJ server. This can be undef.
4033             ##
4034             ## Returns 1 on success, 0 on failure. On failure $LJ::Simple::error is
4035             ## populated.
4036             ##
4037             sub SendRequest($$$$) {
4038 10     10 0 23 my ($self,$mode,$args,$req_hash)=@_;
4039 10         13 $LJ::Simple::error="";
4040 10         13 my $sub=$LJ::Simple::NonBlock;
4041 10         12 my $bytes_in=0;
4042 10         11 my $bytes_out=0;
4043 10         19 my $timestart=time();
4044 10 50 33     27 if ((defined $sub) && (ref($sub) ne "CODE")) {
4045 0         0 my $reftype=ref($sub);
4046 0         0 $LJ::Simple::error="\$LJ::Simple::NonBlock given a $reftype reference, not CODE";
4047 0         0 return 0;
4048             }
4049 10         21 $self->{request}={};
4050 10 50 66     133 if ((ref($args) ne "HASH")&&($mode ne "getchallenge")) {
4051 0         0 $LJ::Simple::error="INTERNAL: SendRequest() not given hashref for arguments";
4052 0         0 return 0;
4053             }
4054 10 50 66     44 if ((defined $req_hash) && (ref($req_hash) ne "HASH")) {
4055 0         0 $LJ::Simple::error="INTERNAL: SendRequest() not given hashref for responses";
4056 0         0 return 0;
4057             }
4058 10         19 $mode=lc($mode);
4059 10         82 my @request=(
4060             "mode=$mode",
4061             );
4062 10 100       23 if ($mode ne "getchallenge") {
4063 5         22 push(@request,
4064             EncVal("user",$self->{auth}->{user}),
4065             );
4066             # Much fun here - see if we use the challenge-response stuff
4067 5 50       13 if ($LJ::Simple::challenge) {
4068 5         11 Debug("Trying to use challenge-response system");
4069 5         15 Debug(" Getting new challenge");
4070 5         11 my %chall=();
4071 5 100       42 $self->SendRequest("getchallenge",undef,\%chall) || return 0;
4072 4 50       17 if ($chall{auth_scheme} ne "c0") {
4073 0         0 $LJ::Simple::error="Server returned unsupported auth_scheme \"$chall{auth_scheme}\"";
4074 0         0 return 0;
4075             }
4076 4         15 Debug(" Got challenge from server:");
4077 4         24 Debug(" challenge: $chall{challenge}");
4078 4         23 Debug(" expire_time: $chall{expire_time}");
4079 4         17 Debug(" server_time: $chall{server_time}");
4080              
4081             # Work out our own timeout point, basically the livetime of the
4082             # challenge less 10 seconds of fudge factor.
4083 4         17 my $chall_livetime=$chall{expire_time} - $chall{server_time} - 10;
4084 4         8 my $ctime=time();
4085 4         18 $self->{auth}->{challenge}->{timeout}=$ctime + $chall_livetime;
4086 4         13 Debug(" Challenge lifetime is $chall_livetime seconds");
4087 4         14 Debug(" Current: $ctime");
4088 4         20 Debug(" Expire: $self->{auth}->{challenge}->{timeout}");
4089              
4090 4         15 $self->{auth}->{challenge}->{challenge}=$chall{challenge};
4091             # We assume that the Digest::MD5 module is loaded already; also
4092             # means that we have an MD5 hash of the password to hand.
4093 4         49 my $md5=Digest::MD5->new;
4094 4         33 $md5->add($chall{challenge});
4095 4         19 $md5->add($self->{auth}->{hash});
4096 4         48 $self->{auth}->{challenge}->{hash}=$md5->hexdigest;
4097             }
4098 4 50       15 if (exists $self->{auth}->{challenge}->{hash}) {
4099 4         17 push(@request,
4100             EncVal("auth_method","challenge"),
4101             EncVal("auth_challenge",$self->{auth}->{challenge}->{challenge}),
4102             EncVal("auth_response",$self->{auth}->{challenge}->{hash}),
4103             );
4104             } else {
4105 0 0       0 if (exists $self->{auth}->{hash}) {
4106 0         0 push(@request,EncVal("hpassword",$self->{auth}->{hash}));
4107             } else {
4108 0         0 push(@request,EncVal("password",$self->{auth}->{pass}));
4109             }
4110             }
4111 4         10 my $ljprotver=0;
4112 4 50       10 if ($LJ::Simple::UTF) { $ljprotver=1; }
  4         6  
4113 4         12 push(@request,
4114             "ver=$ljprotver",
4115             );
4116             }
4117 9 50       23 (defined $sub) && &{$sub}($mode,0.1,"Preparing request data",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4118 9 100 33     146 if ($mode eq "login") {
    50 33        
    50 33        
      33        
      33        
      33        
      33        
      33        
      33        
4119 4         15 push(@request,EncVal("clientversion","Perl-LJ::Simple/$VERSION"));
4120 4 100 66     30 if ((exists $args->{moods}) && ($args->{moods} == 1)) {
4121 3         7 push(@request,EncVal("getmoods",0));
4122             }
4123 4 100 66     26 if ((exists $args->{getpickws}) && ($args->{getpickws} == 1)) {
4124 3         7 push(@request,EncVal("getpickws",1));
4125 3         9 push(@request,EncVal("getpickwurls",1));
4126             }
4127             } elsif ( ($mode eq "postevent")
4128             || ($mode eq "editevent")
4129             || ($mode eq "syncitems")
4130             || ($mode eq "getevents")
4131             || ($mode eq "getfriends")
4132             || ($mode eq "friendof")
4133             || ($mode eq "checkfriends")
4134             || ($mode eq "getdaycounts")
4135             || ($mode eq "getfriendgroups")
4136             || ($mode eq "getusertags")
4137             ) {
4138 0 0       0 if (defined $args) {
4139 0         0 my ($k,$v);
4140 0         0 while(($k,$v)=each %{$args}) {
  0         0  
4141 0 0       0 if (!defined $k) {
4142 0         0 $LJ::Simple::error="CODE: SendRequest() given undefined key value";
4143 0         0 return 0;
4144             }
4145 0 0       0 if (!defined $v) {
4146 0         0 $LJ::Simple::error="CODE: SendRequest() given undefined value for \"$k\"";
4147 0         0 return 0;
4148             }
4149 0         0 push(@request,EncVal($k,$v));
4150             }
4151             }
4152             } elsif ($mode eq "getchallenge") {
4153             # NOP - nothing required
4154             } else {
4155 0         0 $LJ::Simple::error="INTERNAL: SendRequest() given unsupported mode \"$mode\"";
4156 0         0 return 0;
4157             }
4158 9         41 my $req=join("&",@request);
4159 9         12 my $ContLen=length($req);
4160              
4161 9 50       25 (defined $sub) && &{$sub}($mode,0.2,"Preparing connection to server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4162              
4163             ## Now we've got the request ready, time to start talking to the web
4164             # Work out where we're talking to and the URI to do it with
4165 9         29 my $server=$self->{lj}->{host};
4166 9         14 my $host=$server;
4167 9         17 my $port=$self->{lj}->{port};
4168 9         15 my $uri="/interface/flat";
4169 9 50       31 if (defined $self->{proxy}) {
4170 0         0 $uri="http://$server:$port$uri";
4171 0         0 $server=$self->{proxy}->{host};
4172 0         0 $port=$self->{proxy}->{port};
4173             }
4174              
4175             # Prepare the HTTP request now we've got the URI
4176 9         62 my @HTTP=(
4177             "POST $uri HTTP/1.0",
4178             "Host: $host",
4179             "Content-type: application/x-www-form-urlencoded",
4180             "User-Agent: LJ::Simple/$VERSION; http://www.bpfh.net/computing/software/LJ::Simple/; lj-simple\@bpfh.net",
4181             "Content-length: $ContLen",
4182             );
4183 9 50       29 if ($self->{fastserver}) {
4184 0         0 push(@HTTP,"Cookie: ljfastserver=1");
4185             }
4186 9         19 push(@HTTP,
4187             "",
4188             $req,
4189             "",
4190             );
4191              
4192             # Prepare the socket
4193 9         1992 my $tcp_proto=getprotobyname("tcp");
4194 9         327 socket(SOCK,PF_INET,SOCK_STREAM,$tcp_proto);
4195              
4196             # Resolve the server name we're connecting to
4197 9 50       27 (defined $sub) && &{$sub}($mode,0.3,"Starting to resolve $server to IP address",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4198 9         124877 my $addr=inet_aton($server);
4199 9 50       72 if (!defined $addr) {
4200 0         0 $LJ::Simple::error="Failed to resolve server $server";
4201 0         0 return 0;
4202             }
4203 9         81 my $sin=sockaddr_in($port,$addr);
4204              
4205 9         290 my $ip_addr=join(".",unpack("CCCC",$addr));
4206              
4207 9         26 my $proto=$LJ::Simple::ProtoSub;
4208 9 50       29 ($LJ::Simple::protocol) && &{$proto}(undef,undef,$server,$ip_addr);
  0         0  
4209 9 50       25 if ($LJ::Simple::raw_protocol) {
4210 0         0 print STDERR "Connecting to $server [$ip_addr]\n";
4211 0         0 print STDERR "Lines starting with \"-->\" is data SENT to the server\n";
4212 0         0 print STDERR "Lines starting with \"<--\" is data RECEIVED from the server\n";
4213             }
4214              
4215             # Connect to the server
4216 9 50       25 (defined $sub) && &{$sub}($mode,0.4,"Trying to connect to server $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4217 9 50       1266017 if (!connect(SOCK,$sin)) {
4218 0         0 $LJ::Simple::error="Failed to connect to $server - $!";
4219 0         0 return 0;
4220             }
4221              
4222 9 50       55 ($LJ::Simple::protocol) && &{$proto}(undef,"Connected to $server [$ip_addr]",$server,$ip_addr);
  0         0  
4223 9 50       36 ($LJ::Simple::raw_protocol) &&
4224             print STDERR "Connected to $server [$ip_addr]\n";
4225              
4226             # Send the HTTP request
4227 9 50       39 (defined $sub) && &{$sub}($mode,0.5,"Starting to send HTTP request to $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4228 9         27 my $cp=0.5;
4229 9         55 foreach (@HTTP) {
4230 72         180 my $line="$_\r\n";
4231 72         96 my $len=length($line);
4232 72         77 my $pos=0;
4233 72         71 my $fail=0;
4234 72         409 while($pos!=$len) {
4235 72         1216 my $nbytes=syswrite(SOCK,$line,$len,$pos);
4236 72 50       587 if (!defined $nbytes) {
4237 0 0 0     0 if ( ($! == EAGAIN) || ($! == EINTR) ) {
4238 0         0 $fail++;
4239 0 0       0 if ($fail>4) {
4240 0         0 $LJ::Simple::error="Write to socket failed with EAGAIN/EINTR $fail times";
4241 0         0 shutdown(SOCK,2);
4242 0         0 close(SOCK);
4243 0         0 return 0;
4244             }
4245 0         0 next;
4246             } else {
4247 0         0 $LJ::Simple::error="Write to socket failed - $!";
4248 0         0 shutdown(SOCK,2);
4249 0         0 close(SOCK);
4250 0         0 return 0;
4251             }
4252             }
4253 72         326 $pos+=$nbytes;
4254 72         79 $bytes_out+=$nbytes;
4255 72         91 $cp=$cp+0.001;
4256 72 50       241 (defined $sub) && &{$sub}($mode,$cp,"Sending HTTP request to $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4257             }
4258 72 50       122 ($LJ::Simple::protocol) && &{$proto}(0,$_,$server,$ip_addr);
  0         0  
4259 72 50       200 ($LJ::Simple::raw_protocol) && print STDERR "--> $_\n";
4260             }
4261              
4262             # Read the response from the server - use select()
4263 9 50       38 (defined $sub) && &{$sub}($mode,0.6,"Getting HTTP response from $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4264 9         15 $cp=0.6001;
4265 9         29 my ($rin,$rout,$eout)=("","","");
4266 9         114 vec($rin,fileno(SOCK),1) = 1;
4267 9         28 my $ein = $rin;
4268 9         17 my $response="";
4269 9         19 my $done=0;
4270 9         39 while (!$done) {
4271 18         30 my $nfound;
4272 18 50       51 if (defined $sub) {
4273 0         0 $nfound = select($rout=$rin,undef,$eout=$ein,0);
4274 0         0 my $ttaken=time()-$timestart;
4275 0 0       0 if ($nfound!=1) {
4276 0 0       0 if ($ttaken>$LJ::Simple::timeout) {
4277 0         0 &{$sub}($mode,1,"Connection with server $server timed out",$bytes_in,$bytes_out,$ttaken,0);
  0         0  
4278 0         0 $LJ::Simple::error="Failed to receive data from $server [$ip_addr]";
4279 0         0 shutdown(SOCK,2);
4280 0         0 close(SOCK);
4281 0         0 return 0;
4282             }
4283 0         0 &{$sub}($mode,$cp,"Waiting for response from $server",$bytes_in,$bytes_out,time()-$timestart,1);
  0         0  
4284 0         0 next;
4285             }
4286             } else {
4287 18         3532566 $nfound = select($rout=$rin,undef,$eout=$ein,$LJ::Simple::timeout);
4288 18 50       112 if ($nfound!=1) {
4289 0         0 $LJ::Simple::error="Failed to receive data from $server [$ip_addr]";
4290 0         0 shutdown(SOCK,2);
4291 0         0 close(SOCK);
4292 0         0 return 0;
4293             }
4294             }
4295 18         40 my $resp="";
4296 18         250 my $nbytes=sysread(SOCK,$resp,$LJ::Simple::buffer);
4297 18 50       242 if (!defined $nbytes) {
    100          
4298 0         0 $LJ::Simple::error="Error in getting data from $server [$ip_addr] - $!";
4299 0         0 shutdown(SOCK,2);
4300 0         0 close(SOCK);
4301 0 0       0 (defined $sub) && &{$sub}($mode,1,$LJ::Simple::error,$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4302 0         0 return 0;
4303             } elsif ($nbytes==0) {
4304 9         35 $done=1;
4305             } else {
4306 9         192 $bytes_in=$bytes_in+$nbytes;
4307 9 50       26 (defined $sub) && &{$sub}($mode,$cp,"Getting response from server $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4308 9         23 $cp=$cp+0.001;
4309 9         41 $response="$response$resp";
4310 9 50       77 if ($LJ::Simple::raw_protocol) {
    50          
4311 0         0 print STDERR "<-- ";
4312 0         0 foreach (split(//,$resp)) {
4313 0         0 s/([\x00-\x20\x7f-\xff])/sprintf("\\%o",ord($1))/ei;
  0         0  
4314 0         0 print "$_";
4315             }
4316 0         0 print STDERR "\n";
4317             } elsif ($LJ::Simple::protocol) {
4318 0         0 foreach (split(/[\r\n]{1,2}/o,$resp)) {
4319 0         0 &{$proto}(1,$_,$server,$ip_addr);
  0         0  
4320             }
4321             }
4322             }
4323             }
4324 9 50       162 (defined $sub) && &{$sub}($mode,0.7,"Finished getting data from server $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4325            
4326             # Shutdown the socket
4327 9 50       739 if (!shutdown(SOCK,2)) {
4328 0         0 $LJ::Simple::error="Failed to shutdown socket - $!";
4329 0 0       0 (defined $sub) && &{$sub}($mode,1,$LJ::Simple::error,$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4330 0         0 return 0;
4331             }
4332              
4333             # Close the socket
4334 9         208 close(SOCK);
4335              
4336 9 50       32 (defined $sub) && &{$sub}($mode,0.8,"Parsing data from server $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4337             ## We've got the response from the server, so we now parse it
4338 9 50       27 if (!defined $response) {
4339 0         0 $LJ::Simple::error="Failed to get result from server";
4340 0         0 return 0;
4341             }
4342              
4343             ## Ensure that response isn't zero length
4344 9 50       37 if (length($response) == 0) {
4345 0         0 $LJ::Simple::error="Zero length response from server";
4346 0 0       0 (defined $sub) && &{$sub}($mode,1,"$LJ::Simple::error $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4347 0         0 return 0;
4348             }
4349              
4350             # Split into headers and body
4351 9         96 my ($http,$body)=split(/\r\n\r\n/,$response,2);
4352              
4353 9 50       37 if (!defined $http) {
4354 0         0 $LJ::Simple::error="Failed to get HTTP headers from server";
4355 0 0       0 (defined $sub) && &{$sub}($mode,1,"$LJ::Simple::error $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4356 0         0 return 0;
4357             }
4358 9 50       27 if (!defined $body) {
4359 0         0 $LJ::Simple::error="Failed to get HTTP body from server";
4360 0 0       0 (defined $sub) && &{$sub}($mode,1,"$LJ::Simple::error $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4361 0         0 return 0;
4362             }
4363              
4364             # First lets see if we got a valid response
4365 9         104 $self->{request}->{http}={};
4366 9         178 $self->{request}->{http}->{headers}=[(split(/\r\n/,$http))];
4367 9         39 my $srv_resp=$self->{request}->{http}->{headers}->[0];
4368 9         136 $srv_resp=~/^HTTP\/[^\s]+\s([0-9]+)\s+(.*)/;
4369 9         51 my ($srv_code,$srv_msg)=($1,$2);
4370 9         34 $self->{request}->{http}->{code}=$srv_code;
4371 9         28 $self->{request}->{http}->{msg}=$srv_msg;
4372 9 100       35 if ($srv_code != 200) {
4373 1         4 $LJ::Simple::error="HTTP request failed with $srv_code $srv_msg";
4374 1         60 return 0;
4375             }
4376              
4377             # We did, so lets pull in the LJ stuff for processing
4378 8         31 $self->{request}->{lj}={};
4379              
4380             # The response from LJ takes the form of a key\nvalue\n
4381             # Note that the value can be null tho
4382 8         30 $done=0;
4383 8         34 while (!$done) {
4384 36 100       161 if ($body=~/^([^\n]+)\n([^\n]*)\n(.*)$/so) {
4385 28         62 my ($k,$v)=(undef,undef);
4386 28         108 ($k,$v,$body)=(lc($1),DecVal($2),$3);
4387 28         57 $v=~s/\r\n/\n/go;
4388 28         105 $self->{request}->{lj}->{$k}=$v;
4389             } else {
4390 8         28 $done=1;
4391             }
4392             }
4393              
4394             # Got it into a hash - lets see if we made a successful request
4395 8 100 66     155 if ( (!exists $self->{request}->{lj}->{success}) ||
4396             ($self->{request}->{lj}->{success} ne "OK") ) {
4397 4         9 my $errmsg="Server Error, try again later";
4398 4 50       20 if (exists $self->{request}->{lj}->{errmsg}) {
4399 4         11 $errmsg=$self->{request}->{lj}->{errmsg};
4400             }
4401 4         13 $LJ::Simple::error="LJ request failed: $errmsg";
4402 4 50       10 (defined $sub) && &{$sub}($mode,1,"$LJ::Simple::error $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4403 4         126 return 0;
4404             }
4405              
4406             # We did!
4407             # Now to populate the hash we were given (if asked to)
4408 4 50       12 if (defined $req_hash) {
4409 4         5 %{$req_hash}=();
  4         12  
4410 4         6 my ($k,$v);
4411 4         6 while(($k,$v)=each %{$self->{request}->{lj}}) {
  24         83  
4412 20         38 $req_hash->{$k}=$v;
4413             }
4414             }
4415              
4416 4 50       15 (defined $sub) && &{$sub}($mode,1,"Finished processing request to server $server",$bytes_in,$bytes_out,time()-$timestart,0);
  0         0  
4417 4         39 return 1;
4418             }
4419              
4420             ##
4421             ## Output debugging info
4422             ##
4423             sub Debug(@) {
4424 60 50   60 0 152 ($LJ::Simple::debug) || return;
4425 0         0 my $msg=join("",@_);
4426 0         0 foreach (split(/\n/,$msg)) {
4427 0         0 print STDERR "DEBUG> $_\n";
4428             }
4429             }
4430              
4431              
4432             ##
4433             ## Dump out a list recursively. Will call dump_hash
4434             ## for any hash references in the list.
4435             ##
4436             ## Generally used for debugging
4437             ##
4438             sub dump_list($$) {
4439 0     0 0 0 my ($lr,$sp)=@_;
4440 0         0 my $le="";
4441 0         0 my $res="";
4442 0         0 foreach $le (@{$lr}) {
  0         0  
4443 0 0       0 if (ref($le) eq "HASH") {
    0          
4444 0         0 $res="$res$sp\{\n";
4445 0         0 $res=$res . dump_hash($le,"$sp ");
4446 0         0 $res="$res$sp},\n";
4447             } elsif (ref($le) eq "ARRAY") {
4448 0         0 $res="$res$sp\[\n" . dump_list($le,"$sp ") . "$sp],\n";
4449             } else {
4450 0         0 my $lv=$le;
4451 0 0       0 if (defined $lv) {
4452 0         0 $lv=~s/\n/\\n/go;
4453 0         0 $lv=quotemeta($lv);
4454 0         0 $lv=~s/\\-/-/go;
4455 0         0 $lv="\"$lv\"";
4456             } else {
4457 0         0 $lv="undef";
4458             }
4459 0         0 $res="$res$sp$lv,\n";
4460             }
4461             }
4462 0         0 return $res;
4463             }
4464              
4465             ##
4466             ## Dump out a hash recursively. Will call dump_list
4467             ## for any list references in the hash values.
4468             ##
4469             ## Generally used for debugging
4470             ##
4471             sub dump_hash($$) {
4472 18     18 0 27 my ($hr,$sp)=@_;
4473 18         23 my ($k,$v)=();
4474 18         24 my $res="";
4475 18         23 while(($k,$v)=each %{$hr}) {
  57         201  
4476 39         80 $k=quotemeta($k);
4477 39         50 $k=~s/\\-/-/go;
4478 39 100       85 if (ref($v) eq "HASH") {
    50          
4479 14         31 $res="$res$sp\"$k\"\t=> {\n";
4480 14         54 $res=$res . dump_hash($v,"$sp ");
4481 14         36 $res="$res$sp},\n";
4482             } elsif (ref($v) eq "ARRAY") {
4483 0         0 $res="$res$sp\"$k\"\t=> \[\n" . dump_list($v,"$sp ") . "$sp],\n";
4484             } else {
4485 25 100       36 if (defined $v) {
4486 24         41 $v=~s/\n/\\n/go;
4487 24         32 $v=quotemeta($v);
4488 24         30 $v=~s/\\\\n/\\n/go;
4489 24         24 $v=~s/\\-/-/go;
4490 24         43 $v="\"$v\"";
4491             } else {
4492 1         3 $v="undef";
4493             }
4494 25         53 my $out="$sp\"$k\"\t=> $v,";
4495 25         62 $res="$res$out\n";
4496             }
4497             }
4498 18         53 return $res;
4499             }
4500              
4501             1;
4502             __END__