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