File Coverage

blib/lib/Log/Dispatch/Atom.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

# @(#) $Id: Atom.pm 1102 2005-12-07 14:33:19Z dom $

package Log::Dispatch::Atom;

$VERSION = 0.03;

use warnings;
use strict;

use Carp qw( carp croak );
use Fcntl qw( :flock );
use POSIX qw( strftime );
use Params::Validate qw( validate SCALAR HASHREF );
use Sys::Hostname qw( hostname );
use XML::Atom 0.15;    # We need add_entry(mode=>insert).
use XML::Atom::Entry;
use XML::Atom::Feed;
use XML::Atom::Person;

use base qw( Log::Dispatch::Output );

# We don't want complaints about this; classes below will check the
# remaining args.
Params::Validate::validation_options( allow_extra => 1 );

sub new {
    my $class = shift;
    my %p     = @_;

    my $self = bless {}, $class;
    # Log::Dispatch setup.
    $self->_basic_init( %p );
    # Our setup.
    $self->_init( %p );
    return $self;
}

sub _init {
    my $self = shift;
    my %p    = validate(
        @_,
        {
            file        => { type => SCALAR },
            feed_id     => { type => SCALAR, optional => 1 },
            feed_title  => { type => SCALAR, optional => 1 },
            feed_author => { type => HASHREF, optional => 1 },
        }
    );
    $self->{ file }        = $p{ file };
    $self->{ feed_id }     = $p{ feed_id } if $p{ feed_id };
    $self->{ feed_title }  = $p{ feed_title } if $p{ feed_title };
    $self->{ feed_author } = $p{ feed_author } if $p{ feed_author };
    return;
}

sub _now_datetime { strftime "%Y-%m-%dT%H:%M:%SZ", gmtime }
sub _now_date     { strftime "%Y-%m-%d", gmtime }

sub log_message {
    my $self = shift;
    my %p    = validate(
        @_,
        {
            id     => { type => SCALAR,  default  => $self->_default_id },
            author => { type => HASHREF, optional => 1 },
        }
    );
    my $fh = eval {
        my $fh   = $self->_lock_and_open();
        my $feed = $self->_get_feed_from_handle( $fh );
        $self->_new_entry( $feed, \%p );
        $self->_write_feed( $fh, $feed );
        return $fh;
    };

    # Take care to avoid clobbering $@.
    my $err = $@;
    eval { $self->_unlock_and_close( $fh ) };
    die $err if $err;
    return;
}

{
    my $i;
    sub _default_id {
        my $self = shift;
        return sprintf( "tag:%s,%s:%d/%d/%d",
            hostname(), $self->_now_date(), time(), $$, ++$i );
    }
}

sub _get_feed_from_handle {
    my $self = shift;
    my ( $fh ) = @_;

    my $size = ( stat( $fh ) )[7];
    if ( $size > 0 ) {
        return XML::Atom::Feed->new( $fh );
    }
    else {
        return $self->_new_feed();
    }
}

sub _new_feed {
    my $self = shift;
    my $feed = XML::Atom::Feed->new( Version => '1.0' );
    $feed->id( $self->{ feed_id } )       if $self->{ feed_id };
    $feed->title( $self->{ feed_title } ) if $self->{ feed_title };
    if ( my $author = $self->{ feed_author } ) {
        $feed->author( $self->_new_person( $author ) );
    }
    return $feed;
}

sub _new_person {
    my $self     = shift;
    my ( $args ) = @_;
    my $person   = XML::Atom::Person->new( Version => '1.0' );
    $person->name( $args->{ name } )   if $args->{ name };
    $person->email( $args->{ email } ) if $args->{ email };
    $person->uri( $args->{ uri } )     if $args->{ uri };
    return $person;
}

sub _new_entry {
    my $self = shift;
    my ( $feed, $args ) = @_;
    my $entry = XML::Atom::Entry->new( Version => '1.0' );
    $entry->title( "$args->{message}" );
    $entry->content( "$args->{message}" );
    $entry->id( "$args->{id}" );

    my $now = _now_datetime();
    $feed->updated( $now );
    $entry->updated( $now );

    if ( $args->{ author } ) {
        $entry->author( $self->_new_person( $args->{ author } ) );
    }

    $feed->add_entry( $entry, { mode => 'insert' } );
    return $entry;
}

sub _write_feed {
    my $self = shift;
    my ( $fh, $feed ) = @_;

    seek $fh, 0, 0;
    print $fh $feed->as_xml();
    return;
}

sub _lock_and_open {
    my $self = shift;
    open my $fh, '+<', $self->{ file }
        or croak "open($self->{file}): $!";
    flock( $fh, LOCK_EX )
        or croak "flock($self->{file}): $!";
    return $fh;
}

sub _unlock_and_close {
    my $self = shift;
    my ( $fh ) = @_;
    return unless $fh;

    flock( $fh, LOCK_UN )
        or carp "unlock($self->{file}): $!";
    close( $fh )
        or carp "close($self->{file}): $!";
    return;
}

1;
__END__