File Coverage

blib/lib/Metadata/SOIF.pm

Criterion	Covered	Total	%
statement	76	99	76.7
branch	24	42	57.1
condition	3	10	30.0
subroutine	11	14	78.5
pod	9	10	90.0
total	123	175	70.2

# Hey emacs, this is -*-perl-*- !
#
# $Id: SOIF.pm,v 1.10 2001/01/09 12:04:12 cmdjb Exp $
#
# Metadata::SOIF - Harvest Structured Objects Interchange Format class
#
# 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::SOIF;

require 5.004;

use strict;
use vars qw(@ISA $VERSION $Debug %Default_Options);

use Carp;

use Metadata::Base;

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

%Default_Options=(
  TEMPLATE_TYPE => 'FILE',
  URL => '',
  SPLIT => '0',
  DEBUG => '0',
);


# 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;
    $self->SUPER::debug($self->{DEBUG});
    return $old;
  }

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

  my $old=$Debug;
  $Default_Options{DEBUG}=$Debug=$self;
  Metadata::Base::debug($Debug);
  $old;
}

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


# Constructor
sub new {
  my $proto =shift;
  my $class = ref($proto) || $proto;
  my $options= { @_ };
  $options->{ORDERED}=1;
  for (keys %Default_Options) {
    $options->{$_}=$Default_Options{$_} unless defined $options->{$_};
  }

  my $self = $class->SUPER::new($options);
  bless $self, $class;
  return $self;
}


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

  my $copy = $self->SUPER::clone;

  $copy->{TEMPLATE_TYPE}= $self->{TEMPLATE_TYPE};
  $copy->{URL}= $self->{URL};

  $copy;
}


sub template_type ($;$) {
  my $self=shift;
  return $self->{TEMPLATE_TYPE} if !@_;

  my $old=$self->{TEMPLATE_TYPE};
  $self->{TEMPLATE_TYPE}=shift;
  $old;
}


sub url ($;$) {
  my $self=shift;
  return $self->{URL} if !@_;

  my $old=$self->{URL};
  $self->{URL}=shift;
  $old;
}


sub read ($$;$) {
  my $self = shift;
  my $fh=shift;

  $self->clear;

  return undef if eof($fh);

  my $seen_url=0;
  $self->url(shift) and $seen_url=1 if @_;

  my $count=0;
  while(<$fh>) {
    warn "@{[&whowasi]}: Read line: '$_'\n" if $self->{DEBUG};
    if (/^\}/) {
      last;
    } elsif (my($template_type,$url)=/^\@\s*(\S+)\s*\{\s*(\S+)\s*$/o) {
      warn "@{[&whowasi]}: Read Template Type '$template_type' URL '$url'\n" if $self->{DEBUG};
      $self->template_type($template_type);
      $self->url($url) and $seen_url=1 unless $seen_url;
    } elsif (my($element,$rest_length,$value)=/^\s*([^{]+)\{(\d+)\}:\t(.*)$/so) {
      my $value_length=length($value)-1;  # -1 off for for NL, removed below
      $value_length=0 if $value_length<0; # however handle 0 length value
      $rest_length-= $value_length;
      if ($rest_length>0) {
	$value_length++; # Append after newline
        my $read_length=read($fh,$value,$rest_length, $value_length);
        croak "Cannot read $rest_length bytes (read $read_length) - $!\n"
	  if $read_length != $rest_length;
      }
      chomp $value; # extra newline removed here
      # Split values on newlines into sub-values, maybe
      my(@v);
      if ($self->{SPLIT} && ((@v)=split(/\n/, $value)) > 1) {
        $self->set($element, \@v);
      } else {
        $self->set($element, $value);
      }
      $count++;
    } else {
      warn "@{[&whowasi]}:$.: Do not understand line '$_'\n";
    }
  }

  warn "@{[&whowasi]}: Read $count elements\n" if $self->{DEBUG};
  return 1;
}


sub format ($;$) {
  my $self=shift;
  $self->url(shift) if @_;

  my $url=$self->url;
  my $string="\@$self->{TEMPLATE_TYPE} {";
  $string.= $url ? " $url\n" : "\n";
  for my $element ($self->order) {
    my $value=join("\n",grep (defined $_, $self->get($element) ));
    $string.="$element\{".length($value)."\}:\t".$value."\n";
  }
  return $string."}\n";
}


# Pack Template Type and URL too
sub pack ($) {
  my $self=shift;
  my $string=$self->SUPER::pack;

  # Use the knowledge that Metadata::Base uses 'thing\0' for fields
  return join("\001", $self->{TEMPLATE_TYPE}, $self->{URL}, $string);
}


sub unpack ($$) {
  my $self=shift;
  my($tt,$url,$string)=split(/\001/, shift);
  $self->SUPER::unpack($string);
  $self->{TEMPLATE_TYPE}=$tt;
  $self->{URL}=$url;
}


1;
__END__