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   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