File Coverage

blib/lib/Metadata/IAFA.pm

Criterion	Covered	Total	%
statement	73	141	51.7
branch	24	80	30.0
condition	4	15	26.6
subroutine	11	19	57.8
pod	14	15	93.3
total	126	270	46.6

# Hey emacs, this is -*-perl-*- !
#
# $Source: /home/cmdjb/develop/perl/Metadata/lib/Metadata/RCS/IAFA.pm,v $
#
# $Id: IAFA.pm,v 1.10 2001/01/09 12:07:26 cmdjb Exp $
#
# Metadata::IAFA - IAFA templates class
#
# Copyright (C) 1997-1998 Dave Beckett.  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::IAFA;

require 5.004;

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

use Carp;

use Metadata::Base;

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

%Default_Options=(
  TEMPLATE_TYPE => 'DOCUMENT',
  STRICT => '0',
  DEBUG => '0',
  WRAP => '0',
);

$HEADER_TEMPLATE_TYPE = 'X-AFA-HEADER';
$FOOTER_TEMPLATE_TYPE = 'X-AFA-FOOTER';


# 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;
}


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

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


# Set the given element, value and index?
sub validate ($$$;$) {
  my($self, $element, $value, $index)=@_;
  warn "@{[&whowasi]}: Field: $element Value: ", (defined $value) ? $value : "(undefined)", " Index:",(defined $index) ? $index : "(undefined)", "\n" if $self->{DEBUG};
  if ($element eq 'Template-Type') {
    $self->{TEMPLATE_TYPE}=$value;
    return;
  }
  $index=$1 if $element =~ s/-v(\d+)$//;
  return ($element, $value, $index);
}


# Check the legality of the given element and index
sub validate_elements ($$;$) {
  my($self, $element, $index)=@_;
  warn "@{[&whowasi]}: Field: $element Index:", (defined $index) ? $index : "(undefined)", "\n" if $self->{DEBUG};

  $index=$1 if $element =~ s/-v(\d+)$//;
  return ($element, $index);
}


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

  $self->clear;

  return undef if eof($fh);

  my $element='';
  my $value='';
  my $count=0;
  while(<$fh>) {
    chomp;
    if (/^([-#\w]+):\s*(.*)$/) {
      my($new_attr,$new_value)=($1,$2);
      $self->set($element, $value) and $count++ if $element;
      $count++;
      $element=$new_attr; $value=$new_value;
    } elsif (/^\s+(.*)$/) { # Allow leading whitespace to continue line
      my $bit=$1;

      # Strictly...
      last if $self->{STRICT} && !$bit; # end on a blank line too

      # A continuation line, so what about that white space?
      if ($value) {
	if ($self->{STRICT}) {
	  # strict - remove in URI elements, otherwise collapse to ' '
	  if ($element !~ /URI$/) {
	    $value .= ' ';
	  }
	} else {
	  # lax - preserve the newline, who cares?
	  $value.="\n";
	}
      }

      $value.=$bit;
    } elsif (!$_) {
      last;
    } else {
      warn "IAFA::read:$.: Do not understand line '$_'\n";
    }
  }

  $self->set($element, $value) and $count++ if $element;
  warn "@{[&whowasi]}: Read $count elements\n" if $self->{DEBUG};
  return 1;
}


sub format ($) {
  require 'Text/Wrap.pm';

  my $self=shift;
  my $string="Template-Type: $self->{TEMPLATE_TYPE}\n";
  for my $element ($self->order) {
    my $variants=$self->size($element);
    my $variant=0;
    for my $value ($self->get($element)) {
      next unless defined $value;
      chomp $value;
      if ($self->{STRICT}) {
        $value =~ s/\s+/ /g;
      } else {
        $value =~ s/\n/\n\t/g;
      }
      my $bit=($variants>1) ? "$element-v$variant: $value\n" : "$element: $value\n";
      if ($self->{STRICT} || $self->{WRAP}) {
	$bit=Text::Wrap::wrap("\t", "\t", $bit);
      }

      $string.=$bit;
    } continue {
      $variant++;
    }
  }
  $string;
}


sub pack ($) {
  my $self=shift;
  my $string=$self->SUPER::pack;

  # Use the knowledge that a field called Template-Type automagically becomes
  # a Template Type, not a regular field (via validate method).
  # Also depend on Metadata::Base using 'thing\0'  too.
  $string="Template-Type\0$self->{TEMPLATE_TYPE}\0".$string;

  $string;
}

# Base version is fine
# sub unpack


sub get_date_as_seconds ($$) {
  my($self,$element)=@_;

  my $value=$self->get($element);

  unless ($self->{STRICT}) {
    return $value if $value =~ /^\d+$/;

    if (my($year,$month,$day)=($value=~ /^(\d\d\d\d)-(\d\d)-(\d\d)$/)) {
      require 'Time/Local.pm';

      return Time::Local::timegm(0,0,0,$day,$month-1,$year-1900);
    }
  }

  require 'Date/Parse.pm';

  return Date::Parse::str2time($value);
}


sub set_date_as_seconds ($$$) {
  my($self,$element,$value)=@_;

  if ($self->{STRICT}) {
    require 'Date/Format.pm';

    # RFC           Dow, day month year HH:MM TZ
    $value=Date::Format::time2str("%a, %d %b %Y %T %z", $value);
  }

  $self->set($element, $value);
}


sub decode_uri_element ($) {
  my($uri)=@_;

  return (undef,undef,undef) if !defined($uri);

  my($path,$remotepath);
  if ($uri =~ /^(.+)\s+->\s+(.+)$/) {
    ($path,$remotepath)=($1,$2);
  } else {
    $path=$uri; $remotepath='';
  }
  my($basepath)='';
  # URL: ://host/...
  if ($path=~ m%^\w+://.+%) {
    $basepath=$path; $remotepath=$path; $path='';
  # Relative URL: /path/file
  } elsif ($path=~ m%/([^/]+)$%) {
    $basepath=$1;
  # File: file
  } elsif ($path !~ m%/%) {
    $basepath=$path;
  }

  return ($basepath, $path, $remotepath);
}


sub encode_uri_element ($;$) {
  my($path, $remotepath)=@_;

  return $remotepath ? "$path -> $remotepath" : $path;
}


sub order_template_type ($) {
  my($type)=@_;

  return 0 if $type eq $HEADER_TEMPLATE_TYPE;
  return 2 if $type eq $FOOTER_TEMPLATE_TYPE;

  return 1;

}



1;
__END__