lib/Module/Build/YAML.pm

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