File Coverage

blib/lib/Data/PropertyList.pm

Criterion	Covered	Total	%
statement	129	156	82.6
branch	55	100	55.0
condition	12	23	52.1
subroutine	15	17	88.2
pod	2	2	100.0
total	213	298	71.4

### Data::PropertyList - Convert arbitrary objects to/from strings.

### Copyright 1996, 1997, 1998 Evolution Online Systems, Inc.
  # You may use this software for free under the terms of the Artistic License

### Change History
  # 1998-12-17 Minor doc cleanup; added makefile and tests for distribution.
  # 1998-10-05 Tweaked output spacing for single-line string arrays.
  # 1998-10-05 Switched from use of String::Escape::add to direct hash access.
  # 1998-07-23 Conventionalized POD, switched to yyyy.mm_dd version numbering.
  # 1998-08-23 On further consideration, this really did belong in Data::*.
  # 1998-06-11 Improved support for <
  # 1998-05-07 Fixed problem with reading "0 = ..." lines in hashes.
  # 1998-03-03 Replaced $r->class with ref($r) -Simon
  # 1998-02-28 Initialized _parse_multiline $value to '' to run clean under -w.
  # 1998-02-25 Version 1.00 - String::PropertyList
  # 1998-02-25 Moved to String:: and @EXPORT_OK for CPAN distribution - jeremy
  # 1998-01-28 Fixed variable name typo in _parse_array.
  # 1998-01-11 Added rudimentary support for comments: full-line comments only
  # 1998-01-02 Renamed package Data::PropertyList to Text::PropertyList -Simon
  # 1997-12-08 Removed package Data::Types, use UNIVERSAL::isa instead. -Piglet
  # 1997-11-19 Added loopback handling to astext; now Supress as XREF TO
  # 1997-10-28 Updated to use new Text::Escape interface.
  # 1997-10-21 Documentation cleanup.
  # 1997-08-17 Moved string escape/unescape code into new Text::Escape. -Simon
  # 1997-01-2? New fromDictionary parser -Eric
  # 1997-01-14 New asDictionary function provides closer match to NeXT style.
  # 1997-01-11 Cloned & cleaned for Inetics; moved I/O to file.pm. V3.0 -Simon
  # 1996-10-29 Added append flag and trailing \n to write. -Piglet
  # 1996-08-06 Partial fix for blessed data; treat as basic type. V2.05 -Simon
  # 1996-07-13 Cleaned up flow, fixed headers.
  # 1996-06-25 Wrote &write. V2.04 -EJ
  # 1996-06-23 Converted from Perl 4 library to Perl 5 package. V2.03
  # 1996-06-18 Iterative line parsing replaces raw recursion. V2.02
  # 1996-06-15 Clean start with support for nested data structures. V2.01
  # 1996-05-26 Support for =<< multiline values.
  # 1996-05-08 Parse key-value pairs into a flat hash. Version 1. -Simon

package Data::PropertyList;

require 5.003;
use strict;

use vars qw( $VERSION @ISA @EXPORT_OK );
$VERSION = 1998.12_17;

use Exporter;
push @ISA, qw( Exporter );
push @EXPORT_OK, qw( astext fromtext );

use vars qw( $Separator );
$Separator = '.';

use String::Escape qw( qprintable unprintable );
$String::Escape::Escapes{'astext'} = \&astext;
$String::Escape::Escapes{'fromtext'} = \&fromtext;

### Writer

use vars qw( %DRefs %Supress $CurrentDRef $CurrentDepth );
use vars qw( $Indent $ShowClasses $ShowDRefs $Multiline $MaxItems );

# $string = astext($value_or_reference);
# $string = astext($value_or_reference, %options);
  # Write out an object graph in NeXT property list format
  # Numerous variables are localized, then we recurse.
sub astext {
  my $target = shift;
  my %options = @_;

  # Options
  local $CurrentDRef = '';
  local $CurrentDepth = 0;

  local $Indent = 2;

  local $ShowClasses = $options{'-classes'} if (exists $options{'-classes'} );
  local $ShowDRefs = $options{'-drefs'}     if (exists $options{'-drefs'} );
  local $Multiline = $options{'-multiline'} if (exists $options{'-multiline'});
  local $MaxItems = $options{'-maxitems'} if (exists $options{'-maxitems'});

  # Working scope for this invokation of astext.
  local %DRefs = ();
  local %Supress = ();

  _astext( $target )
}

# $string = _astext($referenceorvalue);
sub _astext {
  my $target = shift;

  # Write out an "UNDEFINED" comment to signal undefined values;
  return '/* UNDEFINED */' if (not defined $target);

  # Write out escaped version of non-reference (string or number) values.
  if ( ! ref($target) ) {
    if ( $Multiline and $target =~ /\n.*?\n/ ) {
      return "<
	     $target . ($target =~ /\n\Z/ ?'':"\n") .
	     "  END_OF_TEXT_DELIMITER";
    } else {
      return qprintable( $target );
    }
  }

  # If this is a reference an item written out elsewhere, write an XREF comment
  return '/* CROSS-REFERENCE TO ' .
  	( length($DRefs{$target}) ? $DRefs{$target} : 'ROOT' ) .' */'
		      if ( exists $DRefs{$target} and $Supress{$target} );

  # Store a relative DRef from the root to here, if we haven't already
  $DRefs{$target} = $CurrentDRef if ( not exists $DRefs{$target});

  # We're going to show this item, so don't show it again in the future
  $Supress{$target} ++ ;

  # Variable to hold the stringified form of $target.
  my $result = '';

  # Write out DRef if $ShowDRefs is set
  $result .= "/* DREF $CurrentDRef */ "
				      if ($ShowDRefs and length $CurrentDRef);

  # Any DRefs after this point are separated by dots.
  local $CurrentDRef = $CurrentDRef . $Separator if ( length $CurrentDRef );

  # Write out class of item if it's blessed and $ShowClasses is set
  $result .= "/* CLASS " . ref($target) . " */ " if ($ShowClasses and
      ref($target) and (ref($target) !~ /\A(ARRAY|HASH|SCALAR|REF|CODE)\Z/));

  if ( UNIVERSAL::isa($target, 'HASH') ) {
    my $key;
    foreach $key (sort keys %{$target}) {
      my $value = $target->{$key};
      next unless (ref $value);
      $DRefs{$value} = $CurrentDRef . $key unless ( exists $DRefs{$value} );
      $Supress{$value} ++;
    }
    $result .=  "{" if ($CurrentDepth);
    $result .= "\n" if ($result);
    $CurrentDepth ++;
    foreach $key (sort keys %{$target}) {
      $result .= ' ' x ( ($CurrentDepth - 1) * $Indent);
      local $CurrentDRef = $CurrentDRef . $key;
      $Supress{$target->{$key}} -- if ( ref $target->{$key} );
      $result .= _astext($key) . ' = ' . _astext($target->{$key}) .";\n";
    }
    $CurrentDepth --;
    $result .= ' 'x(($CurrentDepth-1) * $Indent) . "}" if ($CurrentDepth);
    return $result;
  }

  elsif ( UNIVERSAL::isa($target, 'ARRAY') ) {
    my $key;
    # If $MaxItems is set and there are fewer than that many non-ref items
    my $one_line = ( $MaxItems and $#{$target} <= $MaxItems );
    foreach $key (0 .. $#{$target}) {
      my $value = $target->[$key];
      next unless (ref $value);
      $one_line = 0;
      $DRefs{$value} = $CurrentDRef . $key unless ( exists $DRefs{$value} );
      $Supress{$value} ++;
    }
    my $joiner = ( $one_line ) ? " " : "\n";
    $result .=  "(" if ( $CurrentDepth );
    $result .= $joiner if ( $result );
    $CurrentDepth ++;
    foreach $key (0 .. $#{$target}) {
      $result .= $one_line ? '' : ' ' x ( ($CurrentDepth - 1) * $Indent);
      local $CurrentDRef = $CurrentDRef . $key;
      $Supress{$target->[$key]} -- if ( ref $target->[$key] );
      $result .= _astext($target->[$key]) . "," . $joiner;
    }
    $CurrentDepth --;
    $result .= ( ! $one_line ? ' 'x(($CurrentDepth-1) * $Indent) : '' ) . ")"
    						 if ( $CurrentDepth );
    return $result;
  }

  elsif (UNIVERSAL::isa($target, 'REF') or UNIVERSAL::isa($target, 'SCALAR')) {
    $result .= '/* REFERENCE */ ';
    local $CurrentDepth = $CurrentDepth + 1;
    local $CurrentDRef = $CurrentDRef . 0;
    $result .= _astext($$target);
    return $result;
  }

  # Otherwise it's some unsupported kind of reference; just "" stringify it
  return "/* REFERENCE TO $target */";
}

### Reader

use vars qw( @TextLines $LineNumber $Source );

# $datastructure = fromtext($string);
# $datastructure = fromtext($string, %options);
  # reconstruct an object graph from a NeXT property list.
sub fromtext ($%) {
  my $dictionary_text = shift;
  my %options = @_;

  local @TextLines = split("\n", $dictionary_text);
  local $LineNumber = 0;
  local $Source = $options{'-source'} || '';

  if ( $options{'-scalar'} ) {
    return _parse_value( _get_line() . "\000", "\000" );
  } elsif ( $options{'-array'} ) {
    return _parse_array();
  } else {
    return _parse_hash();
  }
}

# _parse_error( $message );
sub _parse_error {
  my $message = shift;
  warn 'PropertyList error, ' . $message .
      ' at line ' . $LineNumber . ( $Source ? ' in ' . $Source : '' ) ."\n";
}

# $text = _get_line;
sub _get_line {
  $LineNumber++;
  shift(@TextLines);
}

# $hash_ref = _parse_hash();
sub _parse_hash {
  my $hash = {};
  my ($key, $value, $current_line);

  while (@TextLines) {
    $current_line = _get_line();

    # Ignore comments
    $current_line =~ s#\Q/*\E.*?\Q*/\E##g;

    # Ignore blank lines
    next if ( $current_line =~ /^\s*$/ );

    # If we hit a closing brace, we're done with this hash
    last if ( $current_line =~ /^\s*\}[,;]/o );

    # Extract key and equals sign.
    if ( $current_line =~ s/^\s*\"(([^\"\\]|\\.)+)\"//o ) {
      $key = unprintable( $1 );
    } elsif ( $current_line =~ s/^\s*(\S+)//o ) {
      $key = unprintable( $1 );
    } else {
      _parse_error("Key not found");
      last;
    }

    $current_line =~ s/^\s*=\s*//o or _parse_error("= not found");

    # Extract value
    $value = _parse_value( $current_line, ';' );

    next unless (defined $key);

    $hash->{$key} = $value;
  }

  return $hash;
}

# $array_ref = _parse_array();
sub _parse_array {
  my $array = [];
  my ($value, $current_line);

  while (@TextLines) {
    $current_line = _get_line();

    # Ignore comments
    $current_line =~ s#\Q/*\E.*?\Q*/\E##g;

    # Ignore blank lines
    next if ( $current_line =~ /^\s*$/ );

    # If we hit a closing paren, we're done with this hash
    last if ( $current_line =~ /^\s*\)[,;]/o );

    # Extract value
    $value = _parse_value( $current_line, ',' );

    push( @$array, $value);

    next;
  }

  return $array;
}

# $string = _parse_multiline($ender);
sub _parse_multiline {
  my $ender = shift;

  my $value = '';
  my $current_line;

  while (@TextLines) {
    $current_line = _get_line();
    last if ($current_line =~ /^\s*\Q$ender\E[\;\,]?\s*$/);
    $value .= $current_line . "\n";
  }
  return $value;
}

# $value = _parse_value( $value, $terminator );
  # Extracts a quoted or unquoted string, an array, hash, or a multiline string
sub _parse_value {
  my $current_line = shift;
  my $end_value = shift;

  if ( $current_line =~ /^\s*\"(([^\"\\]|\\.)*)\"\Q$end_value\E\s*/ ) {
    # Extract quoted value
    return unprintable( $1 );
  } elsif ( $current_line =~ /^\s*(\S+?)\Q$end_value\E\s*/ ) {
    # Extract unquoted value
    return unprintable( $1 );
  } elsif ( $current_line =~ /^\s*(\/\*.*?\*\/)\s*\Q$end_value\E\s*/ ) {
    # Extract comment
    return undef;
  } elsif ( $current_line =~ /^\s*\{/o ) {
    return _parse_hash();
  } elsif ( $current_line =~ /^\s*\(/o ) {
    return _parse_array();
  } elsif ( $current_line =~ /^\s*\<\<(\w+)(?:\Q$end_value\E)?/o ) {
    return _parse_multiline($1);
  } else {
    _parse_error("value not found in '$current_line' - $end_value");
  }
}

1;

__END__