home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Module / Build / YAML.pm < prev   
Encoding:
Perl POD Document  |  2009-06-26  |  4.0 KB  |  161 lines
  1. package Module::Build::YAML;
  2.  
  3. use strict;
  4.  
  5. use vars qw($VERSION @EXPORT @EXPORT_OK);
  6. $VERSION = "0.50";
  7. @EXPORT = ();
  8. @EXPORT_OK = qw(Dump Load DumpFile LoadFile);
  9.  
  10. sub new {
  11.     my $this = shift;
  12.     my $class = ref($this) || $this;
  13.     my $self = {};
  14.     bless $self, $class;
  15.     return($self);
  16. }
  17.  
  18. sub Dump {
  19.     shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
  20.     my $yaml = "";
  21.     foreach my $item (@_) {
  22.         $yaml .= "---\n";
  23.         $yaml .= &_yaml_chunk("", $item);
  24.     }
  25.     return $yaml;
  26. }
  27.  
  28. sub Load {
  29.     shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
  30.     die "not yet implemented";
  31. }
  32.  
  33. # This is basically copied out of YAML.pm and simplified a little.
  34. sub DumpFile {
  35.     shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
  36.     my $filename = shift;
  37.     local $/ = "\n"; # reset special to "sane"
  38.     my $mode = '>';
  39.     if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
  40.         ($mode, $filename) = ($1, $2);
  41.     }
  42.     open my $OUT, "$mode $filename"
  43.       or die "Can't open $filename for writing: $!";
  44.     print $OUT Dump(@_);
  45.     close $OUT;
  46. }
  47.  
  48. # This is basically copied out of YAML.pm and simplified a little.
  49. sub LoadFile {
  50.     shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
  51.     my $filename = shift;
  52.     open my $IN, $filename
  53.       or die "Can't open $filename for reading: $!";
  54.     return Load(do { local $/; <$IN> });
  55.     close $IN;
  56. }   
  57.  
  58. sub _yaml_chunk {
  59.   my ($indent, $values) = @_;
  60.   my $yaml_chunk = "";
  61.   my $ref = ref($values);
  62.   my ($value, @allkeys, %keyseen);
  63.   if (!$ref) {  # a scalar
  64.     $yaml_chunk .= &_yaml_value($values) . "\n";
  65.   }
  66.   elsif ($ref eq "ARRAY") {
  67.     foreach $value (@$values) {
  68.       $yaml_chunk .= "$indent-";
  69.       $ref = ref($value);
  70.       if (!$ref) {
  71.         $yaml_chunk .= " " . &_yaml_value($value) . "\n";
  72.       }
  73.       else {
  74.         $yaml_chunk .= "\n";
  75.         $yaml_chunk .= &_yaml_chunk("$indent  ", $value);
  76.       }
  77.     }
  78.   }
  79.   else { # assume "HASH"
  80.     if ($values->{_order} && ref($values->{_order}) eq "ARRAY") {
  81.         @allkeys = @{$values->{_order}};
  82.         $values = { %$values };
  83.         delete $values->{_order};
  84.     }
  85.     push(@allkeys, sort keys %$values);
  86.     foreach my $key (@allkeys) {
  87.       next if (!defined $key || $key eq "" || $keyseen{$key});
  88.       $keyseen{$key} = 1;
  89.       $yaml_chunk .= "$indent$key:";
  90.       $value = $values->{$key};
  91.       $ref = ref($value);
  92.       if (!$ref) {
  93.         $yaml_chunk .= " " . &_yaml_value($value) . "\n";
  94.       }
  95.       else {
  96.         $yaml_chunk .= "\n";
  97.         $yaml_chunk .= &_yaml_chunk("$indent  ", $value);
  98.       }
  99.     }
  100.   }
  101.   return($yaml_chunk);
  102. }
  103.  
  104. sub _yaml_value {
  105.   my ($value) = @_;
  106.   # undefs become ~
  107.   return '~' if not defined $value;
  108.  
  109.   # empty strings will become empty strings
  110.   return '""' if $value eq '';
  111.  
  112.   # allow simple scalars (without embedded quote chars) to be unquoted
  113.   # (includes $%_+=-\;:,./)
  114.   return $value if $value !~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/;
  115.  
  116.   # quote and escape strings with special values
  117.   return "'$value'"
  118.     if $value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/;  # nothing but " or @ or < or > (email addresses)
  119.  
  120.   $value =~ s/\n/\\n/g;    # handle embedded newlines
  121.   $value =~ s/"/\\"/g;     # handle embedded quotes
  122.   return qq{"$value"};
  123. }
  124.  
  125. 1;
  126.  
  127. __END__
  128.  
  129. =head1 NAME
  130.  
  131. Module::Build::YAML - Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed
  132.  
  133. =head1 SYNOPSIS
  134.  
  135.     use Module::Build::YAML;
  136.  
  137.     ...
  138.  
  139. =head1 DESCRIPTION
  140.  
  141. Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed.
  142.  
  143. Currently, this amounts to the ability to write META.yml files when "perl Build distmeta"
  144. is executed via the Dump() and DumpFile() functions/methods.
  145.  
  146. =head1 AUTHOR
  147.  
  148. Stephen Adkins <spadkins@gmail.com>
  149.  
  150. =head1 COPYRIGHT
  151.  
  152. Copyright (c) 2006. Stephen Adkins. All rights reserved.
  153.  
  154. This program is free software; you can redistribute it and/or modify it
  155. under the same terms as Perl itself.
  156.  
  157. See L<http://www.perl.com/perl/misc/Artistic.html>
  158.  
  159. =cut
  160.  
  161.