lib/Module/Build/YAML.pm

   1 package Module::Build::YAML;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = "0.50";
   7 our @EXPORT = ();
   8 our @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   # XXX doesn't handle embedded newlines
 106   my ($value) = @_;
 107   # undefs and empty strings will become empty strings
 108   if (! defined $value || $value eq "") {
 109     return('""');
 110   }
 111   # allow simple scalars (without embedded quote chars) to be unquoted
 112   elsif ($value !~ /["'\\]/) {
 113     return($value);
 114   }
 115   # strings without double-quotes get double-quoted
 116   elsif ($value !~ /\"/) {
 117     $value =~ s{\\}{\\\\}g;
 118     return qq{"$value"};
 119   }
 120   # other strings get single-quoted
 121   else {
 122     $value =~ s{([\\'])}{\\$1}g;
 123     return qq{'$value'};
 124   }
 125 }
 126
 127 1;
 128
 129 __END__
 130
 131 =head1 NAME
 132
 133 Module::Build::YAML - Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed
 134
 135 =head1 SYNOPSIS
 136
 137     use Module::Build::YAML;
 138
 139     ...
 140
 141 =head1 DESCRIPTION
 142
 143 Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed.
 144
 145 Currently, this amounts to the ability to write META.yml files when "perl Build distmeta"
 146 is executed via the Dump() and DumpFile() functions/methods.
 147
 148 =head1 AUTHOR
 149
 150 Stephen Adkins <spadkins@gmail.com>
 151
 152 =head1 COPYRIGHT
 153
 154 Copyright (c) 2006. Stephen Adkins. All rights reserved.
 155
 156 This program is free software; you can redistribute it and/or modify it
 157 under the same terms as Perl itself.
 158
 159 See L<http://www.perl.com/perl/misc/Artistic.html>
 160
 161 =cut
 162