local-lib5/lib/perl5/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     binmode($OUT, ':utf8') if $] >= 5.008;
  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     binmode($IN, ':utf8') if $] >= 5.008;
  55     return Load(do { local $/; <$IN> });
  56     close $IN;
  57 }
  58
  59 sub _yaml_chunk {
  60   my ($indent, $values) = @_;
  61   my $yaml_chunk = "";
  62   my $ref = ref($values);
  63   my ($value, @allkeys, %keyseen);
  64   if (!$ref) {  # a scalar
  65     $yaml_chunk .= &_yaml_value($values) . "\n";
  66   }
  67   elsif ($ref eq "ARRAY") {
  68     foreach $value (@$values) {
  69       $yaml_chunk .= "$indent-";
  70       $ref = ref($value);
  71       if (!$ref) {
  72         $yaml_chunk .= " " . &_yaml_value($value) . "\n";
  73       }
  74       else {
  75         $yaml_chunk .= "\n";
  76         $yaml_chunk .= &_yaml_chunk("$indent  ", $value);
  77       }
  78     }
  79   }
  80   else { # assume "HASH"
  81     if ($values->{_order} && ref($values->{_order}) eq "ARRAY") {
  82         @allkeys = @{$values->{_order}};
  83         $values = { %$values };
  84         delete $values->{_order};
  85     }
  86     push(@allkeys, sort keys %$values);
  87     foreach my $key (@allkeys) {
  88       next if (!defined $key || $key eq "" || $keyseen{$key});
  89       $keyseen{$key} = 1;
  90       $yaml_chunk .= "$indent$key:";
  91       $value = $values->{$key};
  92       $ref = ref($value);
  93       if (!$ref) {
  94         $yaml_chunk .= " " . &_yaml_value($value) . "\n";
  95       }
  96       else {
  97         $yaml_chunk .= "\n";
  98         $yaml_chunk .= &_yaml_chunk("$indent  ", $value);
  99       }
 100     }
 101   }
 102   return($yaml_chunk);
 103 }
 104
 105 sub _yaml_value {
 106   my ($value) = @_;
 107   # undefs become ~
 108   return '~' if not defined $value;
 109
 110   # empty strings will become empty strings
 111   return '""' if $value eq '';
 112
 113   # allow simple scalars (without embedded quote chars) to be unquoted
 114   # (includes $%_+=-\;:,./)
 115   return $value if $value !~ /["'`~\n!\@\#^\&\*\(\)\{\}\[\]\|<>\?]/;
 116
 117   # quote and escape strings with special values
 118   return "'$value'"
 119     if $value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/;  # nothing but " or @ or < or > (email addresses)
 120
 121   $value =~ s/\n/\\n/g;    # handle embedded newlines
 122   $value =~ s/"/\\"/g;     # handle embedded quotes
 123   return qq{"$value"};
 124 }
 125
 126 1;
 127
 128 __END__
 129
 130 =head1 NAME
 131
 132 Module::Build::YAML - Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed
 133
 134 =head1 SYNOPSIS
 135
 136     use Module::Build::YAML;
 137
 138     ...
 139
 140 =head1 DESCRIPTION
 141
 142 Provides just enough YAML support so that Module::Build works even if YAML.pm is not installed.
 143
 144 Currently, this amounts to the ability to write META.yml files when C<perl Build distmeta>
 145 is executed via the Dump() and DumpFile() functions/methods.
 146
 147 =head1 AUTHOR
 148
 149 Stephen Adkins <spadkins@gmail.com>
 150
 151 =head1 COPYRIGHT
 152
 153 Copyright (c) 2006. Stephen Adkins. All rights reserved.
 154
 155 This program is free software; you can redistribute it and/or modify it
 156 under the same terms as Perl itself.
 157
 158 See L<http://www.perl.com/perl/misc/Artistic.html>
 159
 160 =cut
 161