File Coverage

blib/lib/LCC.pm

Criterion	Covered	Total	%
statement	47	209	22.4
branch	8	108	7.4
condition	0	50	0.0
subroutine	13	30	43.3
pod	15	16	93.7
total	83	413	20.1

package LCC;

# Make sure we do everything by the book
# Set modules to inherit from
# Set version information

use strict;
@LCC::ISA = qw();
$LCC::VERSION = '0.02';

# Use the internal modules that we always need

use LCC::Documents ();
use LCC::Backend ();
use LCC::UNS ();

# Use the external modules that we always need

use IO::File ();
use IO::Socket ();

# Make sure that a true value is returned from -use-

1;

#-------------------------------------------------------------------------

# Following subroutines are for instantiating objects

#-------------------------------------------------------------------------

#  IN: 1 reference to hash with method value pairs
# OUT: 1 instantiated LCC object

sub new {

# Find out what class we need to be blessing
# If we're not trying to make a LCC object
#  Warn the user it shouldn't be done and return

  my $class = shift;
  if ($class ne 'LCC') {
    warn "Can only call 'new' on LCC itself\n";
    return;
  }

# Create the object and bless the object
# Set any parameters if they are specified
# Save version information in the object
# Return something that we can work with

  my $self = bless {},$class;
  $self->Set( shift ) if $_[0];
  $self->_variable( qw(version 1.0) );
  return $self;
} #new

#-------------------------------------------------------------------------

# Create the Backend to be used (only once during lifetime of LCC object)
#  IN: 1 instantiated LCC object
#      2 (optional) type of backend (e.g. 'Storable' or 'DBI')
#      3 source specification (filename for Storable, $dbh for DBI)
#      4 (optional) ref to hash with parameters
# OUT: 1 instantiated LCC::Backend::xxx object

# or:

# Obtain existing Backend object
#  IN: 1 instantiated LCC object
# OUT: 1 instantiated LCC::Backend::xxx object

sub Backend {

# Obtain the object
# If we already have a Backend object
#  Add error if we're trying to create a new one
#  Return the existing Backend object

  my $self = shift;
  if (exists $self->{'Backend'}) {
    $self->_add_error( "Can only create Backend once" ) if @_;
    return $self->{'Backend'};
  }

# Obtain the type of backend
# If it is not a known type of backend
#  Move the type back into the parameters (it needs to be deduced)

  my $type = shift;
  unless ($type =~ m#^(?:DBI|Storable|textfile)$#) {
    unshift( @_,$type );

#  If we have an object of some kind
#   If it is a DBI database handle
#    Set to use DBI
#   Else (unknown type of object)
#    Reset type (will cause error later)

    if (my $ref = ref($type)) {
      if ($ref eq 'DBI::db') {
        $type = 'DBI';
      } else {
        $type = '';
      }

#  Else (not an object)
#   If Storable is available
#    Assume user wants Storable
#   Else
#    Assume user wants plain textfiles

    } else {
      if (defined($Storable::VERSION)) {
        $type = 'Storable';
      } else {
        $type = 'textfile';
      }
    }
  }

# Add error if we don't have a type by now
# Return the result of the object creation, saving it in the LCC on the fly

  $self->_add_error( "Unable to determine type of Backend" ) unless $type;
  return $self->{'Backend'} = "LCC::Backend::$type"->_new( $self,@_ );
} #Backend

#-------------------------------------------------------------------------

# Create a new set of documents to be checked
#  IN: 1 instantiated LCC object
#      2 (optional) storage type documents
#        allowed are: DBI, filesystem, module and queue
#      3 (optional) source specification (depending on type of storage)
#      4 (optional) ref to hash with parameters
# OUT: 1 instantiated LCC::Documents::xxx object

sub Documents {

# Obtain the object
# Obtain the storage type of documents
# If it is not a known type of storage
#  Move the type back into the parameters (it needs to be deduced)

  my $self = shift;
  my $type = shift || '';
  unless ($type =~ m#^(?:DBI|filesystem|module|queue)$#) {
    unshift( @_,$type );

#  If we have an object of some kind
#   If it is a DBI database handle
#    Set to use DBI
#   Elseif it is a queue object
#    Set to use queue
#   Else (unknown type of object)
#    Set type to module
#  Else (not an object)
#   Assume wants documents stored on filesystem

    if (my $ref = ref($type)) {
      if ($ref eq 'DBI::db') {
        $type = 'DBI';
      } elsif ($ref eq 'threads::shared::queue') {
        $type = 'queue';
      } else {
        $type = 'module';
      }
    } else {
      $type = 'filesystem';
    }
  }

# Add error if we don't have a type by now
# Save the result of the object creation
# Return the last object created

  $self->_add_error( "Unable to determine storage type of Documents" )
   unless $type;
  push( @{$self->{'Documents'}},"LCC::Documents::$type"->_new( $self,@_ ) );
  return $self->{'Documents'}->[-1];
} #Documents

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object
#      2 server:port specification
# OUT: 1 instantiated LCC::UNS object

sub UNS { $_[0]->{'UNS'} ||= 'LCC::UNS'->_new( @_ ) } #UNS

#-------------------------------------------------------------------------

# Inheritable methods

#-------------------------------------------------------------------------

# OUT: 1..N errors accumulated so far and removed from object if in list context

sub Errors {

# Obtain the object
# Create the name of the field
# Initialize the list of errors

  my $self = shift;
  my $name = ref($self).'::Errors';
  my @error;

# If there are errors
#  Obtain them
#  Delete them from the object if we're returning the content of the errors
# Return whatever we found

  if (exists $self->{$name}) {
    @error = @{$self->{$name}};
    delete( $self->{$name} ) if wantarray;
  }
  return @error;
} #Errors

#-------------------------------------------------------------------------

#  IN: 1..N names of methods to apply to object
# OUT: 1..N values returned by the methods

sub Get {

# Obtain the object
# Initialize the list of values
# Allow for non-strict references

  my $self = shift;
  my @value;
  no strict 'refs';

# If were supposed to return something
#  For all of the methods specified
#   Execute the method and return its value
#  Return the list of values

  if (defined(wantarray)) {
    foreach my $method (@_) {
      push( @value,scalar($self->$method()) );
    }
    return @value;
  }

# Obtain the namespace of the caller
# For all of the methods specified
#  Call the method and put the result in the caller's namespace

  my $namespace = caller().'::';
  foreach my $method (@_) {
    ${$namespace.$method} = $self->$method();
  }
} #Get

#-------------------------------------------------------------------------

#  IN: 1 new setting for PrintError (default: no change)
# OUT: 1 current/old setting for PrintError

sub PrintError {

# Obtain the object
# Return now if just returning

  my $self = shift;
  return $self->_variable( 'PrintError' ) unless @_;

# Obtain the value
# If it is 'cluck'
#  Load the 'Carp' module
#  Set the reference to the cluck routine if Carp is available
# Handle as normal setting from here on

  my $value = shift;
  if ($value eq 'cluck') {
    eval( 'use Carp ();' );
    $SIG{__WARN__} = \&Carp::cluck if defined(&Carp::cluck);
  }
  return $self->_variable( 'PrintError',$value,@_ );
} #PrintError

#-------------------------------------------------------------------------

#  IN: 1 new setting for RaiseError (default: no change)
# OUT: 1 current/old setting for RaiseError

sub RaiseError {

# Obtain the object
# Return now if just returning

  my $self = shift;
  return $self->_variable( 'RaiseError' ) unless @_;

# Obtain the value
# If it is 'confess'
#  Load the 'Carp' module
#  Set the reference to the confess routine if Carp is available
# Handle as normal setting from here on

  my $value = shift;
  if ($value eq 'confess') {
    eval( 'use Carp ();' );
    $SIG{__DIE__} = \&Carp::confess if defined(&Carp::confess);
  }
  return $self->_variable( 'RaiseError',$value,@_ );
} #RaiseError

#-------------------------------------------------------------------------

#  IN: 1 reference to a hash or list with values keyed to method names

sub Set {

# Obtain the object
# Obtain the reference
# Obtain the type of reference
# Allow for non-strict references

  my $self = shift;
  my $ref = shift;
  my $type = ref($ref);
  no strict 'refs';

# If we have a hash reference
#  For all of the methods specified
#   Execute the method with the given parameters

  if ($type eq 'HASH') {
    foreach my $method (keys %{$ref}) {
      $self->$method( ref($ref->{$method}) eq 'ARRAY' ?
       @{$ref->{$method}} : $ref->{$method} );
    }

# Elseif we have a list reference
#  While there are methods to be handled
#   Obtain the parameters
#   Execute the method with the given parameters

  } elsif ($type eq 'ARRAY') {
    while (my $method = shift( @{$ref} )) {
      my $parameters = shift( @{$ref} );
      $self->$method( ref($parameters) eq 'ARRAY' ?
       @{$parameters} : $parameters );
    }

# Else (we don't know what to do with it)
#  Add error

  } else {
   $self->_add_error( "Cannot handle value of type '$type'" );
  }
} #Set

#-------------------------------------------------------------------------

# Methods for the LCC object only

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object
# OUT: 1..N ID's of new/changed documents (# of documents in scalar context)

sub check {

# Obtain the object
# Add error if there is no Backend
# Obtain local copy of backend
# Add error if unclear what kind of update must be done
# Add error if there are no Documents to check

  my $self = shift;
  $self->_add_error( "Must have a Backend first before checking" )
   unless exists( $self->{'Backend'} );
  my $backend = $self->{'Backend'};
  $self->_add_error( "Unclear whether 'complete' or 'partial' update" )
   unless exists( $backend->{'old'} );
  $self->_add_error( "No Documents to be checked" )
   unless exists( $self->{'Documents'} ) and @{$self->{'Documents'}};

# Obtain local copy of list of documents
# Obtain local copy of old ID's
# Obtain local copy of new ID's
# Obtain local copy of URL information
# Create a reference to an empty subroutine doing nothing

  my $documents = $self->{'Documents'} || [];
  my $old = $backend->{'old'};
  my $new = $backend->{'new'} ||= {};
  my $url = $backend->{'url'} ||= {};

# Obtain ordinal of first Documents to check
# Obtain ordinal if the Documents after the last one now
# Loop for all the documents that we need to do now
#  Create local copy of Documents object for this iteration

  my $first = $self->{'_next_documents'} || 0;
  my $next = $self->{'_next_documents'} = @{$documents};
  for (my $i = $first; $i < $next; $i++) {
    my $thistime = $documents->[$i];

#  Obtain the browse URL code reference
#  Obtain the conceptual URL code reference
#  Obtain the fetch URL code reference

    my $burl = $thistime->browse_url || $thistime->_browse_url;
    my $curl = $thistime->conceptual_url || $thistime->_conceptual_url;
    my $furl = $thistime->fetch_url || $thistime->_fetch_url;

#  While there are document to be fetched
#   Create the string for the list
#   Reloop if there was no change

    while (my ($id,@list) = $thistime->next_document) {
      my $list = join( "\0",@list );
      next if $list eq $old->{$id};

#   Add error if we did this one already and reloop
#   Add this document to the list to be done
#   Add URL information for this document ID

      $self->_add_error( "Document with ID '$id' was already added" ), next
       if exists( $new->{$id} );
      $new->{$id} = $list;
      $url->{$id} = {
       burl => $burl->( $id ),
       curl => $curl->( $id ),
       furl => $furl->( $id ),
      };
    }
  }

# Return indicating how many new documents there are now

  return keys %{$backend->{'new'}};
} #check

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object

sub complete { shift->_backend_method( 'complete',@_ ) } #complete

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object
#      2 (optional) flag to force partial document set

sub partial { shift->_backend_method( 'partial',@_ ) } #partial

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object

sub update { shift->_backend_method( 'update',@_ ) } #update

#-------------------------------------------------------------------------

#  IN: 1 instantiated object
#      2 reference to hash with provider credentials (id and password)
#      3 handle to write XML to or reference to list of handles to write to
#        (default: just return the resulting XML)
# OUT: 1 resulting XML

sub update_notification_xml {

# Obtain the object
# Obtain the credentials
# Obtain the handles to write to
# Initialize the XML

  my $self = shift;
  my $credentials = shift;
  my @handle = ref($_[0]) eq 'ARRAY' ? @{(shift)} : shift;

# Create a local copy to the backend
# Create the type of set we're working with

  my $backend = $self->{'Backend'};
  my $set = keys %{$backend->{'old'}} ? 'partial' : 'complete';

# Start the XML
# Send it to the handles (if appropriate)

  my $xml = <





EOD
  print $_ $xml foreach @handle;

# Create local copy of list of new documents
# Create local copy of URL info of new documents
# While there are documents to be processed
#  Obtain the constituent parts
#  Initialize the line for this document

  my $new = $backend->{'new'} || {};
  my $url = $backend->{'url'} || {};
  while (my ($id,$value) = each %{$new}) {
    my ($mtime,$length,$md5,$mimetype,$subtype) = split( m#\0#,$value );
    my $line = "

#  If there is URL info (there should be, really)
#   Foreach of the special fields
#    Reloop if no specific info
#    Add field to this documents XML

    if (my $urlid = $url->{$id} || '') {
      foreach (qw(curl burl furl)) {
        next unless $urlid->{$_} || '';
        $line .= qq( $_="$urlid->{$_}");
      }
    }

#  Add the constituent parts if applicable

    $line .= qq( mtime="$mtime") if $mtime || '';
    $line .= qq( len="$length") if $length || '';
    $line .= qq( md5="$md5") if $md5 || '';
    $line .= qq( mimetype="$mimetype") if $mimetype || '';
    $line .= qq( subtype="$subtype") if $subtype || '';

#  Finish off this line
#  Print the line to each appropriate handle
#  Add the line to the XML

    $line .= "/>\n";
    print $_ $line foreach @handle;
    $xml .= $line;
  }

# Create the finish up XML
# Send it to the handles (if appropriate)
# Return the final XML if appropriate

  my $last = <


EOD
  print $_ $last foreach @handle;
  return $xml.$last if defined( wantarray );
} #update_notification_xml

#-------------------------------------------------------------------------

#  IN: 1 instantiated LCC object
# OUT: 1 current setting for version of LCC

sub version { shift->_variable( 'version' ) } #version

#-------------------------------------------------------------------------

# Following subroutines are for internal use only

#-------------------------------------------------------------------------

#  IN: 1 instantiated object
#      2 name of method to execute on Backend
#      3..N parameters to be passed

sub _backend_method {

# Obtain object
# Add error if we don't have a backend yet
# Obtain the method name
# Perform the complete method on the Backend object

  my $self = shift;
  $self->_add_error( "Must have a Backend first" )
   unless exists( $self->{'Backend'} );
  my $method = shift;
  $self->{'Backend'}->$method( @_ );
} #_backend_method

#------------------------------------------------------------------------

#  IN: 1 class to create object in
#      2 LCC object
#      3 reference to hash with method/value pairs
# OUT: 1 instantiated LCC::xxxxx object

sub _new {

# Create an empty object and bless it
# Inherit anything that needs to be inherited
# Set any fields that are specified
# Return the object

  my $self = bless {},shift;
  $self->_inherit( shift );
  $self->Set( shift ) if $_[0];
  return $self;
} #_new

#-------------------------------------------------------------------------

#  IN: 1 instantiated object
#      2 object to inherit from
# OUT: 1 object itself

sub _inherit {

# Obtain the objects to work on

  my ($self,$parent) = @_;

# For names of all of the fields that we need to copy
#  Copy the value

  foreach (qw(
   PrintError
   RaiseError
    )) {
    $self->{$_} ||= $parent->{$_} if exists $parent->{$_};
  }
  return $self;
} #_inherit

#-------------------------------------------------------------------------

#  IN: 1 error message to add
# OUT: 1 object itself (for handy oneliners)

sub _add_error {

# Obtain the object
# Save whatever was specified as an error
# Save the error on the list
# Show the warning if we're supposed to

  my $self = shift;
  my $message = shift;
  push( @{$self->{ref($self).'::Errors'}},$message );
  warn "$message\n" if $self->{'PrintError'} || '';

# If we're to die on errors
#  If it is a code reference
#   Execute it, passing the message as a parameter
#  Else
#   Eval what we had as a value
#  Die now if we hadn't died already

  if (my $action = $self->{'RaiseError'} || '') {
    if (ref($action) eq 'CODE') {
      &{$action}( $message );
    } else {
      eval( $action );
    }
    die "$message\n";
  }

# Return the object again

  return $self;
} #_add_error

#-------------------------------------------------------------------------

#  IN: 1 server:port or port specification
#      2..N any other parameters to IO::Socket::INET
# OUT: 1 socket (undef if error)

sub _socket {

# Obtain the object
# Obtain the server:port specification
# Set the default host if only a port number specified

  my $self = shift;
  my $serverport = shift;
  $serverport = "localhost:$serverport" if $serverport =~ m#^\d+$#;

# Attempt to open a socket there
# Set error if failed
# Return whatever we got

  my $socket = IO::Socket::INET->new( $serverport,@_ );
  $self->_add_error( "Error connecting to socket: $@" )
   unless $socket;
  return $socket;
} #_socket

#-------------------------------------------------------------------------

# The following methods are for setting and obtaining values

#-------------------------------------------------------------------------

#  IN: 1 name of field in hash
#      2 new value (default: no change)
# OUT: 1 current/old value

sub _variable {

# Obtain the parameters
# Obtain the current value
# Set the new value if there is a new value specified
# Return the current/old value

  my ($self,$name) = @_;
  my $value = $self->{$name};
  $self->{$name} = $_[2] if @_ > 2;
  return $value;
} #_variable

#-------------------------------------------------------------------------

# subroutines for standard Perl features

#-------------------------------------------------------------------------

# Debugging tools

#-------------------------------------------------------------------------

#  IN: 1..N variables to be dumped also, apart from object itself
# OUT: 1 Dumper output (if Data::Dumper available)

sub Dump {

# Obtain the object
# Attempt to get the Data::Dumper module if not availabl already
# If the module is available
#  Return the result of the dump if we're expecting something
#  Output the result the dump as a warning (in void context)

  my $self = shift;
  eval 'use Data::Dumper ();' unless defined( $Data::Dumper::VERSION );
  if (defined( $Data::Dumper::VERSION )) {
    return Data::Dumper->Dump( [$self,@_] ) if defined( wantarray );
    warn Data::Dumper->Dump( [$self,@_] );
  }
}

#-------------------------------------------------------------------------

__END__