File Coverage

blib/lib/Metadata/Base.pm

Criterion	Covered	Total	%
statement	139	214	64.9
branch	59	110	53.6
condition	13	15	86.6
subroutine	21	34	61.7
pod	24	30	80.0
total	256	403	63.5

# 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__