File Coverage

blib/lib/WWW/Sitebase/Poster.pm
Criterion Covered Total %
statement 42 183 22.9
branch 0 68 0.0
condition 0 12 0.0
subroutine 14 33 42.4
pod 13 13 100.0
total 69 309 22.3


line stmt bran cond sub pod time code
1             # $Id: Poster.pm,v 1.1 2013/12/22 05:33:16 grant Exp $
2              
3             package WWW::Sitebase::Poster;
4              
5 2     2   10217 use warnings;
  2         9  
  2         61  
6 2     2   7 use strict;
  2         2  
  2         38  
7 2     2   5 use WWW::Sitebase -Base;
  2         2  
  2         15  
8 2     2   5214 use IO::Prompt;
  2     2   3  
  2     2   30  
  2         6  
  2         1  
  2         52  
  2         933  
  2         26489  
  2         12  
9 2     2   93 use Carp;
  2         2  
  2         94  
10 2     2   7 use File::Spec::Functions;
  2         3  
  2         126  
11 2     2   1442 use List::Compare;
  2         27381  
  2         896  
12              
13             =head1 NAME
14              
15             WWW::Sitebase::Poster - Base class for web site posting routines
16              
17             =head1 VERSION
18              
19             Version 0.4
20              
21             =cut
22              
23             our $VERSION = '0.4';
24              
25             =head1 SYNOPSIS
26              
27             package MyPostingModule;
28            
29             use WWW::Sitebase::Poster -Base;
30            
31             # Define your options
32             sub default_options {
33             my $options = super;
34              
35             $options->{cache_file} = { default => 'mypostingmodule' }; # (VERY IMPORTANT)
36             $options->{my_option} = 0; # 0 = not required. 1 means required.
37             $options->{my_option} = { default => 'mydefault' }; # Sets a default for your option.
38            
39             # Some common example options, say for posting messages or comments:
40             $options->{subject} = 1; # Require subject
41             $options->{message} = 1; # Require a message
42              
43             return $options;
44              
45             }
46            
47             # Add accessors if you like (usually a good idea)
48             # (Poster.pm already gives you the cache_file accessor).
49             field 'my_option';
50             field 'subject';
51             field 'message';
52            
53             # Define your send_post method (see examples below)
54             sub send_post {
55            
56             my ( $friend_id ) = @_;
57              
58             $result = $self->browser->do_something( $friend_id, $other_value );
59              
60             # ... Do anything else you need ...
61            
62             return $result; # $result must be P, R, F, or undef. (Pass, Retry, Fail, or stop)
63              
64             }
65            
66            
67             ----------------
68             Then you or others can write a script that uses your module.
69            
70             #!/usr/bin/perl -w
71            
72             use MyPostingModule;
73             use WWW::Myspace;
74            
75             my @friend_list = &fancy_friend_gathering_routine;
76            
77             my $poster = new MyPostingModule(
78             browser => new WWW::Myspace, # Note, this'll prompt for username/password
79             friend_ids => \@friend_list,
80             subject => 'hi there!',
81             message => 'I'm writing you a message!',
82             noisy => 1,
83             interactive => 1,
84             );
85            
86             $poster->post;
87              
88             This is a base class for modules that need to post things and remember
89             to whom they've posted.
90             If you're writing a new module that needs to send something and
91             remember stuff about it, you'll want to look at this module. It gives
92             you all sorts of neat tools, like write_log and read_log to remember
93             what you did, and it automatically parses all your arguments right
94             in the new method, and can even read them from a
95             config file in CFG or YAML format. All the "new" method stuff it just
96             inherits from WWW::Sitebase, so look there for more info.
97              
98             The cache_file is where write_log and read_log write and read their data.
99              
100             You MUST set the cache_file default to something specific to your module.
101             This will be used by the cache_file method to return (and create if needed)
102             the default cache file for your module. Make sure it's unique to "Poster" modules.
103             (Hint: name it after your module). Your default filename will be placed
104             in the value returned by $self->cache_dir (.www-poster by default), so don't
105             specify a path. If you're writing a WWW::Myspace module, you
106             should override cache_dir. See "cache_dir" below.
107              
108             This module itself is a subclass of WWW::Sitebase, so it inherits
109             "new", default_options, and a few other methods from there. Be
110             sure to read up on WWW::Sitebase if you're not familiar with it,
111             as your class will magically inherit those methods too.
112              
113             If you're writing a script that uses a subclass of this module,
114             you can read up on the methods it provides below.
115              
116             =cut
117              
118             =head1 OPTIONS
119              
120             The following options can be passed to the new method, or set using
121             accessor methods (see below).
122              
123             Note that if you're writing a script using a subclass of this module,
124             more options may be available to the specific subclass you're
125             using.
126              
127             Options with sample values:
128            
129             friend_ids => [ 12345, 123456 ], # Arrayref of friendIDs.
130             cache_file => '/path/to/file',
131             max_count => 50, # Maximum number of successful posts before stopping
132             html => 1, # 1=display in HTML, 0=plain text.
133             delay_time => 86400, # Number of seconds to sleep on COUNTER/CAPTCHA
134             interactive => 1, # Can we ask questions? Turns on noisy also.
135             noisy => 1, # Display detailed output (1) or be quiet (0)?
136             browser => $myspace, # A valid, logged-in site browsing object (i.e. WWW::Myspace,
137             # or a subclass of WWW::Sitebase::Navigator).
138              
139             =cut
140              
141             =head2 default_options
142              
143             Override this method to allow additional options to be passed to
144             "new". You should also provide accessor methods for them.
145             These are parsed by Params::Validate. In breif, setting an
146             option to "0" means it's optional, "1" means it's required.
147             See Params::Validate for more info. It looks like this:
148              
149             sub default_options {
150            
151             $self->{default_options} = {
152             friend_ids => 0,
153             cache_file => 0,
154             html => 0,
155             browser => 0,
156             exclude_my_friends => { default => 0 },
157             interactive => { default => 1 },
158             noisy => { default => 1 },
159             max_count => { default => 0 },
160             };
161            
162             return $self->{default_options};
163             }
164              
165             # So to add a "questions" option that's mandatory:
166              
167             sub default_options {
168             super;
169             $self->{default_options}->{questions}=1;
170             return $self->{default_options};
171             }
172              
173             =cut
174              
175 0     0 1   sub default_options {
176              
177             $self->{default_options} = {
178 0           friend_ids => 0,
179             cache_file => 0,
180             html => 0,
181             browser => 0,
182             exclude_my_friends => { default => 0 },
183             interactive => { default => 1 },
184             noisy => { default => 1 },
185             max_count => { default => 0 },
186             };
187            
188 0           return $self->{default_options};
189             }
190              
191              
192             =head2 friend_ids
193              
194             Retreives/sets the list of friendIDs for whom we're going to
195             post things.
196              
197             $message->friend_ids( 12345, 12347, 123456 ); # Set the list of friends
198            
199             @friend_ids = $message->friend_ids; # Retreive the list of friends
200              
201             You can set the friend_ids to a list of friends, an arrayref to a list
202             of friends, or to an object whose "get_friends" method will return
203             the list of friends.
204              
205             When called without arguments, returns a list of friends (even if you
206             set it with an arrayref).
207              
208             =cut
209              
210 0     0 1   sub friend_ids {
211 0 0         if ( @_ ) {
212 0 0         if ( ref $_[0] ) {
213 0           $self->{friend_ids} = $_[0];
214             } else {
215 0           $self->{friend_ids} = \@_;
216             }
217             } else {
218             # If $self->{friend_ids} is set, it's either an array ref
219             # to a list of friends, or an object that we need to call
220             # "get_friends" on, which will return a list of friends.
221 0 0         if ( defined ( $self->{friend_ids} ) ) {
222 0 0         if ( ref $self->{friend_ids} eq "ARRAY" ) {
223 0           return @{ $self->{friend_ids} };
  0            
224             } else {
225 0           return $self->{friend_ids}->get_friends;
226             }
227             } else {
228 0           return ();
229             }
230             }
231             }
232              
233             =head2 cache_dir
234              
235             cache_dir sets or returns the directory in which we should store cache
236             data. Defaults to $ENV{'HOME'}/.www-poster.
237              
238             If you're subclassing this module to write a module that will use
239             WWW::Myspace, you should override this method with something like:
240              
241             sub cache_dir { $self->browser->cache_dir( @_ ) }
242              
243             This will put your module's cache data neatly into the same place as the
244             other WWW::Myspace modules' data.
245              
246             =cut
247              
248             # Get and scrub the path to their home directory.
249             our $HOME_DIR= "";
250             if ( defined $ENV{'HOME'} ) {
251             $HOME_DIR = "$ENV{'HOME'}";
252            
253             if ( $HOME_DIR =~ /^([\-A-Za-z0-9_ \/\.@\+\\:]*)$/ ) {
254             $HOME_DIR = $1;
255             } else {
256             croak "Invalid characters in $ENV{HOME}.";
257             }
258             }
259              
260             field cache_dir => catfile( "$HOME_DIR", '.www-poster' );
261              
262             =head2 cache_file
263              
264             Sets or returns the cache filename. This defaults to
265             $self->default_options->{cache_file}->{default} in cache_dir.
266             If you try to call cache_file without a value and you haven't set
267             default_options properly, it'll get really pissed off and throw nasty
268             error messages all over your screen.
269              
270             For convenience this method returns the value in all cases, so you
271             can do this:
272              
273             $cache_file = $commented->cache_file( "filename" );
274              
275             =cut
276              
277 0     0 1   sub cache_file {
278              
279 0 0         if ( @_ ) {
    0          
280 0           $self->{cache_file} = shift;
281             } elsif (! defined $self->{cache_file} ) {
282             # Make the cache directory if it doesn't exist
283 0           $self->make_cache_dir;
284 0           $self->{cache_file} = $self->default_options->{cache_file}->{default};
285             }
286              
287 0           return $self->{cache_file};
288              
289             }
290              
291             =head2 cache_path
292              
293             Returns the full path to the cache_file.
294              
295             =cut
296              
297 0     0 1   sub cache_path {
298              
299             # Make the cache directory if it doesn't exist.
300 0           $self->make_cache_dir;
301              
302 0           return catfile( $self->cache_dir, $self->cache_file );
303             }
304              
305             =head2 html( [1] [0] )
306              
307             Sets to display HTML-friendly output (only really useful with "noisy"
308             turned on also).
309              
310             Call html(1) to display HTML tags (currently just "BR" tags).
311             Call html(0) to display plain text.
312              
313             Text output (html = 0) is enabled by default.
314              
315             Example
316              
317             $comment->html( 1 );
318              
319             =cut
320              
321             field html => 0;
322              
323             =head2 browser
324              
325             Sets/retreives the site navigation object with which we're logged in.
326             You'll probably just pass that info to the new method, but the accessor is here
327             if you want to use it.
328              
329             Hint: To make your module more site-specific, add a convenience method:
330            
331             sub myspace { $self->browser( @_ ) }
332            
333             or
334            
335             sub bebo { $self->browser( @_ ) }
336              
337             =cut
338              
339             field 'browser';
340              
341             =head2 exclude_my_friends
342              
343             Sets/retrieves the value of the "exclude_my_friends" flag.
344             If set to a true value, the "post" method will exclude the logged-in
345             user's friends from the list of friendIDs set in the "friend_ids" method.
346              
347             This works by calling the "get_friends" method of the browser object. If
348             the object stored in "browser" doesn't have a "get_friends" method, the
349             "post" routine will die.
350              
351             Note that getting friends can take some time, so it's best to have your
352             friend list properly filtered instead of using this option. But, it's here
353             if you need it.
354              
355             =cut
356              
357             field 'exclude_my_friends';
358              
359             =head2 interactive
360              
361             If set to 1, allows methods to ask questions by displaying a prompt and
362             reading STDIN. Setting to 0 makes the script run non-interactively.
363             Setting to 1 automatically sets "noisy" to 1 also.
364              
365             =cut
366              
367 0     0 1   sub interactive {
368              
369 0 0         if ( @_ ) {
370 0           ( $self->{interactive} ) = @_;
371 0 0         if ( $self->{interactive} ) { $self->noisy(1) }
  0            
372             }
373            
374 0           return $self->{interactive};
375            
376             }
377              
378             =head2 noisy( [1] [0] )
379              
380             If set to 1, the module should output status reports for each post.
381             This, of course, will vary by module, and you'll probably want to
382             document any module-specific output in your module.
383              
384             If "noisy" is off (0), run silently, unless there is an error, until
385             you have to stop. Then you may print a report or status.
386              
387             noisy is off (0) by default.
388              
389             =cut
390              
391             field noisy => 0;
392              
393             =head2 max_count
394              
395             Sets or returns the number of posts we should attempt before
396             stopping. Default: 0 (don't stop).
397              
398             This is handy if you want to stop before a CAPTCHA response, or if you
399             want to limit your daily posts. Override this to set a default that's
400             appropriate for your module (i.e. 50 for a Myspace commenting module)
401              
402             =cut
403              
404             field max_count => 0;
405              
406             =head1 POSTING
407              
408             =head2 send_post
409              
410             You must override this method with your posting method. It will be
411             called by the "post" method and passed an ID from the list of friend_ids
412             (set using the option to the "new" method or using the "friend_ids" accessor method).
413             It must return two values: a result code (P, R, F, or undef) and a human-readable
414             reason string. The result codes mean "Pass", "Retry", "Fail", and "stop!" respectively,
415             and the human-readable reason will be used in the report output when the "post"
416             method stops.
417              
418             Example:
419             # Send Myspace group invitations. The send_group_invitation method returns two
420             # array references, one of passed IDs and one of failed. We want to retry any
421             # failures.
422             sub send_post {
423             my ( $id ) = @_;
424            
425             my ( $passed, $failed ) = $self->browser->send_group_invitation( $id );
426            
427             # We only passed 1 ID, so if "passed" has anything in it, our ID passed.
428             if ( @{ $passed } ) {
429             return 'P', 'Invitation Sent';
430             } else {
431             return 'R', 'Invitation send failed';
432             }
433             }
434            
435             # Post a comment on Myspace. There are several possible codes post_comment could
436             # return, so we want to decide for each whether to retry or not. Also, if we reach a
437             # CAPTCHA response, we want to stop. Note that this example assumes your
438             # subclass module defined "subject" and "message" accessors.
439             sub send_post {
440             my ( $id ) = @_;
441            
442             my $result = $self->browser->post_comment( $id, $self->subject, $self->message );
443            
444             if ( $result eq 'P' ) {
445             return 'P', 'Passed';
446             } elsif ( $result eq 'FC' ) {
447             return undef;
448             } elsif ( $result eq 'FN' ) {
449             return 'R', "Network error";
450             } elsif ( $result eq 'FF' ) {
451             return 'F', 'Person is not your friend';
452             } else {
453             return 'R', 'Failed - reason unknown';
454             }
455             }
456              
457             =cut
458              
459             stub 'send_post';
460              
461             =head2 post
462              
463             This is the main method of the module. It is called to do the actual
464             posting. It gathers the friendIDs and loops through them, calling the
465             "send_post" method to send each post. It handles logging each post,
466             and excluding previously-posted friends.
467              
468             =cut
469              
470 0     0 1   sub post {
471              
472 2     2   13 no strict 'refs';
  2         3  
  2         498  
473              
474             # Check for browser object
475 0 0         croak "Must set a valid browser object before calling post method"
476             unless ( $self->browser );
477              
478 0           $self->{post_count} = 0;
479 0           my ( $result, $reason );
480 0           my ( @friend_list ) = $self->friend_ids;
481              
482 0           ( @friend_list ) = $self->_exclude_friends( @friend_list );
483            
484 0 0         unless ( @friend_list ) { $self->_report( "Nothing to process\n" ); return; }
  0            
  0            
485              
486 0           foreach my $id ( @friend_list ) {
487 0           ( $result, $reason ) = $self->send_post( $id );
488 0 0         last unless ( $result );
489              
490 0           $self->_record_result( $id, $result, $reason );
491 0 0         $self->{post_count}++ unless ( $result eq 'R' );
492              
493 0 0 0       last if ( $self->max_count && ( $self->{post_count} > $self->max_count ) );
494             }
495              
496 0           $self->_final_report;
497              
498             }
499              
500             =head2 post_count
501              
502             Returns the current number of successful posts (from the internal
503             counter used by the "post" method.
504              
505             # Pause after every 25th post
506             sleep 30 if ( ( $self->post_count % 25 ) == 0 );
507              
508             =cut
509              
510 0     0 1   sub post_count { $self->{post_count} }
  0            
511              
512 0     0     sub _record_result {
513 0           my ( $friend_id, $result, $reason ) = @_;
514            
515 0 0         unless ( $result =~ /^[PFR]$/o ) {
516 0           croak "Invalid result code: \"$result\".\n".
517             "Valid codes are P, R, or F (Pass, Retry, or Fail).";
518             }
519              
520 0           $self->write_log( { friend_id => $friend_id, status => $result } );
521 0           $self->{reasons}->{$reason}++;
522              
523             }
524              
525 0     0     sub _final_report {
526              
527 2     2   9 no strict 'refs';
  2         2  
  2         457  
528              
529 0           print "\n\nFinal status report...\n\n######################\n";
530              
531 0           foreach my $reason ( keys( %{ $self->{reasons} } ) ) {
  0            
532 0           print $self->{reasons}->{$reason} . " " . $reason;
533             }
534            
535 0           print "\n";
536              
537             }
538              
539 0     0     sub _exclude_friends {
540 0           my ( @friend_list ) = @_;
541            
542 0           my @exclude_list = ();
543            
544             # Exclude our friends if they asked.
545 0 0         if ( $self->{'exclude_my_friends'} ) {
546 0           $self->_report("Getting friend IDs to exclude. This could take a while.\n");
547 0           push @exclude_list, $self->browser->get_friends;
548             }
549            
550             # Exclude previous posts
551 0           $self->_report( "Retreiving list of previous posts\n" );
552 0           push @exclude_list, $self->read_posted('all');
553              
554             # Process the exclusions
555 0           $self->_report( "Processing exclusions...\n" );
556 0           my $lc = List::Compare->new(
557             {
558             lists => [ \@exclude_list, \@friend_list],
559             accelerated => 1, # Only one comparison
560             unsorted => 1, # Unsorted
561             }
562             );
563              
564 0           return ( $lc->get_complement );
565              
566             }
567              
568             =head1 LOGGING METHODS
569              
570             =head2 reset_log( [ $filter ] )
571              
572             Resets the log file. If passed a subroutine reference in $filter,
573             items matching filter will be left in the log - everything else will
574             be erased.
575              
576             Say for example you wanted to retry all "Failed" items:
577              
578             $filter = sub { ( $_->{'status'} eq "P" ) };
579             $self->reset_log( $filter );
580              
581             To delete the log file completely, just do:
582              
583             $self->reset_log;
584              
585             =cut
586              
587 0     0 1   sub reset_log {
588              
589 0           my ( $filter ) = @_;
590              
591 0 0         unless ( defined $filter ) {
592 0 0         unlink $self->cache_path or croak @!;
593 0           $self->{log} = undef;
594             } else {
595             # Read in the items to save
596 0           $self->read_log( $filter );
597              
598             # Write that to the exclusions file.
599 0           $self->write_log('all');
600             }
601              
602             }
603              
604              
605             #---------------------------------------------------------------------
606              
607             =head2 write_log( 'all' | $data )
608              
609             If called with "all", write $self->{log} to the log file.
610             If called with a hash of data, append a line to the log
611             file.
612              
613             $self->write_log( 'all' );
614            
615             $self->write_log( {
616             friend_id => $friend_id,
617             status => $status
618             } );
619            
620             If there is a "time" field in the list of log_fields (there is by default),
621             write_log will automatically write the current time (the value returned by
622             the "time" function) to the file.
623              
624             =cut
625              
626             sub write_log
627 0     0 1   {
628 2     2   8 no strict 'refs';
  2         3  
  2         308  
629 0           my ( $data ) = @_;
630              
631 0           my ( $fh, $key_field, $key_value );
632             # We track who we've posted to in a file. We need to
633             # open and close it each time to make sure everyone
634             # gets stored.
635 0 0         if ( $data eq 'all' ) {
636             # Re-write the file (called by reset_exclusions).
637             # ($fh closes when it goes out of scope)
638 0 0         open( $fh, ">", $self->cache_path ) or croak @!;
639 0           foreach $key_value ( sort( keys( %{ $self->{log} } ) ) ) {
  0            
640 0           $self->$print_row( $key_value, $fh );
641             }
642             } else {
643             # Just append the current data.
644             # ($fh closes when it goes out of scope)
645 0 0         open( $fh, ">>", $self->cache_path ) or croak @!;
646            
647             # Write the data into the log hash
648 0           $key_field = $self->log_fields->[0]; # i.e. "friend_id"
649 0           $key_value = $data->{"$key_field"}; # i.e. "12345"
650            
651             # Add the time if it's not there
652 0 0         unless ( exists $data->{'time'} ) {
653 0           $data->{'time'} = time;
654             }
655             # Store the rest of the passed data into the log hash.
656 0           $self->{'log'}->{$key_value} = $data;
657            
658             # Write that row to the log file.
659 0           $self->$print_row( $key_value, $fh );
660             }
661              
662             }
663              
664             # print_row( $row_key, $fh );
665             # Print the row of data from the log hash specified by $row_key to the
666             # file identified by the filehandle reference $fh.
667              
668             my sub print_row {
669              
670 2     2   27 no strict 'refs';
  2         4  
  2         231  
671             my ( $row_key, $fh ) = @_;
672            
673             # Assemble the row
674             my $row = "";
675             foreach my $fieldname ( @{ $self->log_fields } ) {
676             ( $row ) && ( $row .= ":" );
677             $row .= $self->{log}->{$row_key}->{"$fieldname"};
678             }
679              
680             # Print to the file
681             print $fh "$row\n";
682              
683              
684             }
685              
686             =head2 log_fields
687              
688             Returns a reference to an array of the columnn names you use in your
689             log file. Defaults to friend_id, status, and time. The first field
690             will be used as your unique key field.
691              
692             Override this method if you want to use different columns in your
693             log file.
694              
695             =cut
696              
697             const 'log_fields' => [ 'friend_id', 'status', 'time' ];
698              
699              
700              
701             #----------------------------------------------------------------------
702              
703             =head2 read_log
704              
705             Read items from the log file. The first time it's invoked, it
706             reads the log file contents into $self->{log}, which is also
707             neatly maintained by write_log. This lets you call read_log
708             without worrying about huge performance losses, and also
709             makes it extendable to use SQL in the future.
710              
711             For future compatibility, you should access the log only through
712             read_log (i.e. don't access $self->{log} directly).
713              
714             # Post something unless we've successfully posted before
715             unless ( $self->read_log("$friend_id")->{'status'} =~ /^P/ ) {
716             $myspace->post_something( $friend_id )
717             }
718              
719             # When did we last post to $friend_id?
720             $last_time = $self->read_log("$friend_id")->{'time'};
721            
722             if ( $last_time ) {
723             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
724             localtime($last_time);
725             print "Successfully posted to $friend_id on: " .
726             "$mon/$day/$year at $hour:$min:sec\n";;
727             } else {
728             print "I don't remember posting to $friend_id before\n";
729             }
730              
731             read_log can be called with an optional filter argument, which can
732             be the string "all", or a reference to a subroutine that will
733             be used to filter the returned values. The subroutine will be
734             passed a hashref of fieldnames and values, by default:
735              
736             { friend_id => 12345,
737             status => P,
738             time => time in 'time' format
739             }
740              
741             This lets you do things like this:
742              
743             # Reload the cache in memory ($self->{log})
744             $self->read_log( 'all' )
745              
746             # Return a list of friends that we've already posted
747             # ("the 'o' flag means to optimize the RE because the RE is a constant).
748             my $filter = sub { if ( $_->{'status'} =~ /^[PF]$/o ) { 1 } else { 0 } }
749             @posted_friends = $self->read_log( $filter );
750            
751             # Of course, that's just for example - you'd really do this:
752             @posted_friends = $self->read_log( sub { ( $_[0]->{'status'} =~ /^[PF]$/o ) } );
753              
754             # or this, which means "return anything that doesn't need to be retried"
755             # (this is, in fact, what "read_posted" (see below) does).
756             @posted_friends = $self->read_log( sub { ( $_[0]->{'status'} ne 'R' ) } );
757              
758             Only the last post attempt for each key (friend_id by default) is stored
759             in $self->{log}. It is possible for the cache file to have more than one
760             in some circumstances, but only the last will be used, and if the file
761             is re-written, previous entries will be erased.
762              
763             =cut
764              
765 0     0 1   sub read_log {
766              
767 2     2   7 no strict 'refs';
  2         2  
  2         890  
768 0           my $filter = "";
769 0 0         ( $filter ) = @_ if ( @_ );
770            
771 0           my $status = "";
772 0           my $id;
773             my @values;
774              
775             # If we haven't read the log file yet, do it.
776 0 0 0       unless ( ( defined $self->{log} ) && ( $filter ne 'all' ) ) {
777            
778 0 0         if ( -f $self->cache_path ) {
779 0 0         open( LOGGED, "<", $self->cache_path ) or croak
780             "Can't read cache file: " . $self->cache_path . "\n";
781             } else {
782 0           $self->{log} = {};
783 0           return $self->{log};
784             }
785              
786             # There's a cache file, so read it
787 0           while ( $id = ) {
788 0           chomp $id;
789 0           ( @values ) = split( ":", $id );
790            
791             # Match the values to the appropriate fieldnames
792 0           my $i = 0;
793 0           my %data = ();
794 0           foreach my $value ( @values ) {
795 0           my $fieldname = $self->log_fields->["$i"];
796 0           $data{"$fieldname"}=$value;
797 0           $i++;
798             }
799            
800 0           $self->{'log'}->{"$values[0]"} = { %data };
801            
802             }
803            
804 0           close LOGGED;
805            
806             }
807              
808             # If we reloaded, we're done.
809 0 0         return $self->{log} if ( $filter eq 'all' );
810            
811             # If they passed a specific key value instead of a filter subroutine,
812             # return the appropriate record if it exists.
813 0 0 0       if ( ( $filter ) && ( ! ref $filter ) ) {
814 0 0         if ( exists $self->{log}->{"$filter"} ) {
815 0           return $self->{log}->{$filter}
816             } else {
817 0           return "";
818             }
819             }
820            
821             # Unless we've got a real filter, return.
822 0 0         unless ( ref $filter ) {
823 0           return $self->{log};
824             }
825            
826             # Return a list of keys that matches their filter
827 0           my @keys = ();
828 0           foreach my $key_value ( sort( keys( %{ $self->{log} } ) ) ) {
  0            
829 0 0         if ( &$filter( $self->{log}->{"$key_value"} ) ) {
830 0           push( @keys, $key_value );
831             }
832             }
833              
834 0           return ( @keys );
835              
836             }
837              
838             =head2 read_posted
839              
840             Returns the keys of all posted rows (status isn't "R").
841              
842             my @posted_friends = $self->read_posted;
843              
844             =cut
845              
846 0     0 1   sub read_posted {
847              
848 0     0     return ( $self->read_log( sub { ( $_[0]->{'status'} ne 'R' ) } ) );
  0            
849            
850             }
851              
852             =head2 previously_posted( $friend_id )
853              
854             This convenience method returns true if there's a log entry for
855             a previous successful posting. A posting is considered successful
856             if the status code is "P" or "F".
857              
858             unless ( $self->previously_posted( $friend_id ) ) {
859             $self->post( $friend_id );
860             }
861              
862             =cut
863              
864 0     0 1   sub previously_posted {
865              
866 0           return ( $self->read_log( $_[0] )->{'status'} ne 'R' );
867              
868             }
869              
870 0     0     sub _report {
871              
872 0 0         print @_ if $self->{'interactive'};
873              
874             }
875              
876             =head2 make_cache_dir
877              
878             Creates the cache directory in cache_dir. Only creates the
879             top-level directory, croaks if it can't create it.
880              
881             $myspace->cache_dir("/path/to/dir");
882             $myspace->make_cache_dir;
883              
884             This function mainly exists for the internal login method to use,
885             and for related sub-modules that store their cache files by
886             default in WWW:Myspace's cache directory.
887              
888             =cut
889              
890 0     0 1   sub make_cache_dir {
891              
892             # Make the cache directory if it doesn't exist.
893 0 0         unless ( -d $self->cache_dir ) {
894 0 0         mkdir $self->cache_dir or croak "Can't create cache directory ".
895             $self->cache_dir;
896             }
897              
898             }
899              
900             # This tells Sitebase we don't want to save the browser field.
901 0     0     sub _nosave {
902 0           my ( $key ) = shift;
903              
904 0 0 0       if ( $key && ( $key eq 'browser' ) ) { return 0 }
  0            
905 0           return 1;
906              
907             }
908              
909             =pod
910              
911             =head1 AUTHOR
912              
913             Grant Grueninger, C<< >>
914              
915             =head1 BUGS
916              
917             Please report any bugs or feature requests to
918             C, or through the web interface at
919             L.
920             I will be notified, and then you'll automatically be notified of progress on
921             your bug as I make changes.
922              
923              
924             =head1 SUPPORT
925              
926             You can find documentation for this module with the perldoc command.
927              
928             perldoc WWW::Sitebase::Poster
929              
930             You can also look for information at:
931              
932             =over 4
933              
934             =item * AnnoCPAN: Annotated CPAN documentation
935              
936             L
937              
938             =item * CPAN Ratings
939              
940             L
941              
942             =item * RT: CPAN's request tracker
943              
944             L
945              
946             =item * Search CPAN
947              
948             L
949              
950             =back
951              
952             =head1 ACKNOWLEDGEMENTS
953              
954             =head1 COPYRIGHT & LICENSE
955              
956             Copyright 2006 Grant Grueninger, all rights reserved.
957              
958             This program is free software; you can redistribute it and/or modify it
959             under the same terms as Perl itself.
960              
961             =cut
962              
963             1; # End of WWW::Sitebase::Poster