—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—
—

              
#
# File: lib/Devel/Ladybug/Object.pm
#
# Copyright (c) 2009 TiVo Inc.
#
# All rights reserved. This program and the accompanying materials
# are made available under the terms of the Common Public License v1.0
# which accompanies this distribution, and is available at
# http://opensource.org/licenses/cpl1.0.txt
#
package Devel::Ladybug::Object;
HideShow 22 lines of Pod
=pod
=head1 NAME
Devel::Ladybug::Object - Abstract object class
=head1 DESCRIPTION
Base abstract object class for the Devel::Ladybug framework. Extends
L<Devel::Ladybug::Class> with a constructor, getters, and setters.
=head1 INHERITANCE
This class inherits additional class and object methods from the
following packages:
L<Devel::Ladybug::Class> > Devel::Ladybug::Object
=head1 PUBLIC CLASS METHODS
=cut
use strict;
use warnings;
use Clone qw| clone |;
use Error qw| :try |;
use Devel::Ladybug::Type;
use Devel::Ladybug::Enum::Bool;
use Devel::Ladybug::Exceptions;
use Devel::Ladybug::Persistence::MySQL;
use Devel::Ladybug::Persistence::SQLite;
use Devel::Ladybug::Persistence::PostgreSQL;
use base qw| Devel::Ladybug::Class |;
our $AUTOLOAD;
our @EXPORT;
HideShow 49 lines of Pod
=pod
=over 4
=item * $class->new()
Returns a new object instance. Optionally accepts a hash or hash ref
for use as a prototype object.
  #
  # File: Example.pm
  #
  # Implement a concrete class based on Devel::Ladybug::Object:
  #
  use Devel::Ladybug::Class;
  create "YourApp::Example" => {
    __BASE__ => "Devel::Ladybug::Object"
  };
Meanwhile, in caller:
  #!/bin/env perl
  #
  # File: somecaller.pl
  #
  # New empty object:
  #
  my $obj = YourApp::Example->new();
  #
  # New object from an even list:
  #
  my $objFromList = YourApp::Example->new(
    foo => "whiskey",
    bar => "tango"
  );
  #
  # New object from HASH ref:
  #
  my $objFromRef = YourApp::Example->new( {
    foo => "whiskey",
    bar => "tango"
  } );
=cut
sub new {
  my $class = shift;
  my @args  = @_;
  my $hash;
  if ( @args == 0 ) {
    #
    # No arguments provided, so start with an empty hash
    #
    $hash = {};
  } elsif ( @args == 1 ) {
    #
    # Single argument was provided:
    #
    if ( ref $args[0] ) {
      #
      # Single reference arg provided, which should walk like a HASH:
      #
      $hash = shift @args;
      throw Devel::Ladybug::InvalidArgument(
        "In $class->new(...), arg was not HASH-like")
        if !UNIVERSAL::isa( $hash, "HASH" );
    } else {
      #
      # Garbage in?
      #
      my $caller = caller();
      throw Devel::Ladybug::InvalidArgument( "BUG (Check $caller): "
          . "In $class->new(...), args should be hash, hashref, or nothing"
      );
    }
  } else {
    #
    # Unreferenced list received; make a HASHREF from it:
    #
    my %hash = @args;
    $hash = \%hash;
  }
  #
  #
  #
  my $assertions = $class->get('ASSERTS');
  if ($assertions) {
    #
    # We'll make a clean, new self and assign it later:
    #
    my $sanitized = bless {}, $class;
    #
    # Class assertions were provided;
    # use provided value, or fall back to default
    #
    for my $key ( keys %{$assertions} ) {
      my $type = $assertions->{$key};
      my $value = $hash->{$key};
      #
      # if optional() was specified and there's no value,
      # populate sanitized hash with undef and move on:
      #
      if ( !defined $value && $type->optional() ) {
        $sanitized->set( $key, undef );
        next;
      }
      #
      # If these tests are failing in the constructor, the caller
      # probably did not send the proper (or any args).
      #
      my $keyLabel = join( "::", $class, $key );
      if ( defined $value ) {
        $type->test( $keyLabel, $value );
        $sanitized->set( $key, ref($value) ? clone($value) : $value );
      } else {
        #
        # fall back to default
        #
        my $default = $type->default();
        #
        # test the default value, because it might be invalid on purpose
        # (that is, callers of this class might need to provide an
        # allowed value for this attribute in the constructor)
        #
        $type->test( $keyLabel, $default );
        $sanitized->set( $key,
          ref($default) ? clone($default) : $default );
      }
    }
    #
    # Perl reference magic
    #
    $hash = $sanitized;
  } else {
    bless $hash, $class;
  }
  $hash->_init();
  return $hash;
}
HideShow 10 lines of Pod
=pod
=item * $class->proto()
Constructor method. Returns a new instance of self, populated with
default values. The returned object may contain undefined values which
must be populated before calling C<save()>.
=cut
sub proto {
  my $class = shift;
  my $self = bless {}, $class;
  my $asserts = $class->asserts();
  for my $attr ( $class->attributes() ) {
    my $type = $asserts->{$attr};
    my $default = $type->default();
    next if !defined($default);
    eval { $self->set( $attr, $default ); };
    ###
    ### This works, but ended up being really spammy in the logs.
    ### Changed to just eval instead, above.
    ###
    # try {
    # $self->set($attr, $default);
    # } catch Devel::Ladybug::AssertFailed with {
    # my $error = $_[0];
    # warn "Prototype warning (possibly harmless): $error";
    # };
  }
  return $self;
}
HideShow 11 lines of Pod
=pod
=item * $class->attributes()
Returns a flat list of allowed attributes, if any, for objects of this
class. Includes any attribute names in C<__baseAsserts()>.
  my @keys = $class->attributes();
=cut
sub attributes {
  my $class = shift;
  if ( $class->class() ) {
    $class = $class->class();
  }
  return sort keys %{ $class->asserts() };
}
HideShow 45 lines of Pod
=pod
=item * $class->isAttributeAllowed($key)
Returns true if the received key is a valid attribute for instances of
the current class, otherwise warns to STDERR and returns false.
  #
  # File: Example.pm
  #
  # Create a new class with two attrs, "foo" and "bar"
  #
  my $class = "YourApp::Example";
  create $class => {
    foo => Devel::Ladybug::Str->assert(),
    bar => Devel::Ladybug::Int->assert(),
    # ...
  };
Meanwhile, in caller...
  #!/bin/env perl
  #
  # File: somecaller.pl
  #
  # Check for allowed attributes:
  #
  for ( qw| foo bar rebar | ) {
    next if !$class->isAttributeAllowed($_);
    # ...
  }
  #
  # Expected output is warning text to the effect of:
  #
  # BUG IN CALLER: "rebar" is not a member of class "YourApp::Example"
  #
=cut
sub isAttributeAllowed {
  my $class = shift;
  my $key   = shift;
  my $asserts = $class->asserts();
  if ( keys %{$asserts} ) {
    if ( exists $asserts->{$key} ) {
      return true;
    } else {
      my ($caller,$pkg,$line) = caller();
      warn
        "BUG (Check $caller:$line): \"$key\" is not a member of \"$class\"";
      return false;
    }
  } else {
    return true;
  }
}
HideShow 12 lines of Pod
=pod
=item * $class->asserts()
Abstract method, implemented by subclasses to returns an
Devel::Ladybug::Hash of assertion objects, including any base
assertions which may be present.
  my $asserts = $class->asserts();
=cut
sub asserts {
  my $class = shift;
  throw Devel::Ladybug::ClassIsAbstract(
    "Abstract class $class will never have assertions");
}
HideShow 71 lines of Pod
=pod
=item * $class->assert()
Abstract method, implemented by subclasses to return an assertion
object.
Returns a pre-made Devel::Ladybug::Type object with subtypes for the
named datatype. See "Concrete Classes" in L<Devel::Ladybug> for a list
of types which may be asserted.
  create "YourApp::Example" => {
    someStr     => Devel::Ladybug::Str->assert(
      ::optional(),
      ::default("Foo Bar!")
    ),
    someInt     => Devel::Ladybug::Int->assert( ::optional() ),
    someFloat   => Devel::Ladybug::Float->assert( ::optional() ),
    someDouble  => Devel::Ladybug::Double->assert( ::optional() ),
    someBool    => Devel::Ladybug::Bool->assert( ::default(false) ),
    # ...
  };
To enforce a range of allowed values, use the desired values as
arguments:
  create "YourApp::Example" => {
    foo => Devel::Ladybug::Str->assert(qw| alpha bravo cthulhu |);
    ...
  };
If the range of allowed values should be looked up from some external
source at runtime (rather than load time), provide an anonymous
function (Perl C<sub{}> block or C<CODE> ref).
This lets the range of allowed values change through the lifetime of
the application process, based on whatever the function returns (as
opposed to using a static list, which is loaded at "use" time and
doesn't adapt to changing data.)
The function provided should return an array ref of allowed values.
 ...
  create "YourApp::Example" => {
    #
    # Always check against a live datasource:
    #
    someId => Devel::Ladybug::Str->assert( sub { YourApp::Example->allIds() } ),
    ...
  };
Instance variables containing complex data structures, objects, or
pointers to external objects follow the same basic form as simple
assertions.
The values for L<Devel::Ladybug::Array> and L<Devel::Ladybug::Hash>
attributes are stored in linked tables, which Devel::Ladybug creates
and manages.
L<Devel::Ladybug::ExtID>, which is a simple pointer to an external
object, is generally a more maintainable approach than inline
L<Devel::Ladybug::Array> and L<Devel::Ladybug::Hash> elements, and also
provides the best performance.
=cut
sub assert {
  my $class = shift;
  my @rules = @_;
  throw Devel::Ladybug::ClassIsAbstract(
    "You may not assert attributes for abstract class $class");
}
HideShow 17 lines of Pod
=pod
=back
=head1 PRIVATE CLASS METHODS
=head2 Class Callback Methods
=over 4
=item * $class->import()
Callback method invoked when callers C<use> this package. Provides
caller with Types and Bools.
=cut
sub import {
  my $class = shift;
  my @what  = @_;
  my $caller = caller();
  #
  # deep magics
  #
  # install the bare "assert" keyword inside of caller
  #
  eval qq/
    package $caller;
    use Devel::Ladybug::Type;
    use Devel::Ladybug::Enum::Bool;
  /;
  my $asserts = $class->get("ASSERTS");
  return if !$asserts;
  for my $key ( keys %{$asserts} ) {
    my $type = $asserts->{$key};
    next
      if !ref($type)
        || ( !UNIVERSAL::isa( $type, 'HASH' )
          && !UNIVERSAL::isa( $type, 'ARRAY' ) );
    # ref($type->{$key}) !~ /Hash|Array/i;
    $class->__elementClass($key);
  }
}
HideShow 67 lines of Pod
=pod
=item * $class->__baseAsserts()
Abstract method.
Asserts are not inherited by subclasses, unless defined in the hash
returned by this method. Override in subclass to provide a hash of
inherited assertions.
Unless implementing a new abstract class that uses special keys,
__baseAsserts() does not need to be used or modified. Concrete classes
should just use inline assertions as per the examples in
L<Devel::Ladybug::Type>.
C<__baseAsserts()> may be overridden as a C<sub{}> or as a class
variable.
Using a C<sub{}> lets you extend the parent class's base asserts, or
use any other Perl operation to derive the appropriate values:
  create "YourApp::Example" => {
    #
    # Inherit parent class's base asserts, tack on "foo"
    #
    __baseAsserts => sub {
      my $class = shift;
      my $base = $class->SUPER::__baseAsserts();
      $base->{foo} = Devel::Ladybug::Str->assert();
      return $base;
    },
    # ...
  };
One may alternately use a class variable to redefine base asserts,
overriding the parent:
  create "YourApp::Example" => {
    #
    # Statically assert two base attributes, "id" and "name"
    #
    __baseAsserts => {
      id   => Devel::Ladybug::Int->assert(),
      name => Devel::Ladybug::Str->assert()
    },
    # ...
  }
To inherit no base assertions:
  create "Devel::Ladybug::RebelExample" => {
    #
    # Sometimes, parent doesn't know best:
    #
    __baseAsserts => { },
    # ...
  }
=cut
sub __baseAsserts {
  my $class = shift;
  throw Devel::Ladybug::ClassIsAbstract(
    "Abstract class $class has no base asserts");
}
sub __assertClass {
  my $class = shift;
  my $assertClass = $class->get("__assertClass");
  if ( !defined $assertClass ) {
    $assertClass = $class;
    $assertClass =~ s/.*\:\:/Devel::Ladybug::Type::/;
    #
    # Dynamically allocate a Type subclass
    #
    do {
      no strict "refs";
      @{"$assertClass\::ISA"} = qw| Devel::Ladybug::Type |;
    };
    $class->set( "__assertClass", $assertClass );
    $assertClass->set( "objectClass", $class );
  }
  return $assertClass;
}
sub __elementClass {
  my $class = shift;
  my $key   = shift;
  #
  # Fine for abstract method
  #
  return undef;
}
HideShow 17 lines of Pod
=pod
=back
=head1 PUBLIC INSTANCE METHODS
=over 4
=item * $self->get($key)
Get the received instance variable. Very strict about input
enforcement.
If using assertions, Devel::Ladybug *DIES* if the key is invalid!
=cut
sub get {
  my $self = shift;
  my $key  = shift;
  my $class = $self->class();
  if ($class) {
    if ( !$class->isAttributeAllowed($key) ) {
      my ($caller,$pkg,$line) = caller();
      Devel::Ladybug::RuntimeError->throw(
        "BUG (Check $caller:$line): $self does not answer to $key"
      );
    }
    return $self->{$key};
  } else {
    return $self->SUPER::get($key);
  }
}
HideShow 12 lines of Pod
=pod
=item * $self->set($key, $value)
Set the received instance variable. Very strict about input
enforcement.
If using assertions, Devel::Ladybug *DIES* on purpose here if key or
value are invalid.
=cut
sub set {
  my $self  = shift;
  my $key   = shift;
  my @value = @_;
  my $class = $self->class();
  if ($class) {
    throw Devel::Ladybug::RuntimeError("Extra args received by set()")
      if scalar(@value) > 1;
    throw Devel::Ladybug::RuntimeError("$key is not a member of $class")
      if !$class->isAttributeAllowed($key);
    my $type = $class->asserts()->{$key};
    throw Devel::Ladybug::AssertFailed("Type for $key failed")
      if $type && !$type->test( $key, $value[0] );
    $self->{$key} = $value[0];
  } else {
    return $self->SUPER::set( $key, @value );
  }
  return true;
}
HideShow 21 lines of Pod
=pod
=item * $self->clear()
Removes all items, leaving self with zero elements.
  my $object = YourApp::Example->new(
    foo => "uno",
    bar => "dos"
  );
  print $object->count(); # 2
  print "\n";
  $object->clear();
  print $object->count(); # 0
  print "\n";
=cut
sub clear {
  my $self = shift;
  %{$self} = ();
  return $self;
}
HideShow 8 lines of Pod
=pod
=item * $self->class()
Object wrapper for Perl's built-in ref() function
=cut
sub class {
  my $self = shift;
  return ref($self);
}
HideShow 8 lines of Pod
=pod
=item * $self->value()
Returns self's value as a native data type, ie dereferences it
=cut
sub value {
  my $self = shift;
  return %{$self};
}
HideShow 39 lines of Pod
=pod
=back
=head2 AUTOLOADED
=over 4
=item * $self->set<Attribute>($value)
AUTOLOADed setter method. Set the attribute named in the message to the
received value. Does lcfirst on the attribute name.
Performs value checking and sanitizing (a good reason to use the
setter!)
  $self->setFoo("bario")
=item * $self-><Attribute>()
AUTOLOADed getter method. Returns the value for the received attribute.
  $self->setFoo("bario");
  my $value = $self->foo(); # returns "bario"
=item * $self->delete<Attribute>()
AUTOLOADed key deletion method. Removes the named attribute from the
working object. Performs lcfirst on the attribute named in the message.
  $self->setFoo("bario");
  $self->foo(); # returns "bario";
  $self->deleteFoo();
  $self->foo(); # returns undef
=cut
sub AUTOLOAD {
  my $self = shift;
  my @args = @_;
  my $message = $AUTOLOAD;
  $message =~ s/.*:://;
  return if $message eq 'DESTROY';
  my $class = $self->class();
  do {
    my $receiver = $class;
    if ( !$receiver ) { $receiver = $self }
    if ( $receiver->can("__useDbi") && $receiver->__useDbi ) {
      my $delegate;
      if ( $receiver->__useDbi == 1 ) {
        $delegate = "Devel::Ladybug::Persistence::MySQL";
      } elsif ( $receiver->__useDbi == 2 ) {
        $delegate = "Devel::Ladybug::Persistence::SQLite";
      } elsif ( $receiver->__useDbi == 3 ) {
        $delegate = "Devel::Ladybug::Persistence::PostgreSQL";
      }
      if ( !defined( *{"$delegate\::$message"} ) ) {
        $delegate = "Devel::Ladybug::Persistence::Generic";
      }
      if ( $delegate->can($message) ) {
        do {
          no strict "refs";
          my $results = &{"$delegate\::$message"}( $self, @_ );
          return $results;
        };
      }
    }
  };
  if ( !$class ) {
    $class = $self;
    my $value = $class->get($message);
    if ( !defined $value ) {
      my ( $package, $filename, $line ) = caller;
      throw Devel::Ladybug::RuntimeError(
"BUG (Check $package:$line): Class var \@$class\::$message is undefined"
      );
    }
    return $value;
  }
  if ( $message =~ /^[Ss]et(\w+)/ ) {
    my $attributeName = lcfirst($1);
    #
    # set() will perform attribute tests
    #
    if ( scalar( @args > 1 ) ) {
      return $self->set( $attributeName, \@args );
    } else {
      return $self->set( $attributeName, $args[0] );
    }
  } elsif ( $message =~ /^[Dd]elete(\w+)/ ) {
    my $attributeName = lcfirst($1);
    return if !$class->isAttributeAllowed($attributeName);
    return delete $self->{$attributeName};
  } elsif ( $message =~ /^[Gg]et(\w+)/ ) {
    my $attributeName = lcfirst($1);
    #
    # get() will perform attribute tests
    #
    return $self->get($attributeName);
  } else {
    return $self->get($message);
  }
}
HideShow 17 lines of Pod
=pod
=back
=head1 PRIVATE INSTANCE METHODS
=over 4
=item * $self->_init();
Abstract callback method invoked after object creation (called from
new()).
Override in subclass to handle additional logic if needed.
=cut
sub _init {
  my $self = shift;
  return true;
}
HideShow 10 lines of Pod
=pod
=back
=head1 SEE ALSO
This file is part of L<Devel::Ladybug>.
=cut
true;