lib/Module/Build/YAML.pm

   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   if (! defined $value) {
 108     return("~");
 109   }
 110   # empty strings will become empty strings
 111   elsif (! defined $value || $value eq "") {
 112     return('""');
 113   }
 114   # quote and escape strings with special values
 115   elsif ($value =~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/) {
 116     if ($value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/) {  # nothing but " or @ or < or > (email addresses)
 117       return("'" . $value . "'");
 118     }
 119     else {
 120       $value =~ s/\n/\\n/g;    # handle embedded newlines
 121       $value =~ s/"/\\"/g;     # handle embedded quotes
 122       return('"' . $value . '"');
 123     }
 124   }
 125   # allow simple scalars (without embedded quote chars) to be unquoted
 126   # (includes $%_+=-\;:,./)
 127   else {
 128     return($value);
 129   }
 130 }
 131
 132 1;
 133
 134 __END__
 135
 136 =head1 NAME
 137
 138 Module::Build::YAML - Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed
 139
 140 =head1 SYNOPSIS
 141
 142     use Module::Build::YAML;
 143
 144     ...
 145
 146 =head1 DESCRIPTION
 147
 148 Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed.
 149
 150 Currently, this amounts to the ability to write META.yml files when "perl Build distmeta"
 151 is executed via the Dump() and DumpFile() functions/methods.
 152
 153 =head1 AUTHOR
 154
 155 Stephen Adkins <spadkins@gmail.com>
 156
 157 =head1 COPYRIGHT
 158
 159 Copyright (c) 2006. Stephen Adkins. All rights reserved.
 160
 161 This program is free software; you can redistribute it and/or modify it
 162 under the same terms as Perl itself.
 163
 164 See L<http://www.perl.com/perl/misc/Artistic.html>
 165
 166 =cut
 167