lib/Metadata/Base.pm

# Hey emacs, this is -*-perl-*- !
#
# $Id: Base.pm,v 1.10 2001/01/09 12:04:12 cmdjb Exp $
#
# Metadata::Base - base class for metadata
#
# Copyright (C) 1997-2001 Dave Beckett - http://purl.org/net/dajobe/
# All rights reserved.
#
# This module is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#

package Metadata::Base;

require 5.004;

use strict;
use vars qw($VERSION $Debug);

use Carp;

$VERSION = sprintf("%d.%02d", ('$Revision: 1.10 $ ' =~ /\$Revision:\s+(\d+)\.(\d+)/));


# Class debugging
$Debug = 0;

sub debug {
  my $self=shift;
  # Object debug - have an object reference
  if (ref ($self)) {
    my $old=$self->{DEBUG};
    $self->{DEBUG}=@_ ? shift : 1;
    return $old;
  }

  # Class debug (self is debug level)
  return $Debug if !defined $self; # Careful, could be debug(0)

  my $old=$Debug;
  $Debug=$self;
  $old;
}

sub whowasi { (caller(1))[3] }


# Constructor
sub new ($%) {
  my ($type,$self)=@_;
  $self = {} unless defined $self;

  my $class = ref($type) || $type;
  bless $self, $class;

  $self->{DEBUG}=$Debug unless defined $self->{DEBUG};

  $self->{DEFAULT_OPTIONS}={ %$self };

  # Create empty order if needed
  $self->{ORDER}=[] if $self->{ORDERED};

  $self->{ELEMENTS}={};
  $self->{ELEMENTS_COUNT}=0;

  warn "@{[&whowasi]}\n" if $self->{DEBUG};

  $self;
}


# Clone
sub clone ($) {
  my $self=shift;

  my $copy=new ref($self);

  my(@order)=$self->{ORDERED} ? @{$self->{ORDER}} : keys %{$self->{ELEMENTS}};
  for my $element (@order) {
    my(@values)=$self->get($element);
    $copy->set($element, [ @values ]);
  }

  $copy->{DEBUG}=$self->{DEBUG};
  $copy->{DEFAULT_OPTIONS}={ %{$self->{DEFAULT_OPTIONS}} };

  $copy;
}


sub set ($$$;$) {
  my $self=shift;
  return $self->_set('set',@_);
}


sub add ($$$;$) {
  my $self=shift;
  return $self->_set('add',@_);
}


sub _set ($$$$;$) {
  my $self=shift;
  my $operation=shift;

  my($element,$value,$index)=$self->validate(@_);
  return if !defined $element;

  if (!defined $self->{ELEMENTS}->{$element}) {
    # Update order
    push(@{$self->{ORDER}}, $element) if $self->{ORDERED};
    $self->{ELEMENTS_COUNT}++;
    warn "@{[&whowasi]} Adding new element $element\n" if $self->{DEBUG};
  }

  if (ref($value)) {  # Assuming eq 'ARRAY'
    $self->{ELEMENTS}->{$element}=[ @$value ];
    warn "@{[&whowasi]} Set $element to values @$value\n" if $self->{DEBUG};
  } else {
    if (defined $index) {
      # Set new value at a particular index
      $self->{ELEMENTS}->{$element}->[$index]=$value;
    } else {
      if ($operation eq 'add') {
	# Append value to end of list
	push(@{$self->{ELEMENTS}->{$element}}, $value);
	$index=@{$self->{ELEMENTS}->{$element}} - 1;
      } else {
	$index='(all)';
	$self->{ELEMENTS}->{$element}=[ $value ];
      }
    }
    warn "@{[&whowasi]} Set $element subvalue $index to value $value\n" if $self->{DEBUG};
  }
}


sub get ($$;$) {
  my $self=shift;
  my($element,$index)=@_;
  warn "@{[&whowasi]} Get $element subvalue ", (defined $index) ? $index : "(undefined)","\n" if $self->{DEBUG};
  ($element,$index)=$self->validate_elements($element,$index);
  return if !defined $element;

  warn "@{[&whowasi]} After validate, element $element subvalue ", (defined $index) ? $index : "(undefined)", "\n" if $self->{DEBUG};

  my $value=$self->{ELEMENTS}->{$element};
  return if !defined $value;

  if (defined $index) {
    return $value->[$index];
  } else {
    return wantarray ? @$value : join(' ', grep (defined $_, @$value));
  }
}


sub delete ($$;$) {
  my $self=shift;
  my($element,$index)=@_;
  warn "@{[&whowasi]} element $element subvalue ", (defined $index) ? $index : "(undefined)","\n" if $self->{DEBUG};
  ($element,$index)=$self->validate_elements($element,$index);
  return if !defined $element;

  warn "@{[&whowasi]} After validate, element $element subvalue ", (defined $index) ? $index : "(undefined)", "\n" if $self->{DEBUG};

  my $value=$self->{ELEMENTS}->{$element};
  return if !defined $value;

  my(@old)=@{$value};
  if (defined $index) {
    undef $value->[$index];
    # Are all element subvalues missing / undefined?  If so, then
    # allow code below to delete entire element.
    $index=undef if !grep (defined $_, @{$self->{ELEMENTS}->{$element}});
  }

  if (!defined $index) {
    undef @{$self->{ELEMENTS}->{$element}};
    delete $self->{ELEMENTS}->{$element};
    $self->{ELEMENTS_COUNT}--;
    if ($self->{ORDERED}) {
      @{$self->{ORDER}} = grep ($_ ne $element, @{$self->{ORDER}});
    }
  }
  return(@old);
}


sub exists ($$;$) {
  my $self=shift;
  my($element,$index)=$self->validate_elements(@_);

  return if !exists $self->{ELEMENTS}->{$element};
  return 1 if !defined $index;
  # Trying to find sub-element
  return $self->{ELEMENTS}->{$element}->[$index];
}


sub size ($;$) {
  my $self=shift;
  my $element=shift;

  return $self->{ELEMENTS_COUNT} if !defined $element;

  return if !exists $self->{ELEMENTS}->{$element};

  my $value=$self->{ELEMENTS}->{$element};
  return scalar(@$value);
}


sub elements ($) {
  my $self=shift;
  return @{$self->{ORDER}} if $self->{ORDERED};
  return keys %{$self->{ELEMENTS}};
}


# Old name
sub fields ($) {
  sub fields_warn { warn Carp::longmess @_; }
  fields_warn "Depreciated method called\n";
  return shift->elements;
}


sub order ($;@) {
  my $self=shift;
  return unless $self->{ORDERED};

  return @{$self->{ORDER}} if !@_;

  my(@old_order)=@{$self->{ORDER}} if defined wantarray;
  $self->{ORDER}=[@_];

  return @old_order if defined wantarray;
}


# Set the given element, value and index?
sub validate ($$$;$) {
  my $self=shift;
  # Not used here
  #my($self, $element, $value, $index)=@_;
  return @_;
}


# Check the legality of the given element and index
sub validate_elements ($$;$) {
  my $self=shift;
  # Not used here
  #my($self, $element, $value, $index)=@_;
  return @_;
}


# Return a native-formatted version of this metadata
sub format ($) {
  my $self=shift;
  my $string=$self->{ELEMENTS_COUNT}." elements\n";
  my(@order)=$self->{ORDERED} ? @{$self->{ORDER}} : keys %{$self->{ELEMENTS}};
  $string.="Order: @order\n" if $self->{ORDERED};
  for my $element (@order) {
    for my $value ($self->get($element)) {
      $string.="$element: $value\n";
    }
  }
  $string;
}


# Probably possible to do this using symbol table references
sub as_string ($) { shift->format; }


# Pack the metadata as small as possible - binary OK and preferred
sub pack ($) {
  my $self=shift;
  my(@order)=$self->{ORDERED} ? @{$self->{ORDER}} : keys %{$self->{ELEMENTS}};
  my $string='';
  for my $element (@order) {
    for my $value ($self->get($element)) {
      $value='' if !defined $value;
      $string.="$element\0$value\0";
    }
  }
  $string;
}


# Read the packed format and restore the same metadata state
sub unpack ($$) {
  my $self=shift;
  my $value=shift;

  return if !defined $value;

  $self->clear;
  my(@vals)=(split(/\0/,$value));
  while(@vals) {
    my($element,$value)=splice(@vals,0,2);
    $self->add($element,$value);
  }

  1;
}


sub read ($) {
  confess "Not implemented in base class\n";
}


sub write ($$) {
  my $self=shift;
  my $fd=shift;
  print $fd $self->format;
}


sub reset ($) {
  my $self=shift;

  my $default_options=$self->{DEFAULT_OPTIONS};
  while(my($attr,$value)=each %$default_options) {
    $self->{$attr}=$value;
  }

  $self->clear;
}


sub clear ($) {
  my $self=shift;

  $self->{ELEMENTS}={};
  $self->{ELEMENTS_COUNT}=0;

  # Empty order if needed
  $self->{ORDER}=[] if $self->{ORDERED};
}


sub get_date_as_seconds ($$) {
  my $self=shift;
  iso8601_to_seconds($self->get(shift));
}


sub set_date_as_seconds ($$$) {
  my $self=shift;
  my($element,$value)=shift;
  $self->set($element, seconds_to_iso8601($value));
}


sub get_date_as_iso8601 ($$) {
  my $self=shift;
  $self->get(shift);
}


sub set_date_as_iso8601 ($$$) {
  my $self=shift;
  $self->set(@_);
}


sub seconds_to_iso8601 ($) {
  my($ss,$mm,$hh,$day,$month,$year)=gmtime(shift);
  sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
	  $year+1900, $month+1,$day,$hh,$mm,$ss);
}


sub iso8601_to_seconds ($) {
  my $value=shift;
  my($year,$month,$day,$hh,$mm,$ss,$tz)= ($value =~ m{
     ^
     (\d\d\d\d) (?:                          # year YYYY required
       - (\d\d) (?:                          # month -MM optional
           - (\d\d) (?:                      # day -DD optional
               T (\d\d) : (\d\d) (?:         # time 'T'HH:MM optional
                 (?: : (\d\d (?: \.\d+)?) )? # :SS :SS.frac opt. followed by
                 (Z | (?: [+-]\d+:\d+))      # 'Z' | +/-HH:MM timezone
               )? # optional TZ/SS/SS+TZ
            )? # optional THH:MM ..
       )? # optional -DD...
     )? # optional -MM...
     $
  }x);

  return if !defined $year;

  # Round to start of year, month, etc. since it is too difficult to round
  # to the end (leap years).
  # Really it should return two values for the start & end of period
  # - maybe in V2.0
  $month ||=1; $day ||=1; $hh ||=0; $mm ||=0; $ss ||=0; $tz ||='Z';

  $tz='' if $tz eq 'Z';

  require 'Time/Local.pm';

  $value=Time::Local::timegm(int($ss),$mm,$hh,$day,$month-1,$year-1900);

  if ($tz =~ /^(.)(\d+):(\d+)$/) {
    my $s=(($2*60)+$3)*60;
    $value= ($1 eq '+') ? $value+$s : $value-$s;
  }
  if ($ss=~ /(\.\d+)$/) {
    $value.= $1; # Note string concatenation
  }
  $value;
}


1;

__END__

=head1 NAME

Metadata::Base - base class for metadata

=head1 SYNOPSIS

  package Metadata::FOO

  use vars(@ISA);
  ...
  @ISA=qw(Metadata::Base);
  ...

=head1 DESCRIPTION

Metadata:Base class - the core functionality for handling metadata.

=head1 CONSTRUCTOR

=over 4

=item new [OPTIONS]

Create a new Metadata object with an optional hash of options to describe
the metadata characteristics.  Currently only the following can be set:

=over 4

=item DEBUG

Set if debugging should be enabled from creation.  This can also be
set and read by the B<debug> method below.  If this is not defined,
it is set to the current class debugging state which can be read from
the class method L<debug> described below.

=item ORDERED

Set if the metadata elements are ordered

=back

=head1 COPY CONSTRUCTOR

=over 4

=item clone

Create a new identical Metadata object from this one.

=back

=head1 CLASS METHODS

=over 4

=item debug [VALUE]

If I<VALUE> is given, sets the debugging state of this class and
returns the old state.  Otherwise returns the current debugging
state.

=item seconds_to_iso8601 SECONDS

Convert the I<SECONDS> value to (subset of) ISO-8601 format
YYYY-MM-DDThh:mm:SSZ representing the GMT/UTC value.

=item iso8601_to_seconds VALUE

Convert 6 ISO-8601 subset formats to a seconds value.  The 6 formats
are those proposed for the Dublin Core date use:

   YYYY
   YYYY-MM
   YYYY-MM-DD
   YYYY-MM-DDThh:mm
   YYYY-MM-DDThh:mm:ssTZ
   YYYY-MM-DDThh:mm:ss.ssTZ

where TZ can be 'Z', +hh:mm or -hh:mm

B<NOTE>: This method rounds towards the start of the period (it
should really return two values for start and end).

=back

=head1 METHODS

=over 4

=item debug [VALUE]

If I<VALUE> is given, sets the debugging state of this object and
returns the old state.  Otherwise returns the current debugging
state.  The default debugging state is determined by the class debug
state.

=item set ELEMENT, VALUE, [INDEX]

Set element I<ELEMENT> to I<VALUE>.  If I<VALUE> is an array
reference, the existing array is used to as all the existing
sub-values.  Otherwise if I<INDEX> is given, sets the particular
sub-value of I<ELEMENT>, otherwise appends to the end of the existing
list of sub-values for I<ELEMENT>.

=item get ELEMENT, [INDEX]

Return the contents of the given I<ELEMENT>.  In an array context
returns the sub-values as an array, in a scalar context they are all
returned separated by spaces. If I<INDEX> is given, returns the value
of the given sub-value.

=item delete ELEMENT, [INDEX}

Delete the given I<ELEMENT>.  If an I<INDEX> is given, remove just
that sub-value.

=item exists ELEMENT, [INDEX]

Returns a defined value if the given I<ELEMENT> and/or sub-value
I<INDEX> exists.

=item size [ELEMENT]

Returns number of elements with no argument or the number of subvalues
for the given I<ELEMENT> or undef if I<ELEMENT> does not exist.

=item elements

Return a list of the elements (in the correct order if there is one).

=item order [ORDER]

If I<ORDER> is given, sets that as the order of the elements and returns
the old order list.  Otherwise, returns the current order of the
elements.  If the elements are not ordered, returns undef.

=item validate ELEMENT, VALUE, [INDEX]

This method is intended to be overriden by subclasses.  It is called
when a element value is being set.  The method should return either a
list of I<ELEMENT>, I<VALUE> and I<INDEX> values to use or an undefined value
in which case no element will be set.

=item validate_elements ELEMENT, [INDEX]

This method is intended to be overriden by subclasses.  It is called
when a element and/or index is being read.  The method should return
a list of I<ELEMENT> and I<INDEX> values to use.

=item as_string
=item format

Returns a string representing the metadata, suitable for storing (in
a text file).  This is different from the B<pack> method because this
value is meant to be the native encoding format of the metadata,
usually human readable, wheras B<pack> uses the minimum space.

=item pack

Return a packed string representing the metadata format.  This can be
used with B<unpack> to restore the values.

=item unpack VALUE

Initialise the metadata from the packed I<VALUE> which must be the
value made by the B<pack> method.

=item read HANDLE

Reads from the given file handle and initialises the metadata elements.
Returns undef if end of file is seen.

=item write HANDLE

Write to the given file handle a formatted version of this metadata
format.  Likely to use B<format> in most implementations.

=item reset

Reset the metadata object to the default ones (including any passed
with the constructor) and then do a I<clear>.

=item clear

Remove any stored elements in this metadata object.  This can be used
in conjuction with I<read> to prevent the overhead of many I<new>
operations when reading metadata objects from files.

=item get_date_as_seconds ELEMENT

Assuming I<ELEMENT> is stored in a date format, returns the number of
seconds since 1st January 1970.

=item set_date_as_seconds ELEMENT, VALUE

Set I<ELEMENT> encoded as a date corresponding to I<VALUE> which is the
number of seconds since 1st January 1970.

=back

=head1 AUTHOR

By Dave Beckett - http://purl.org/net/dajobe/

=head1 COPYRIGHT

Copyright (C) 1997-2001 Dave Beckett - http://purl.org/net/dajobe/
All rights reserved.

This module is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut