[Summary view] [Print] [Text view]

   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