8d5e29b5ef39509bc9d662652c049224d2ef9192
[perl.git] / lib / Parse / CPAN / Meta.pm
1 package Parse::CPAN::Meta;
2
3 use strict;
4 use Carp 'croak';
5 BEGIN {
6         require 5.004;
7         require Exporter;
8         $Parse::CPAN::Meta::VERSION   = '0.04';
9         @Parse::CPAN::Meta::ISA       = qw{ Exporter      };
10         @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
11 }
12
13 # Prototypes
14 sub LoadFile ($);
15 sub Load     ($);
16 sub _scalar  ($$$);
17 sub _array   ($$$);
18 sub _hash    ($$$);
19
20 # Printable characters for escapes
21 my %UNESCAPES = (
22         z => "\x00", a => "\x07", t    => "\x09",
23         n => "\x0a", v => "\x0b", f    => "\x0c",
24         r => "\x0d", e => "\x1b", '\\' => '\\',
25 );
26
27
28
29
30
31 #####################################################################
32 # Implementation
33
34 # Create an object from a file
35 sub LoadFile ($) {
36         # Check the file
37         my $file = shift;
38         croak('You did not specify a file name')            unless $file;
39         croak( "File '$file' does not exist" )              unless -e $file;
40         croak( "'$file' is a directory, not a file" )       unless -f _;
41         croak( "Insufficient permissions to read '$file'" ) unless -r _;
42
43         # Slurp in the file
44         local $/ = undef;
45         open( CFG, $file ) or croak("Failed to open file '$file': $!");
46         my $yaml = <CFG>;
47         close CFG          or croak("Failed to close file '$file': $!");
48
49         # Hand off to the actual parser
50         Load( $yaml );
51 }
52
53 # Parse a document from a string.
54 # Doing checks on $_[0] prevents us having to do a string copy.
55 sub Load ($) {
56         unless ( defined $_[0] ) {
57                 croak("Did not provide a string to Load");
58         }
59         return () unless length $_[0];
60         unless ( $_[0] =~ /[\012\015]+$/ ) {
61                 croak("Stream does not end with newline character");
62         }
63
64         # Split the file into lines
65         my @lines = grep { ! /^\s*(?:\#.*)?$/ }
66                     split /(?:\015{1,2}\012|\015|\012)/, shift;
67
68         # A nibbling parser
69         my @documents = ();
70         while ( @lines ) {
71                 # Do we have a document header?
72                 if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?$/ ) {
73                         # Handle scalar documents
74                         shift @lines;
75                         if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML:[\d\.]+)$/ ) {
76                                 push @documents, _scalar( "$1", [ undef ], \@lines );
77                                 next;
78                         }
79                 }
80
81                 if ( ! @lines or $lines[0] =~ /^---\s*(?:(.+)\s*)?$/ ) {
82                         # A naked document
83                         push @documents, undef;
84
85                 } elsif ( $lines[0] =~ /^\s*\-/ ) {
86                         # An array at the root
87                         my $document = [ ];
88                         push @documents, $document;
89                         _array( $document, [ 0 ], \@lines );
90
91                 } elsif ( $lines[0] =~ /^(\s*)\w/ ) {
92                         # A hash at the root
93                         my $document = { };
94                         push @documents, $document;
95                         _hash( $document, [ length($1) ], \@lines );
96
97                 } else {
98                         croak("Parse::CPAN::Meta does not support the line '$lines[0]'");
99                 }
100         }
101
102         if ( wantarray ) {
103                 return @documents;
104         } else {
105                 return $documents[-1];
106         }
107 }
108
109 # Deparse a scalar string to the actual scalar
110 sub _scalar ($$$) {
111         my $string = shift;
112         my $indent = shift;
113         my $lines  = shift;
114
115         # Trim trailing whitespace
116         $string =~ s/\s*$//;
117
118         # Explitic null/undef
119         return undef if $string eq '~';
120
121         # Quotes
122         if ( $string =~ /^\'(.*?)\'$/ ) {
123                 return '' unless defined $1;
124                 my $rv = $1;
125                 $rv =~ s/\'\'/\'/g;
126                 return $rv;
127         }
128         if ( $string =~ /^\"((?:\\.|[^\"])*)\"$/ ) {
129                 my $str = $1;
130                 $str =~ s/\\"/"/g;
131                 $str =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
132                 return $str;
133         }
134         if ( $string =~ /^[\'\"]/ ) {
135                 # A quote with folding... we don't support that
136                 croak("Parse::CPAN::Meta does not support multi-line quoted scalars");
137         }
138
139         # Null hash and array
140         if ( $string eq '{}' ) {
141                 # Null hash
142                 return {};              
143         }
144         if ( $string eq '[]' ) {
145                 # Null array
146                 return [];
147         }
148
149         # Regular unquoted string
150         return $string unless $string =~ /^[>|]/;
151
152         # Error
153         croak("Multi-line scalar content missing") unless @$lines;
154
155         # Check the indent depth
156         $lines->[0] =~ /^(\s*)/;
157         $indent->[-1] = length("$1");
158         if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
159                 croak("Illegal line indenting");
160         }
161
162         # Pull the lines
163         my @multiline = ();
164         while ( @$lines ) {
165                 $lines->[0] =~ /^(\s*)/;
166                 last unless length($1) >= $indent->[-1];
167                 push @multiline, substr(shift(@$lines), length($1));
168         }
169
170         my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
171         my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
172         return join( $j, @multiline ) . $t;
173 }
174
175 # Parse an array
176 sub _array ($$$) {
177         my $array  = shift;
178         my $indent = shift;
179         my $lines  = shift;
180
181         while ( @$lines ) {
182                 # Check for a new document
183                 return 1 if $lines->[0] =~ /^---\s*(?:(.+)\s*)?$/;
184
185                 # Check the indent level
186                 $lines->[0] =~ /^(\s*)/;
187                 if ( length($1) < $indent->[-1] ) {
188                         return 1;
189                 } elsif ( length($1) > $indent->[-1] ) {
190                         croak("Hash line over-indented");
191                 }
192
193                 if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
194                         # Inline nested hash
195                         my $indent2 = length("$1");
196                         $lines->[0] =~ s/-/ /;
197                         push @$array, { };
198                         _hash( $array->[-1], [ @$indent, $indent2 ], $lines );
199
200                 } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*$/ ) {
201                         # Array entry with a value
202                         shift @$lines;
203                         push @$array, _scalar( "$2", [ @$indent, undef ], $lines );
204
205                 } elsif ( $lines->[0] =~ /^\s*\-\s*$/ ) {
206                         shift @$lines;
207                         unless ( @$lines ) {
208                                 push @$array, undef;
209                                 return 1;
210                         }
211                         if ( $lines->[0] =~ /^(\s*)\-/ ) {
212                                 my $indent2 = length("$1");
213                                 if ( $indent->[-1] == $indent2 ) {
214                                         # Null array entry
215                                         push @$array, undef;
216                                 } else {
217                                         # Naked indenter
218                                         push @$array, [ ];
219                                         _array( $array->[-1], [ @$indent, $indent2 ], $lines );
220                                 }
221
222                         } elsif ( $lines->[0] =~ /^(\s*)\w/ ) {
223                                 push @$array, { };
224                                 _hash( $array->[-1], [ @$indent, length("$1") ], $lines );
225
226                         } else {
227                                 croak("Parse::CPAN::Meta does not support the line '$lines->[0]'");
228                         }
229
230                 } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
231                         # This is probably a structure like the following...
232                         # ---
233                         # foo:
234                         # - list
235                         # bar: value
236                         #
237                         # ... so lets return and let the hash parser handle it
238                         return 1;
239
240                 } else {
241                         croak("Parse::CPAN::Meta does not support the line '$lines->[0]'");
242                 }
243         }
244
245         return 1;
246 }
247
248 # Parse an array
249 sub _hash ($$$) {
250         my $hash   = shift;
251         my $indent = shift;
252         my $lines  = shift;
253
254         while ( @$lines ) {
255                 # Check for a new document
256                 return 1 if $lines->[0] =~ /^---\s*(?:(.+)\s*)?$/;
257
258                 # Check the indent level
259                 $lines->[0] =~/^(\s*)/;
260                 if ( length($1) < $indent->[-1] ) {
261                         return 1;
262                 } elsif ( length($1) > $indent->[-1] ) {
263                         croak("Hash line over-indented");
264                 }
265
266                 # Get the key
267                 unless ( $lines->[0] =~ s/^\s*([^\'\"][^\n]*?)\s*:(\s+|$)// ) {
268                         croak("Bad hash line");
269                 }
270                 my $key = $1;
271
272                 # Do we have a value?
273                 if ( length $lines->[0] ) {
274                         # Yes
275                         $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
276                         next;
277                 }
278
279                 # An indent
280                 shift @$lines;
281                 unless ( @$lines ) {
282                         $hash->{$key} = undef;
283                         return 1;
284                 }
285                 if ( $lines->[0] =~ /^(\s*)-/ ) {
286                         $hash->{$key} = [];
287                         _array( $hash->{$key}, [ @$indent, length($1) ], $lines );
288                 } elsif ( $lines->[0] =~ /^(\s*)./ ) {
289                         my $indent2 = length("$1");
290                         if ( $indent->[-1] >= $indent2 ) {
291                                 # Null hash entry
292                                 $hash->{$key} = undef;
293                         } else {
294                                 $hash->{$key} = {};
295                                 _hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
296                         }
297                 }
298         }
299
300         return 1;
301 }
302
303 1;
304
305 __END__
306
307 =pod
308
309 =head1 NAME
310
311 Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files
312
313 =head1 SYNOPSIS
314
315     #############################################
316     # In your file
317     
318     ---
319     rootproperty: blah
320     section:
321       one: two
322       three: four
323       Foo: Bar
324       empty: ~
325     
326     
327     
328     #############################################
329     # In your program
330     
331     use Parse::CPAN::Meta;
332     
333     # Create a YAML file
334     my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' );
335     
336     # Reading properties
337     my $root = $yaml[0]->{rootproperty};
338     my $one  = $yaml[0]->{section}->{one};
339     my $Foo  = $yaml[0]->{section}->{Foo};
340
341 =head1 DESCRIPTION
342
343 B<Parse::CPAN::Meta> is a parser for META.yml files, based on the
344 parser half of L<YAML::Tiny>.
345
346 It supports a basic subset of the full YAML specification, enough to
347 implement parsing of typical META.yml files, and other similarly simple
348 YAML files.
349
350 If you need something with more power, move up to a full YAML parser such
351 as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>.
352
353 Parse::CPAN::Meta provides a very simply API of only two functions, based
354 on the YAML functions of the same name. Wherever possible, identical
355 calling semantics are used.
356
357 All error reporting is done with exceptions (dieing).
358
359 =head1 FUNCTIONS
360
361 For maintenance clarity, no functions are exported.
362
363 =head2 Load( $string )
364
365   my @documents = Load( $string );
366
367 Parses a string containing a valid YAML stream into a list of Perl data
368 structures.
369
370 =head2 LoadFile( $file_name )
371
372 Reads the YAML stream from a file instead of a string.
373
374 =head1 SUPPORT
375
376 Bugs should be reported via the CPAN bug tracker at
377
378 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta>
379
380 =head1 AUTHOR
381
382 Adam Kennedy E<lt>adamk@cpan.orgE<gt>
383
384 =head1 SEE ALSO
385
386 L<YAML::Tiny>, L<YAML>, L<YAML::Syck>
387
388 =head1 COPYRIGHT
389
390 Copyright 2006 - 2009 Adam Kennedy.
391
392 This program is free software; you can redistribute
393 it and/or modify it under the same terms as Perl itself.
394
395 The full text of the license can be found in the
396 LICENSE file included with this module.
397
398 =cut