home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _2d7e8f1a03e75727bd075e2a3492bd3b < prev    next >
Text File  |  2004-06-01  |  8KB  |  296 lines
  1. package PPM::YAML;
  2.  
  3. # this used to be the original version of YAML.pm, now superceded
  4. # by a newer incompatible version
  5.  
  6. use strict;
  7. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  8. use vars qw($Width $Comma $Level $TabWidth $Sort $MaxLines $HashMode);
  9. require Exporter;
  10. @ISA = qw(Exporter);
  11. @EXPORT = qw(serialize deserialize);
  12. $VERSION = '0.16';
  13. use Carp;
  14.  
  15. sub serialize {
  16.     local $/ = "\n";
  17.  
  18.     my $o = bless {serial => '',
  19.            level => 0,
  20.            width => 4,
  21.           }, __PACKAGE__;
  22.  
  23.     while (@_) {
  24.     local $_ = shift;
  25.     croak "Arguments to serialize() must be a list of hash refs\n"
  26.       unless ref eq 'HASH' and not /=/;
  27.     $o->_serialize_hash($_, 1);
  28.     $o->{serial} .= "----\n" if @_;
  29.     }
  30.     return $o->{serial};
  31. }
  32.  
  33. sub _serialize_data {
  34.     my $o = shift;
  35.     local $_ = shift;
  36.     return $o->_serialize_undef($_)
  37.       if not defined;
  38.     return $o->_serialize_value($_)
  39.       if (not ref);
  40.     return $o->_serialize_hash($_, 0)
  41.       if (ref eq 'HASH' and not /=/ or /=HASH/);
  42.     return $o->_serialize_array($_)
  43.       if (ref eq 'ARRAY' and not /=/ or /=ARRAY/);
  44.     warn "WARNING: Cannot serialize the following reference:\n\t$_\n"
  45.     if $^W;
  46.     $o->{serial} .= "$_\n";
  47. }
  48.  
  49. sub _serialize_value {
  50.     my ($o, $data) = @_;
  51.     my $value;
  52.     if ($data =~ /\n/) {
  53.     my $indent = ' ' x (($o->{level} + 1) * $o->{width});
  54.     my $sigil = ($data =~ s/\n\Z//) ? '|' : '|-';
  55.     $data =~ s/^/$indent/mg;
  56.         chomp $data;
  57.     $value = "$sigil\n$data\n";
  58.     }
  59.     elsif ($data =~ /^[\s\%\@\~\"]|\s$/ or
  60.        $data =~ /([\x00-\x1f\x7f-\xff])/ or
  61.        $data eq '') {
  62.     $data =~ s/\"/\\\"/g;
  63.     $value = qq{"$data"\n};
  64.     }
  65.     else {
  66.     $value = "$data\n";
  67.     }
  68.     $o->{serial} .= $value;
  69. }
  70.  
  71. sub _serialize_hash {
  72.     my ($o, $data, $top) = @_;
  73.     $o->_serialize_reference($data, '%', 'HASH', $top);
  74.     $o->{level}++ unless $top;
  75.     my $indent = ' ' x ($o->{level} * $o->{width});
  76.     for my $key (sort keys %$data) {
  77.     my $key_out = $key;
  78.     if ($key =~ /^[\s\%\@\~\"]|:|\s\s|\n|\s$/) {
  79.         $key_out =~ s/\n/\\n/g;
  80.         $key_out =~ s/\"/\\\"/g;
  81.         $key_out = qq{"$key_out"};
  82.     }
  83.     $o->{serial} .= "$indent$key_out: ";
  84.     $o->_serialize_data($data->{$key});
  85.     }
  86.     $o->{level}--;
  87.     delete $o->{ref_stack_xref}{pop @{$o->{ref_stack}} or die};
  88. }
  89.  
  90. sub _serialize_array {
  91.     my ($o, $data) = @_;
  92.     $o->_serialize_reference($data, '@', 'ARRAY', 0);
  93.     my $indent = ' ' x (++$o->{level} * $o->{width});
  94.     for my $datum (@$data) {
  95.     $o->{serial} .= "$indent: ";
  96.     $o->_serialize_data($datum);
  97.     }
  98.     $o->{level}--;
  99.     delete $o->{ref_stack_xref}{pop @{$o->{ref_stack}} or die};
  100. }
  101.  
  102. sub _serialize_undef {
  103.     my ($o) = @_;
  104.     $o->{serial} .= "~\n";
  105. }
  106.  
  107. sub _serialize_reference {
  108.     my ($o, $data, $sigil, $type, $top) = @_;
  109.  
  110.     $data =~ /^(([\w:]+)=)?$type\(0x([0-9a-f]+)\)$/ 
  111.       or croak "Invalid reference: $data, for type $type\n";
  112.  
  113.     croak "PPM::YAML does not yet support circular references\n"
  114.       if defined $o->{ref_stack_xref}{$3};
  115.  
  116.     if (not $top) {
  117.     $o->{serial} .= "!$2 " if defined $2;
  118.     $o->{serial} .= $sigil . "\n";
  119.     }
  120.  
  121.     push @{$o->{ref_stack}}, $3;
  122.     $o->{ref_stack_xref}{$3}++;
  123. }
  124.  
  125. sub deserialize {
  126.     local $/ = "\n";
  127.     my ($text) = @_;
  128.     chomp $text;
  129.     my $o = bless {lines => [split($/, $text)],
  130.            level => 0,
  131.            width => 4,
  132.            tabwidth => 8,
  133.           }, __PACKAGE__;
  134.  
  135.     @{$o->{objects}} = ();
  136.     $o->{level} = 0;
  137.     $o->{line} ||= 1;
  138.     $o->_setup_line;
  139.     while (not $o->{eod}) {
  140.     croak "Deserialize error. Starting production not a hash.\n"
  141.       unless $o->{content} =~ /^\S.*[^\\]:/;
  142.     $o->{done} = 0;
  143.     my $hash = {};
  144.     %$hash = $o->_deserialize_hash(1);
  145.     push @{$o->{objects}}, $hash;
  146.     $o->_next_line;
  147.     $o->_setup_line;
  148.     }
  149.     return wantarray ? @{$o->{objects}} : ${$o->{objects}}[-1];
  150. }
  151.  
  152. sub _deserialize_data {
  153.     my $o = shift;
  154.     my ($obj, $class) = ('', '');
  155.  
  156.     if ($o->{content} =~ /^(?:\!(\w(?:\w|::)*))?\s*
  157.                       ([\%\@])
  158.                           \s*$/x
  159.        ) {
  160.     $obj = ($2 eq '%') ? {} : [];
  161.     $class = $1 || '';
  162.     if ($2 eq '%') {
  163.         %$obj = $o->_deserialize_hash(0);
  164.     }
  165.     elsif ($2 eq '@') {
  166.         @$obj = $o->_deserialize_array;
  167.     }
  168.     else {
  169.         croak "Insane error\n";
  170.     }
  171.     bless $obj, $class if length $class;
  172.     }
  173.     elsif ($o->{content} =~ /^\~\s*$/) {
  174.     $obj = $o->_deserialize_undef;
  175.     }
  176.     else {
  177.     $obj = $o->_deserialize_value;
  178.     }
  179.     return $obj;
  180. }
  181.  
  182. sub _deserialize_value {
  183.     my $o = shift;
  184.     my $value = '';
  185.     my $indent = $o->{level} * $o->{width};
  186.  
  187.     if ($o->{content} =~ /^\s*\|\s*(-)?\s*$/) {
  188.     my $chomp = $1 eq '-';
  189.     $o->_next_line;
  190.     my $indent = ($o->{level} + 1) * $o->{width};
  191.     while (not $o->{done} and
  192.            $o->{lines}[0] =~ /^\s{$indent}/) {
  193.         $value .= substr($o->{lines}[0], $indent) . "\n";
  194.         $o->_next_line;
  195.     }
  196.     chomp $value if $chomp;
  197.     $o->_setup_line;
  198.     }
  199.     elsif ($o->{content} =~ /^\"/) {
  200.     croak "Mismatched quotes"
  201.       unless $o->{content} =~ /^\"(.*)\"\s*$/;
  202.     $value = $1;
  203.     $o->_next_line;
  204.     $o->_setup_line;
  205.     }
  206.     else {
  207.     $value = $o->{content};
  208.     $o->_next_line;
  209.     $o->_setup_line;
  210.     }
  211.     return $value;
  212. }
  213.  
  214. sub _deserialize_hash {
  215.     my @values;
  216.     my ($o, $top) = @_;
  217.     my $level = $o->{level};
  218.     unless ($top) {
  219.     $level++;
  220.     $o->_next_line;
  221.     $o->_setup_line;
  222.     }
  223.     my ($key, $value);
  224.     while ($o->{level} == $level) {
  225.     if ($o->{content} =~ /^\"/) {
  226.         croak "Bad map key at line $o->{line}\n"
  227.           unless ($o->{content} =~ /^\"(.*?(?<!\\))\"\s*:\s*(.*)/);
  228.         ($key, $value) = ($1, $2);
  229.         $key =~ s/\\n/\n/g;
  230.         $key =~ s/\\\"/\"/g;
  231.     }
  232.     else {
  233.         ($key, $value) = split /\s*:\s*/, $o->{content}, 2;
  234.         croak $o->invalid_key_value unless (defined $key);
  235.     }
  236.     $o->{content} = defined $value ? $value : '';
  237.     push @values, $o->_get_key($key), $o->_deserialize_data;;
  238.     }
  239.     croak "Invalid ident level\n$o->{content}\nLine: $o->{line}\n$o->{level}\n$level\n"
  240.       if $o->{level} > $level;
  241.     return @values;
  242. }
  243.  
  244. sub _get_key {
  245.     my ($o, $key) = @_;
  246.     return $key unless $key =~ /^\"(.*)\"$/;
  247.     $key = $1;
  248.     $key =~ s/\\n/\n/g;
  249.     $key =~ s/\\\"/\"/g;
  250.     return $key;
  251. }
  252.  
  253. sub _deserialize_array {
  254.     my @values;
  255.     my $o = shift;
  256.     my $level = $o->{level} + 1;
  257.     $o->_next_line;
  258.     $o->_setup_line;
  259.     while ($o->{level} == $level) {
  260.     croak "List item not bulleted at line $o->{line}\n"
  261.       unless($o->{content} =~ /^(: +)/);
  262.     substr($o->{content}, 0, length($1), '');
  263.     push @values, $o->_deserialize_data;
  264.     }
  265.     croak "Invalid indent level\n" if $o->{level} > $level;
  266.     return @values;
  267. }
  268.  
  269. sub _deserialize_undef {
  270.     my $o = shift;
  271.     $o->_next_line;
  272.     $o->_setup_line;
  273.     return undef;
  274. }
  275.  
  276. sub _next_line {
  277.     my $o = shift;
  278.     $o->{eod}++, $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}};
  279.     local $_ = shift @{$o->{lines}};
  280.     $o->{line}++;
  281. }
  282.  
  283. sub _setup_line {
  284.     my $o = shift;
  285.     $o->{eod}++, $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}};
  286.     $o->{done}++, $o->{level} = -1, return if $o->{lines}[0] =~ /^----$/;
  287.     my ($width, $tabwidth) = @{$o}{qw(width tabwidth)};
  288.     local $_ = $o->{lines}[0];
  289.     croak "Invalid indent width at line $o->{line}\n"
  290.       unless /^(( {$width})*)(\S.*)$/;
  291.     $o->{level} = length($1) / $width;
  292.     $o->{content} = $3;
  293. }
  294.  
  295. 1;
  296.