File Coverage

blib/lib/OpenInteract2/Observer/UsePerlPost.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package OpenInteract2::Observer::UsePerlPost;

# $Id: UsePerlPost.pm,v 1.9 2005/01/17 00:06:59 cwinters Exp $

use strict;
use Log::Log4perl            qw( get_logger );
use Net::Blogger;
use OpenInteract2::Constants qw( :log );
use OpenInteract2::Context   qw( CTX DEPLOY_URL );

$OpenInteract2::Observer::UsePerlPost::VERSION  = '0.05';

my $DEFAULT_PROXY = 'http://use.perl.org/journal.pl';
my $DEFAULT_URI   = 'http://use.perl.org/Slash/Journal/SOAP';

my @REQUIRED_FIELDS = qw(
    use_perl_subject use_perl_content
    use_perl_user_id use_perl_password
);

my ( $log );

sub update {
    my ( $class, $action, $type, $object ) = @_;
    return unless ( $type eq 'post add' );

    my $request = CTX->request;

    my $do_skip = $action->param( 'use_perl_skip' );
    unless ( $do_skip ) {
        if ( $request ) {
            $do_skip = $request->param( 'use_perl_skip' );
        }
    }
    return if ( $do_skip eq 'yes' );

    $log ||= get_logger( LOG_APP );

    my $subject_field = $action->param( 'use_perl_subject' );
    my $content_field = $action->param( 'use_perl_content' );
    my $user_id       = $action->param( 'use_perl_user_id' );
    my $password      = $action->param( 'use_perl_password' );

    my $action_name = $action->name;
    my $error_preamble = "Cannot post use.perl journal from action '$action_name'!";
    unless ( $subject_field and $content_field and $user_id and $password ) {
        $log->error(
            "$error_preamble You must define the following parameters in ",
            "your action: ", join( ', ', @REQUIRED_FIELDS ), ". You can ",
            "do so in the configuration file or in the action code itself."
        );
        return;
    }

    my $subject = $object->$subject_field();
    my $content = $object->$content_field();
    unless ( $subject and $content ) {
        $log->error(
            "$error_preamble No subject found from method '$subject_field' ",
            "or no content found from method '$content_field'; not creating ",
            "journal entry."
        );
        return;
    }

    if ( my $footer = $action->param( 'use_perl_footer' ) ) {
        $content .= "\n\n" . $class->_generate_footer( $object, $footer );
    }

    my $blogger = Net::Blogger->new(
        engine => 'slash',
        debug  => $log->is_debug,
    );

    my $use_perl_proxy = $action->param( 'use_perl_proxy' )
                         || $DEFAULT_PROXY;
    my $use_perl_uri   = $action->param( 'use_perl_uri' )
                         || $DEFAULT_URI;

    # Before we send the content we want to get rid of any HTML that
    # use.perl might not like. (This could be better done...)

    # First create 'ecode' sections...

    $content =~ s|]+>||g;
    $content =~ s|||g;

    # ...then remove all img tags and replace them with links to the
    # image and a note about what you're seeing

    my @image_tags = $content =~ /(]+>)/gsm;
    foreach my $img_tag ( @image_tags ) {
        my ( $src ) = $img_tag =~ /src="([^"]+)"/sm;
        my ( $alt ) = $img_tag =~ /alt="([^"]+)"/sm;
        unless ( $alt ) {
            my $base_src = '';
            if ( $alt =~ m|/| ) {
                ( $base_src ) = $src =~ m|.*/(.*)$|;
            }
            else {
                $base_src = $src;
            }
            $alt = $base_src;
        }
        $content =~ s|$img_tag|(view image: $alt)|sm;
    }

    my $debug_only = $action->param( 'use_perl_debug' );
    if ( $debug_only =~ /^(yes|true)/i ) {
        $log->warn( "Not sending data to use.perl server since ",
                    "'use_perl_debug' is set." );
        $log->warn( "Proxy: $use_perl_proxy" );
        $log->warn( "Uri: $use_perl_uri" );
        $log->warn( "Username: $user_id" );
        my $masked = join( '', map { 'X' } ( 1 .. length $password ) );
        $log->warn( "Password: $masked (masked)" );
        $log->warn( "Subject:\n$subject" );
        $log->warn( "Body:\n$content" );
    }
    else {
        $blogger->Proxy( $use_perl_proxy );
        $blogger->Uri( $use_perl_uri );
        $blogger->Username( $user_id );
        $blogger->Password( $password );
        my $post_id = $blogger->slash()->add_entry(
            subject => $subject,
            body    => $content,
        );
        $log->is_info &&
            $log->info( "Result from adding entry '$subject': $post_id" );
    }
}

sub _generate_footer {
    my ( $class, $object, $footer ) = @_;
    if ( $footer =~ /\$LINK/ || $footer =~ /\$ID/ ) {
        my ( $object_info, $object_url, $object_id );
        eval {
            $object_info = $object->object_description;
            $object_url  = $object_info->{url};
            $object_id   = $object_info->{object_id};
        };

        # last-ditch to define the ID
        eval {
            $object_id ||= $object->id
        };

        if ( $object_url ) {
            my $request = CTX->request;
            my $host    = ( $request )
                            ? $request->server_name
                            : CTX->server_config->{server_host};
            if ( $host ) {
                my $server_url = "http://$host" . DEPLOY_URL;
                $footer =~ s/\$LINK/$server_url$object_url/g;
            }
            else {
                $log->warn( "Cannot generate footer: no server host found. ",
                            "Please define server configuration key ",
                            "'Global.server_host' so I know what hostname to use." );
                return '';
            }
        }
        if ( $object_id ) {
            $footer =~ s/\$ID/$object_id/g;
        }
    }
    $log->is_info && $log->info( "Adding footer: $footer" );
    return $footer;
}

1;

__END__