File Coverage

blib/lib/Apache/Sling/Print.pm

Criterion	Covered	Total	%
statement	68	70	97.1
branch	20	30	66.6
condition			n/a
subroutine	14	14	100.0
pod	5	6	83.3
total	107	120	89.1

#!/usr/bin/perl -w

package Apache::Sling::Print;

use 5.008001;
use strict;
use warnings;
use Carp;
use Fcntl ':flock';
use File::Temp;

require Exporter;

use base qw(Exporter);

our @EXPORT_OK = ();

our $VERSION = '0.27';

#{{{sub print_with_lock

sub print_with_lock {
    my ( $message, $file ) = @_;
    if ( defined $file ) {
        return print_file_lock( "$message", $file );
    }
    else {
        return print_lock("$message");
    }
}

#}}}

#{{{sub print_file_lock

sub print_file_lock {
    my ( $message, $file ) = @_;
    if ( open my $out, '>>', $file ) {
        flock $out, LOCK_EX or croak q{Unable to obtain exclusive lock};
        print {$out} $message . "\n" or croak q{Problem printing!};
        flock $out, LOCK_UN or croak q{Problem releasing exclusive lock};
        close $out or croak q{Problem closing!};
    }
    else {
        croak "Could not open file: $file";
    }
    return 1;
}

#}}}

#{{{sub print_lock

sub print_lock {
    my ($message) = @_;
    my ( $tmp_print_file_handle, $tmp_print_file_name ) =
      File::Temp::tempfile();
    if ( open my $lock, '>>', $tmp_print_file_name ) {
        flock $lock, LOCK_EX or croak q{Unable to obtain exclusive lock};
        print $message . "\n" or croak q{Problem printing!};
        flock $lock, LOCK_UN or croak q{Problem releasing exclusive lock};
        close $lock or croak q{Problem closing!};
        unlink($tmp_print_file_name);
    }
    else {
        croak q(Could not open lock on temporary file!);
    }
    return 1;
}

#}}}

#{{{sub print_result

sub print_result {
    my ($object) = @_;
    my $message = $object->{'Message'};
    if ( $object->{'Verbose'} >= 1 ) {
        $message .= "\n**** Status line was: ";
        $message .= ${ $object->{'Response'} }->status_line;
        if ( $object->{'Verbose'} >= 3 ) {
            $message .= "\n**** Full Content of Response was: \n";
            $message .= ${ $object->{'Response'} }->content;
        }
    }
    print_with_lock( $message, $object->{'Log'} );
    return 1;
}

#}}}

#{{{sub date_string

sub date_string {
    my ( $day_of_week, $month, $year_offset, $day_of_month, $hour, $minute,
        $sec )
      = @_;
    my @months    = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my @week_days = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
    if ( $sec    =~ /^[0-9]$/msx ) { $sec    = "0$sec"; }
    if ( $minute =~ /^[0-9]$/msx ) { $minute = "0$minute"; }
    my $year = 1900 + $year_offset;
    return
"$week_days[$day_of_week] $months[$month] $day_of_month $hour:$minute:$sec";
}

#}}}

#{{{sub date_time

sub date_time {
    (
        my $sec,
        my $minute,
        my $hour,
        my $day_of_month,
        my $month,
        my $year_offset,
        my $day_of_week,
        my $day_of_year,
        my $daylight_savings
    ) = localtime;
    return date_string( $day_of_week, $month, $year_offset, $day_of_month,
        $hour, $minute, $sec );
}

#}}}

1;

__END__