vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libmodule-build-perl/libmodule-build-perl-0.2808.01/lib/Module/Build/YAML.pm

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