File Coverage

blib/lib/Net/Amazon/MechanicalTurk/BaseObject.pm

Criterion	Covered	Total	%
statement	69	120	57.5
branch	10	40	25.0
condition	3	24	12.5
subroutine	17	22	77.2
pod	0	11	0.0
total	99	217	45.6

package Net::Amazon::MechanicalTurk::BaseObject;
use strict;
use warnings;
use Carp;
use IO::File;

our $VERSION = '1.00';

use constant USE_QUALIFIED_ATTRIBUTE_NAMES => 1;

our %CLASS_DEBUG;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->init(@_);
    return $self;
}

sub init {}

sub DESTROY {}

sub assertRequiredAttributes {
    my $self = shift;
    foreach my $attr (@_) {
        if (!defined($self->$attr)) {
            Carp::croak("Required attribute ${attr} was not set.");
        }
    }
}

sub setAttributesIfNotDefined {
    my $self = shift;
    my %attrs = ($#_ == 0) ? %{$_[0]} : @_;
    while (my ($attr,$value) = each %attrs) {
        eval { $self->$attr($value) unless defined($self->$attr); };
        if ($@) { Carp::croak("Can't set attribute $attr - $@"); }
    }
}

sub setAttributes {
    my $self = shift;
    my %attrs = ($#_ == 0) ? %{$_[0]} : @_;
    while (my ($attr,$value) = each %attrs) {
        eval { $self->$attr($value); };
        if ($@) { Carp::croak("Can't set attribute $attr - $@"); }
    }
}

sub trySetAttributes {
    my $self = shift;
    my %attrs = ($#_ == 0) ? %{$_[0]} : @_;
    my %unsetAttrs;
    while (my ($attr,$value) = each %attrs) {
        if (UNIVERSAL::can($self, $attr)) {
            eval {
                $self->$attr($value);
            };
            if ($@) {
                Carp::carp("Couldn't set attribute $attr - $@");
                $unsetAttrs{$attr} = $value;
            }
        }
        else {
            $unsetAttrs{$attr} = $value;
        }
    }
    return \%unsetAttrs;
}

sub attributes {
    my $self = shift;
    foreach my $attr (@_) {
        $self->attribute($attr);
    }
}

sub methodAlias {
    my $self = shift;
    my %aliases = @_;
    my $class = ref($self) || $self;
    while (my ($alias,$existing) = each %aliases) {
        my $sub = UNIVERSAL::can($class, $existing);
        if (!$sub) {
            Carp::croak("Method $existing does not exist.");
        }
        no strict 'refs';
        no warnings;
        *{"${class}::${alias}"} = $sub;
    }
}

sub attribute {
    my $self = shift;
    my $attr = shift;
    my $attr_name = shift || $attr;

    my $class = ref($self) || $self;

    if (USE_QUALIFIED_ATTRIBUTE_NAMES) {
        $attr_name = "${class}::${attr_name}";
    }

    no strict 'refs';
    no warnings;
    # Create a subroutine for an attribute getter/setter
    *{"${class}::${attr}"} = sub {
        my $_self = shift;
        if ($#_ == 0) {
            $_self->{$attr_name} = $_[0];
        }
        return $_self->{$attr_name};
    };
}

sub debug {
    my $self = shift;
    my $class = ref($self) || $self;
    if ($#_ >= 0) {
        my $debug = shift;
        if (UNIVERSAL::isa($debug, "CODE") or
            UNIVERSAL::isa($debug, "GLOB") or
            UNIVERSAL::can($debug, "debugMessage"))
        {
            $CLASS_DEBUG{$class} = $debug;
        }
        elsif ($debug =~ /^STDERR$/i or $debug =~ /^(1|yes|true)$/i) {
            $CLASS_DEBUG{$class} = \*STDERR;
        }
        elsif ($debug =~ /^STDOUT$/i) {
            $CLASS_DEBUG{$class} = \*STDOUT;
        }
        elsif ($debug and $debug !~ /^(0|no|false)$/i) { # true value indicating file
            $CLASS_DEBUG{$class} = IO::File->new($debug, "a");
            if (!$CLASS_DEBUG{$class}) {
                print "Setting debug on $class to STDERR\n";
                # Couldn't open so go to STDERR.
                $CLASS_DEBUG{$class} = \*STDERR;
            }
            else {
                $CLASS_DEBUG{$class}->autoflush(1);
            }
        }
        else {
            delete $CLASS_DEBUG{$class};
        }
    }
    return $CLASS_DEBUG{$class};
}

sub debugMessage {
    my $self = shift;
    my $debug = $self->debug;

    if (!defined($debug)) {
        return;
    }

    my @stack = caller(1);
    my @time = localtime(time());

    my $prefix = sprintf("[%04d-%02d-%02d %02d:%02d:%02d] %s >> ",
        $time[5] + 1900,
        $time[4] + 1,
        $time[3],
        $time[2],
        $time[1],
        $time[0],
        $stack[3]
    );

    my @messages = split(/\n/, join(" ", @_));
    if (UNIVERSAL::isa($debug, "GLOB")) {
        foreach my $msg (@messages) {
            print $debug $prefix.$msg."\n";
        }
    }
    elsif (UNIVERSAL::isa($debug, "CODE")) {
        foreach my $msg (@messages) {
            $debug->($prefix.$msg."\n");
        }
    }
    else {
        foreach my $msg (@messages) {
            $debug->debugMessage($prefix.$msg."\n");
        }
    }
}

return 1;