File Coverage

blib/lib/WWW/UsePerl/Journal/Comment.pm

Criterion	Covered	Total	%
statement	74	81	91.3
branch	22	30	73.3
condition			n/a
subroutine	14	15	93.3
pod	2	2	100.0
total	112	128	87.5

package WWW::UsePerl::Journal::Comment;

use strict;
use warnings;

use vars qw($VERSION $AUTOLOAD);
$VERSION = '0.14';

#----------------------------------------------------------------------------

=head1 NAME

WWW::UsePerl::Journal::Comment - Handles the retrieval of UsePerl journal entry comments.

=head1 SYNOPSIS

  my $comment = WWW::UsePerl::Journal::Comment->new(
      # required
      j       => $journal,
      cid     => $commentid,
      eid     => $entryid,
      extract => $extract
  );

  $comment->subject();

  # called from WWW::UsePerl::Journal::Thread object
  $thread->comment( $cid )->content();

=head1 DESCRIPTION

A collection of routines to handle the retrieval of comments from a
UsePerl (L) journal entry.

=cut

# -------------------------------------
# Library Modules

use base qw(Class::Accessor::Fast);

use HTTP::Request::Common;
use LWP::UserAgent;
use Time::Piece;
use WWW::UsePerl::Journal;

# -------------------------------------
# Constants & Variables

use constant USEPERL => 'http://use.perl.org/use.perl.org';
use overload q{""}  => sub { $_[0]->stringify() };

my %months = (
	'January'   => 1,
	'February'  => 2,
	'March'     => 3,
	'April'     => 4,
	'May'       => 5,
	'June'      => 6,
	'July'      => 7,
	'August'    => 8,
	'September' => 9,
	'October'   => 10,
	'November'  => 11,
	'December'  => 12,
);

# -------------------------------------
# Public Interface

=head1 PUBLIC INTERFACE

=head2 The Constructor

=over 4

=item new

Each comment is retrieved as an object. Note that the parent object
(from WWW::UsePerl::Journal), thread id and comment id are mandatory
requirements to create the object.

=back

=cut

sub new {
    my ($class,%opts) = @_;

    for(qw/j eid cid extract/) {
    	return	unless(exists $opts{$_});
    }

    die "No parent object"
	    unless $opts{j}->isa('WWW::UsePerl::Journal');

    my %atts = map {$_ => $opts{$_}} qw(j eid cid extract);
    my $self = bless \%atts, $class;

    $self->_get_content();

    return $self;
}

#----------------------------------------------------------------------------
# Accessors

=head2 The Accessors

The following accessor methods are available:

  id
  date
  subject
  user
  uid
  score
  content

All functions can be called to return the current value of the associated
object variable.

=cut

__PACKAGE__->mk_accessors($_) for qw(cid date subject user uid score content);

=head2 Methods

=over 4

=item stringify - For String Context

When an object is called directly, stringification occurs. Safer to
use -Econtent instead.

=back

=cut

sub stringify {
    my $self = shift;
    return $self->content();
}

# -------------------------------------
# The Private Subs

# name:	_get_content
# args:	self .... object itself
# retv: content text
# desc: Retrieves the content and additional information for a given
#       comment. Splits the fields into object variables and returns
#       the content text

sub _get_content {
    my $self    = shift;

    my $content = $self->{extract};

    if($self->{j}->debug) {
        $self->{j}->log('mess' => "\n#_get_content: content=[$content]\n");
    }

    return $self->{j}->error("Error getting entry") unless $content;

    # remember there are different presentations for dates!!!!

	my ($string,$format);
	$content =~ s/\n//g;
	my @fields = ( $content =~ m!
               # comment id
    .*?     ]+>([^<]+)                         # subject
    .*?
    .*?     Score:(\d+).*?                             # score
	.*?		\s*(\w+)         # username
	.*?		\((\d+)\)						            # userid
            (?:\s+
	.*?		    on\s+(\d+\.\d+.\d+\s\d+:\d+)  		        # date/time - "2003.05.20 17:31" or "Friday August 08 2003, @01:51PM"
    .*?     )?
    .*?     (.*?)         # text
        !mixs );

    ($self->{pid}) = $content =~ m/id="commtree_(\d+)"/;

    if($self->{j}->debug) {
        $self->{j}->log('mess' => "\n#_get_content: fields=[".(join("][",map {$_||''} @fields))."]\n");
    }

    return  unless(@fields);

    if($fields[5]) {
        my ($year, $month, $day, $hr, $mi) = $fields[5] =~ m! (\d+)\.(\d+)\.(\d+) .*? (\d+):(\d+) !smx;
        unless($day) {
            my $amp;
            ($month, $day, $year, $hr, $mi, $amp) = $fields[5] =~ m! \w+\s+ (\w+) \s+(\d+)\s*(\d*), \s+ @(\d+):(\d+)([AP]M) !smx;
            $month = $months{$month};
            $year = (localtime)[5]  unless($year);	# current year formatting drops the year.
            $hr += 12 if ($amp eq 'PM');
            $hr = 0 if $hr == 24;
        }

        if($self->{j}->debug) {
            $self->{j}->log('mess' => "\n#_get_content: date=[$year $month $day ${hr}:$mi]\n");
        }

        # sometimes Time::Piece can't parse the date :(
        eval {
            $self->{date} = Time::Piece->strptime(
                "$month $day $year ${hr}:$mi",
                '%m %d %Y %H:%M'
            );
        };

        if($self->{j}->debug) {
            $self->{j}->log('mess' => "\n#_get_content: date=[".$self->{date}."]\n");
        }
    }

	$self->{subject}	= $fields[1];
	$self->{score}		= $fields[2];
	$self->{user}		= $fields[3];
	$self->{uid}		= $fields[4];
	$self->{content}	= $fields[6];

	return  unless($self->{content});				# What no content!

	$self->{content} =~ s!(\s+<(?:p|br /)>)*$!!gi;	# remove trailing whitespace formatting
	$self->{content} =~ s!\s+(<(p|br /)>)!$1!gi;	# remove whitespace before whitespace formatting
	$self->{content} =~ s!(<(p|br /)>){2,}!!gi;	# remove repeated whitespace formatting

    return;
}

sub DESTROY {}

1;

__END__