Makefile-DOM-0.006/0000755000175000001440000000000011626450365013070 5ustar agentzusersMakefile-DOM-0.006/Changes0000644000175000001440000000112411626450206014353 0ustar agentzusers0.006 2011-08-28 * Fixed a syntax error in the POD documentation. thanks Mikhail Gusarov. 0.005 2011-08-10 * Updated the author name, author email address, and code repository in the documentation. * Updated the bundled Module::Install to the latest version, 1.01. 0.004 2008-03-10 * Added pointer for Makefile::Parser::GmakeDB to Makefile::DOM's POD. 0.003 2008-03-10 * Removed script/pgmake and script/plmake from MANIFEST. * Tweaked the POD a bit. 0.002 2008-03-07 * Added comprehensive POD to Makefile::DOM. * Fixed the POD in MDOM::Dumper. 0.001 2008-03-07 * inital CPAN release Makefile-DOM-0.006/Makefile.PL0000644000175000001440000000164711626447306015053 0ustar agentzusersuse strict; use lib '.'; use inc::Module::Install; name ('Makefile-DOM'); #requires (perl => '5.006001'); perl_version ('5.006001'); all_from ('lib/Makefile/DOM.pm'); repository 'http://github.com/agentzh/makefile-dom-pm'; #install_script ('script/pgmake'); requires ('List::MoreUtils' => '0.21'); requires ('Params::Util' => '0.22'); #requires ('Scalar::Util' => '1.17'); #requires ('Text::Balanced' => '1.95'); requires ('Clone' => '0.18'); #build_requires ('Test::More' => '0.62'); #build_requires ('IPC::Run3' => '0.036'); #build_requires ('File::Temp' => '0.16'); #build_requires ('File::Spec' => '3.12'); #build_requires ('Cwd' => '3.12'); #build_requiers ('FindBin' => '1.47'); use_test_base; tests('t/*.t t/mdom/*.t t/mdom/*/*.t'); # t/*/*.t t/*/*/*t t/*/*/*/*.t'); auto_install; WriteAll; Makefile-DOM-0.006/MANIFEST0000644000175000001440000000322311626447661014226 0ustar agentzusersChanges inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/TestBase.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm inc/Spiffy.pm inc/Test/Base.pm inc/Test/Base/Filter.pm inc/Test/Builder.pm inc/Test/Builder/Module.pm inc/Test/More.pm lib/Makefile/DOM.pm lib/MDOM/Assignment.pm lib/MDOM/Command.pm lib/MDOM/Directive.pm lib/MDOM/Document.pm lib/MDOM/Document/Gmake.pm lib/MDOM/Dumper.pm lib/MDOM/Element.pm lib/MDOM/Node.pm lib/MDOM/Rule.pm lib/MDOM/Rule/Simple.pm lib/MDOM/Rule/StaticPattern.pm lib/MDOM/Token.pm lib/MDOM/Token/Bare.pm lib/MDOM/Token/Comment.pm lib/MDOM/Token/Continuation.pm lib/MDOM/Token/Interpolation.pm lib/MDOM/Token/Modifier.pm lib/MDOM/Token/Separator.pm lib/MDOM/Token/Whitespace.pm lib/MDOM/Unknown.pm lib/MDOM/Util.pm Makefile.PL MANIFEST MANIFEST.SKIP META.yml README script/checkenv script/mdom-dump script/p4_to_t.pl script/sh t/pod-coverage.t t/pod.t t/Gmake.pm t/GmakeDOM.pm t/lib/Test/Make/Base.pm t/lib/Test/Make/Util.pm t/lib/Test/Util.pm t/lib/Test/Util/Base.pm t/mdom/assignment.t t/mdom/gmake/assignment.t t/mdom/gmake/command.t t/mdom/gmake/comment.t t/mdom/gmake/directive-define.t t/mdom/gmake/directive-export.t t/mdom/gmake/directive-include.t t/mdom/gmake/directive-vpath.t t/mdom/gmake/interpolation.t t/mdom/gmake/misc.t t/mdom/gmake/order_only.t t/mdom/gmake/rule-simple.t t/mdom/gmake/rule-static-pattern.t t/mdom/gmake/unknown.t t/mdom/node.t t/mdom/rule-simple.t t/mdom/token.t t/Shell.pm TODO Makefile-DOM-0.006/lib/0000755000175000001440000000000011626450365013636 5ustar agentzusersMakefile-DOM-0.006/lib/Makefile/0000755000175000001440000000000011626450365015353 5ustar agentzusersMakefile-DOM-0.006/lib/Makefile/DOM.pm0000644000175000001440000002323611626450310016324 0ustar agentzuserspackage Makefile::DOM; use strict; use warnings; our $VERSION = '0.006'; use MDOM::Document; use MDOM::Element; use MDOM::Node; use MDOM::Rule; use MDOM::Token; use MDOM::Command; use MDOM::Assignment; use MDOM::Unknown; use MDOM::Directive; 1; __END__ =encoding utf-8 =head1 NAME Makefile::DOM - Simple DOM parser for Makefiles =head1 VERSION This document describes Makefile::DOM 0.006 released on 28 August 2011. =head1 DESCRIPTION This libary can serve as an advanced lexer for (GNU) makefiles. It parses makefiles as "documents" and the parsing is lossless. The results are data structures similar to DOM trees. The DOM trees hold every single bit of the information in the original input files, including white spaces, blank lines and makefile comments. That means it's possible to reproduce the original makefiles from the DOM trees. In addition, each node of the DOM trees is modifiable and so is the whole tree, just like the L module used for Perl source parsing and the L module used for parsing HTML source. If you're looking for a true GNU make parser that generates an AST, please see L instead. The interface of C mimics the API design of L. In fact, I've directly stolen the source code and POD documentation of L, L, and L, with the full permission from the author of L, Adam Kennedy. C tries to be independent of specific makefile's syntax. The same set of DOM node types is supposed to get shared by different makefile DOM generators. For example, L parses GNU makefiles and returns an instance of L, i.e., the root of the DOM tree while the NMAKE makefile lexer in the future, C, also returns instances of the L class. Later, I'll also consider adding support for dmake and bsdmake. =head1 Structure of the DOM Makefile DOM (MDOM) is a structured set of a series of data types. They provide a flexible document model conformed to the makefile syntax. Below is a complete list of the 19 MDOM classes in the current implementation where the indentation indicates the class inheritance relationships. MDOM::Element MDOM::Node MDOM::Unknown MDOM::Assignment MDOM::Command MDOM::Directive MDOM::Document MDOM::Document::Gmake MDOM::Rule MDOM::Rule::Simple MDOM::Rule::StaticPattern MDOM::Token MDOM::Token::Bare MDOM::Token::Comment MDOM::Token::Continuation MDOM::Token::Interpolation MDOM::Token::Modifier MDOM::Token::Separator MDOM::Token::Whitespace It's not hard to see that all of the MDOM classes inherit from the L class. L and L are its direct children. The former represents a string token which is atomic from the perspective of the lexer while the latter represents a structured node, which usually has one or more children, and serves as the container for other L objects. Next we'll show a few examples to demonstrate how to map DOM trees to particular makefiles. =over =item Case 1 Consider the following simple "hello, world" makefile: all : ; echo "hello, world" We can use the L class provided by L to dump out the internal structure of its corresponding MDOM tree: MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo "hello, world"' MDOM::Token::Whitespace '\n' In this example, speparators C<:> and C<;> are all instances of the L class while spaces and new line characters are all represented as L. The other two leaf nodes, C and C both belong to L. It's worth mentioning that, the space characters in the rule command C were not represented as L. That's because in makefiles, the spaces in commands do not make any sense to C in syntax; those spaces are usually sent to shell programs verbatim. Therefore, the DOM parser does not try to recognize those spaces specifially so as to reduce memory use and the number of nodes. However, leading spaces and trailing new lines will still be recognized as L. On a higher level, it's a L instance holding several C and one L. On the highest level, it's the root node of the whole DOM tree, i.e., an instance of L. =item Case 2 Below is a relatively complex example: a: foo.c bar.h $(baz) # hello! @echo ... It's corresponding DOM structure is MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo.c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar.h' MDOM::Token::Whitespace '\t' MDOM::Token::Interpolation '$(baz)' MDOM::Token::Whitespace ' ' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Bare 'echo ...' MDOM::Token::Whitespace '\n' Compared to the previous example, here appears several new node types. The variable interpolation C<$(baz)> on the first line of the original makefile corresponds to a L node in its MDOM tree. Similarly, the comment C<# hello> corresponds to a L node. On the second line, the rule command indented by a tab character is still represented by a L object. Its first child node (or its first element) is also an L instance corresponding to that tab. The command modifier C<@> follows the C immediately, which is of type L. =item Case 3 Now let's study a sample makefile with various global structures: a: b foo = bar # hello! Here on the top level, there are three language structures: one rule "C", one assignment statement "foo = bar", and one comment C<# hello!>. Its MDOM tree is shown below: MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace '\n' MDOM::Assignment MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\t' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' We can see that below the root node L, there are L, L, and L three elements, as well as two L objects. =back It can be observed from the examples above that the MDOM representation for the makefile's lexical elements is rather loose. It only provides very limited structural representation instead of making a bad guess. =head1 OPERATIONS FOR MDOM TREES Generating an MDOM tree from a GNU makefile only requires two lines of Perl code: use MDOM::Document::Gmake; my $dom = MDOM::Document::Gmake->new('Makefile'); If the makefile source code being parsed is already stored in a Perl variable, say, C<$var>, then we can construct an MDOM via the following code: my $dom = MDOM::Document::Gmake->new(\$var); Now C<$dom> becomes the reference to the root of the MDOM tree and its type is now L, which is also an instance of the L class. Just as mentioned above, C is the container for other L instances. So we can retrieve some element node's value via its C method: $node = $dom->child(3); # or $node = $dom->elements(0); And we may also use the C method to obtain the values of all the nodes: @elems = $dom->elements; For every MDOM node, its corresponding makefile source can be generated by invoking its C method. =head1 BUGS AND TODO The current implemenation of the L lexer is based on a hand-written state machie. Although the efficiency of the engine is not bad, the code is rather complicated and messy, which hurts both extensibility and maintanabilty. So it's expected to rewrite the parser using some grammatical tools like the Perl 6 regex engine L or a yacc-style one like L. =head1 SOURCE REPOSITORY You can always get the latest source code of this module from its GitHub repository: L If you want a commit bit, please let me know. =head1 AUTHOR Zhang "agentzh" Yichun (章亦春) Eagentzh@gmail.comE =head1 COPYRIGHT Copyright 2006-2011 by Zhang "agentzh" Yichun (章亦春). This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, L. Makefile-DOM-0.006/lib/MDOM/0000755000175000001440000000000011626450365014372 5ustar agentzusersMakefile-DOM-0.006/lib/MDOM/Dumper.pm0000644000175000001440000001627111626450246016171 0ustar agentzuserspackage MDOM::Dumper; =pod =head1 NAME MDOM::Dumper - Dumping of MDOM trees =head1 SYNOPSIS # Load a document my $Module = MDOM::Document->new( 'MyMakefile' ); # Create the dumper my $Dumper = MDOM::Dumper->new( $Module ); # Dump the document $Dumper->print; =head1 DESCRIPTION The MDOM trees in MDOM are quite complex, and getting a dump of their structure for development and debugging purposes is important. This module provides that functionality. The process is relatively simple. Create a dumper object with a particular set of options, and then call one of the dump methods to generate the dump content itself. =head1 METHODS =cut use strict; use Params::Util '_INSTANCE'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.006'; } ##################################################################### # Constructor =pod =head2 new $Element, param => value, ... The C constructor creates a dumper, and takes as argument a single L object of any type to serve as the root of the tree to be dumped, and a number of key-Evalue parameters to control the output format of the Dumper. Details of the parameters are listed below. Returns a new C object, or C if the constructor is not passed a correct L root object. =over =item memaddr Should the dumper print the memory addresses of each MDOM element. True/false value, off by default. =item indent Should the structures being dumped be indented. This value is numeric, with the number representing the number of spaces to use when indenting the dumper output. Set to '2' by default. =item class Should the dumper print the full class for each element. True/false value, on by default. =item content Should the dumper show the content of each element. True/false value, on by default. =item whitespace Should the dumper show whitespace tokens. By not showing the copious numbers of whitespace tokens the structure of the code can often be made much clearer. True/false value, on by default. =item comments Should the dumper show comment tokens. In situations where you have a lot of comments, the code can often be made clearer by ignoring comment tokens. True/value value, on by default. =item locations Should the dumper show the location of each token. The values shown are [ line, rowchar, column ]. See L for a description of what these values really are. True/false value, off by default. =back =cut sub new { my $class = shift; my $Element = _INSTANCE(shift, 'MDOM::Element') or return undef; # Create the object my $self = bless { root => $Element, display => { memaddr => '', # Show the refaddr of the item indent => 2, # Indent the structures class => 1, # Show the object class content => 1, # Show the object contents whitespace => 1, # Show whitespace tokens comments => 1, # Show comment tokens locations => 0, # Show token locations }, }, $class; # Handle the options my %options = map { lc $_ } @_; foreach ( keys %{$self->{display}} ) { if ( exists $options{$_} ) { if ( $_ eq 'indent' ) { $self->{display}->{indent} = $options{$_}; } else { $self->{display}->{$_} = !! $options{$_}; } } } $self->{indent_string} = join '', (' ' x $self->{display}->{indent}); # Try to auto-call index_locations. If it failes, turn of locations display if ( $self->{display}->{locations} ) { my $Document = $Element->isa('MDOM::Document') ? $Element : $Element->top; if ( $Document->isa('MDOM::Document') ) { $Document->index_locations(); } else { $self->{display}->{locations} = 0; } } $self; } ##################################################################### # Main Interface Methods =pod =head2 print The C method generates the dump and prints it to STDOUT. Returns as for the internal print function. =cut sub print { CORE::print(shift->string); } =pod =head2 string The C method generates the dump and provides it as a single string. Returns a string or undef if there is an error while generating the dump. =cut sub string { my $array_ref = shift->_dump or return undef; join '', map { "$_\n" } @$array_ref; } =pod =head2 list The C method generates the dump and provides it as a raw list, without trailing newlines. Returns a list or the null list if there is an error while generation the dump. =cut sub list { my $array_ref = shift->_dump or return (); @$array_ref; } ##################################################################### # Generation Support Methods sub _dump { my $self = ref $_[0] ? shift : shift->new(shift); my $Element = _INSTANCE($_[0], 'MDOM::Element') ? shift : $self->{root}; my $indent = shift || ''; my $output = shift || []; # Print the element if needed my $show = 1; if ( $Element->isa('MDOM::Token::Whitespace') ) { $show = 0 unless $self->{display}->{whitespace}; } elsif ( $Element->isa('MDOM::Token::Comment') ) { $show = 0 unless $self->{display}->{comments}; } push @$output, $self->_element_string( $Element, $indent ) if $show; # Recurse into our children if ( $Element->isa('MDOM::Node') ) { my $child_indent = $indent . $self->{indent_string}; foreach my $child ( @{$Element->{children}} ) { $self->_dump( $child, $child_indent, $output ); } } $output; } sub _element_string { my $self = ref $_[0] ? shift : shift->new(shift); my $Element = _INSTANCE($_[0], 'MDOM::Element') ? shift : $self->{root}; my $indent = shift || ''; my $string = ''; # Add the memory location if ( $self->{display}->{memaddr} ) { $string .= $Element->refaddr . ' '; } # Add the location if such exists if ( $self->{display}->{locations} ) { my $loc_string; if ( $Element->isa('MDOM::Token') ) { my $location = $Element->location; if ($location) { $loc_string = sprintf("[ % 4d, % 3d, % 3d ] ", @$location); } } # Output location or pad with 20 spaces $string .= $loc_string || " " x 20; } # Add the indent if ( $self->{display}->{indent} ) { $string .= $indent; } # Add the class name if ( $self->{display}->{class} ) { $string .= ref $Element; } if ( $Element->isa('MDOM::Token') ) { # Add the content if ( $self->{display}->{content} ) { my $content = $Element->content; $content =~ s/\n/\\n/g; $content =~ s/\t/\\t/g; $content =~ s/'/\\'/g; $content =~ s/\r/\\r/g; $string .= " \t'$content'"; } } elsif ( $Element->isa('MDOM::Structure') ) { # Add the content if ( $self->{display}->{content} ) { my $start = $Element->start ? $Element->start->content : '???'; my $finish = $Element->finish ? $Element->finish->content : '???'; $string .= " \t$start ... $finish"; } } $string; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE Zhang "agentzh" Yichun C<< >> =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/lib/MDOM/Element.pm0000644000175000001440000004527211626450246016331 0ustar agentzuserspackage MDOM::Element; =pod =head1 NAME MDOM::Element - The abstract Element class, a base for all source objects =head1 INHERITANCE MDOM::Element is the root of the PDOM tree =head1 DESCRIPTION The abstract C serves as a base class for all source-related objects, from a single whitespace token to an entire document. It provides a basic set of methods to provide a common interface and basic implementations. =head1 METHODS =cut use strict; use Scalar::Util 'refaddr'; use Params::Util '_INSTANCE', '_ARRAY'; use MDOM::Node (); use Clone (); use List::MoreUtils (); use overload 'bool' => sub () { 1 }, '""' => 'content', '==' => '__equals', '!=' => '__nequals', 'eq' => '__eq', 'ne' => '__ne'; use vars qw{$VERSION $errstr %_PARENT}; BEGIN { $VERSION = '0.006'; $errstr = ''; # Master Child -> Parent index %_PARENT = (); } ##################################################################### # General Properties =pod =head2 significant Because we treat whitespace and other non-code items as Tokens (in order to be able to "round trip" the L back to a file) the C method allows us to distinguish between tokens that form a part of the code, and tokens that aren't significant, such as whitespace, POD, or the portion of a file after (and including) the C<__END__> token. Returns true if the Element is significant, or false it not. =cut ### XS -> MDOM/XS.xs:_MDOM_Element__significant 0.845+ sub significant { 1 } sub lineno { $_[0]->{lineno}; } =pod =head2 class The C method is provided as a convenience, and really does nothing more than returning C. However, some people have found that they appreciate the laziness of C<$Foo-Eclass eq 'whatever'>, so I have caved to popular demand and included it. Returns the class of the Element as a string =cut sub class { ref($_[0]) } =pod =head2 tokens The C method returns a list of L objects for the Element, essentially getting back that part of the document as if it had not been lexed. This also means there are no Statements and no Structures in the list, just the Token classes. =cut sub tokens { $_[0] } =pod =head2 content For B C, the C method will reconstitute the base code for it as a single string. This method is also the method used for overloading stringification. When an Element is used in a double-quoted string for example, this is the method that is called. B You should be aware that because of the way that here-docs are handled, any here-doc content is not included in C, and as such you should B eval or execute the result if it contains any L. The L method C should be used to stringify a PDOM document into something that can be executed as expected. Returns the basic code as a string (excluding here-doc content). =cut ### XS -> MDOM/XS.xs:_MDOM_Element__content 0.900+ sub content { '' } ##################################################################### # Naigation Methods =pod =head2 parent Elements themselves are not intended to contain other Elements, that is left to the L abstract class, a subclass of C. However, all Elements can be contained B a parent Node. If an Element is within a parent Node, the C method returns the Node. =cut sub parent { $_PARENT{refaddr $_[0]} } =pod =head2 statement For a C that is contained (at some depth) within a L, the C method will return the first parent Statement object lexically 'above' the Element. Returns a L object, which may be the same Element if the Element is itself a L object. Returns false if the Element is not within a Statement and is not itself a Statement. =cut sub statement { my $cursor = shift; while ( ! _INSTANCE($cursor, 'MDOM::Statement') ) { $cursor = $_PARENT{refaddr $cursor} or return ''; } $cursor; } =pod =head2 top For a C that is contained within a PDOM tree, the C method will return the top-level Node in the tree. Most of the time this should be a L object, however this will not always be so. For example, if a subroutine has been removed from its Document, to be moved to another Document. Returns the top-most PDOM object, which may be the same Element, if it is not within any parent PDOM object. =cut sub top { my $cursor = shift; while ( my $parent = $_PARENT{refaddr $cursor} ) { $cursor = $parent; } $cursor; } =pod For an Element that is contained within a L object, the C method will return the top-level Document for the Element. Returns the L for this Element, or false if the Element is not contained within a Document. =cut sub document { my $top = shift->top; _INSTANCE($top, 'MDOM::Document') and $top; } =pod =head2 next_sibling All L objects (specifically, our parent Node) contain a number of C objects. The C method returns the C immediately after the current one, or false if there is no next sibling. =cut sub next_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; $elements->[$position + 1] || ''; } =pod =head2 snext_sibling As per the other 's' methods, the C method returns the next B sibling of the C object. Returns a C object, or false if there is no 'next' significant sibling. =cut sub snext_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; while ( defined(my $it = $elements->[++$position]) ) { return $it if $it->significant; } ''; } =pod =head2 previous_sibling All L objects (specifically, our parent Node) contain a number of C objects. The C method returns the Element immediately before the current one, or false if there is no 'previous' C object. =cut sub previous_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; $position and $elements->[$position - 1] or ''; } =pod =head2 sprevious_sibling As per the other 's' methods, the C method returns the previous B sibling of the C object. Returns a C object, or false if there is no 'previous' significant sibling. =cut sub sprevious_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; while ( $position-- and defined(my $it = $elements->[$position]) ) { return $it if $it->significant; } ''; } =pod =head2 first_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the first MDOM::Token object within or equal to this one. That is, if called on a L subclass, it will descend until it finds a L. If called on a L object, it will return the same object. Returns a L object, or dies on error (which should be extremely rare and only occur if an illegal empty L exists below the current Element somewhere. =cut sub first_token { my $cursor = shift; while ( $cursor->isa('MDOM::Node') ) { $cursor = $cursor->first_element or die "Found empty MDOM::Node while getting first token"; } $cursor; } =pod =head2 last_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the last MDOM::Token object within or equal to this one. That is, if called on a L subclass, it will descend until it finds a L. If called on a L object, it will return the itself. Returns a L object, or dies on error (which should be extremely rare and only occur if an illegal empty L exists below the current Element somewhere. =cut sub last_token { my $cursor = shift; while ( $cursor->isa('MDOM::Node') ) { $cursor = $cursor->last_element or die "Found empty MDOM::Node while getting first token"; } $cursor; } =pod =head2 next_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the L object that is immediately after the current Element, even if it is not within the same parent L as the one for which the method is being called. Note that this is B defined as a L-specific method, because it can be useful to find the next token that is after, say, a L, although obviously it would be useless to want the next token after a L. Returns a L object, or false if there are no more tokens after the Element. =cut sub next_token { my $cursor = shift; # Find the next element, going upwards as needed while ( 1 ) { my $element = $cursor->next_sibling; if ( $element ) { return $element if $element->isa('MDOM::Token'); return $element->first_token; } $cursor = $cursor->parent or return ''; if ( $cursor->isa('MDOM::Structure') and $cursor->finish ) { return $cursor->finish; } } } =pod =head2 previous_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the L object that is immediately before the current Element, even if it is not within the same parent L as this one. Note that this is not defined as a L-only method, because it can be useful to find the token is before, say, a L, although obviously it would be useless to want the next token before a L. Returns a L object, or false if there are no more tokens before the C. =cut sub previous_token { my $cursor = shift; # Find the previous element, going upwards as needed while ( 1 ) { my $element = $cursor->previous_sibling; if ( $element ) { return $element if $element->isa('MDOM::Token'); return $element->last_token; } $cursor = $cursor->parent or return ''; if ( $cursor->isa('MDOM::Structure') and $cursor->start ) { return $cursor->start; } } } ##################################################################### # Manipulation =pod =head2 clone As per the L module, the C method makes a perfect copy of an Element object. In the generic case, the implementation is done using the L module's mechanism itself. In higher-order cases, such as for Nodes, there is more work involved to keep the parent-child links intact. =cut sub clone { Clone::clone(shift); } =pod =head2 insert_before @Elements The C method allows you to insert lexical perl content, in the form of C objects, before the calling C. You need to be very careful when modifying perl code, as it's easy to break things. In its initial incarnation, this method allows you to insert a single Element, and will perform some basic checking to prevent you inserting something that would be structurally wrong (in PDOM terms). In future, this method may be enhanced to allow the insertion of multiple Elements, inline-parsed code strings or L objects. Returns true if the Element was inserted, false if it can not be inserted, or C if you do not provide a L object as a parameter. =cut sub __insert_before { my $self = shift; $self->parent->__insert_before_child( $self, @_ ); } =pod =head2 insert_after @Elements The C method allows you to insert lexical perl content, in the form of C objects, after the calling C. You need to be very careful when modifying perl code, as it's easy to break things. In its initial incarnation, this method allows you to insert a single Element, and will perform some basic checking to prevent you inserting something that would be structurally wrong (in PDOM terms). In future, this method may be enhanced to allow the insertion of multiple Elements, inline-parsed code strings or L objects. Returns true if the Element was inserted, false if it can not be inserted, or C if you do not provide a L object as a parameter. =cut sub __insert_after { my $self = shift; $self->parent->__insert_after_child( $self, @_ ); } =pod =head2 remove For a given C, the C method will remove it from its parent B, along with all of its children. Returns the C itself as a convenience, or C if an error occurs while trying to remove the C. =cut sub remove { my $self = shift; my $parent = $self->parent or return $self; $parent->remove_child( $self ); } =pod =head2 delete For a given C, the C method will remove it from its parent, immediately deleting the C and all of its children (if it has any). Returns true if the C was successfully deleted, or C if an error occurs while trying to remove the C. =cut sub delete { $_[0]->remove or return undef; $_[0]->DESTROY; 1; } =pod =head2 replace $Element Although some higher level class support more exotic forms of replace, at the basic level the C method takes a single C as an argument and replaces the current C with it. To prevent accidental damage to code, in this initial implementation the replacement element B be of the same class (or a subclass) as the one being replaced. =cut sub replace { my $self = ref $_[0] ? shift : return undef; my $Element = _INSTANCE(shift, ref $self) or return undef; die "The ->replace method has not yet been implemented"; } =pod =head2 location If the Element exists within a L that has indexed the Element locations using C, the C method will return the location of the first character of the Element within the Document. Returns the location as a reference to a three-element array in the form C<[ $line, $rowchar, $col ]>. The values are in a human format, with the first character of the file located at C<[ 1, 1, 1 ]>. The second and third numbers are similar, except that the second is the literal horizontal character, and the third is the visual column, taking into account tabbing. Returns C on error, or if the L object has not been indexed. =cut sub location { my $self = shift; unless ( exists $self->{_location} ) { # Are we inside a normal document? my $Document = $self->document or return undef; if ( $Document->isa('MDOM::Document::Fragment') ) { # Because they can't be serialized, document fragments # do not support the concept of location. return undef; } # Generate the locations. If they need one location, then # the chances are they'll want more, and it's better that # everything is already pre-generated. $Document->index_locations or return undef; unless ( exists $self->{_location} ) { # erm... something went very wrong here return undef; } } # Return a copy, not the original return [ @{$self->{_location}} ]; } # Although flush_locations is only publically a Document-level method, # we are able to implement it at an Element level, allowing us to # selectively flush only the part of the document that occurs after the # element for which the flush is called. sub _flush_locations { my $self = shift; unless ( $self == $self->top ) { return $self->top->_flush_locations( $self ); } # Get the full list of all Tokens my @Tokens = $self->tokens; # Optionally allow starting from an arbitrary element (or rather, # the first Token equal-to-or-within an arbitrary element) if ( _INSTANCE($_[0], 'MDOM::Element') ) { my $start = shift->first_token; while ( my $Token = shift @Tokens ) { return 1 unless $Token->{_location}; next unless refaddr($Token) == refaddr($start); # Found the start. Flush it's location delete $$Token->{_location}; last; } } # Iterate over any remaining Tokens and flush their location foreach my $Token ( @Tokens ) { delete $Token->{_location}; } 1; } ##################################################################### # XML Compatibility Methods sub _xml_name { my $class = ref $_[0] || $_[0]; my $name = lc join( '_', split /::/, $class ); substr($name, 4); } sub _xml_attr { return {}; } sub _xml_content { defined $_[0]->{content} ? $_[0]->{content} : ''; } ##################################################################### # Internals # Set the error string sub _error { $errstr = $_[1]; undef; } # Clear the error string sub _clear { $errstr = ''; $_[0]; } # Being DESTROYed in this manner, rather than by an explicit # ->delete means our reference count has probably fallen to zero. # Therefore we don't need to remove ourselves from our parent, # just the index ( just in case ). ### XS -> MDOM/XS.xs:_MDOM_Element__DESTROY 0.900+ sub DESTROY { delete $_PARENT{refaddr $_[0]} } # Operator overloads sub __equals { ref $_[1] and refaddr($_[0]) == refaddr($_[1]) } sub __nequals { !__equals(@_) } sub __eq { my $self = _INSTANCE($_[0], 'MDOM::Element') ? $_[0]->content : $_[0]; my $other = _INSTANCE($_[1], 'MDOM::Element') ? $_[1]->content : $_[1]; $self eq $other; } sub __ne { !__eq(@_) } 1; =pod =head1 TO DO It would be nice if C could be used in an ad-hoc manner. That is, if called on an Element within a Document that has not been indexed, it will do a one-off calculation to find the location. It might be very painful if someone started using it a lot, without remembering to index the document, but it would be handy for things that are only likely to use it once, such as error handlers. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/lib/MDOM/Rule.pm0000644000175000001440000000020311626450246015630 0ustar agentzuserspackage MDOM::Rule; use strict; use warnings; use base 'MDOM::Node'; use MDOM::Rule::Simple; use MDOM::Rule::StaticPattern; 1; Makefile-DOM-0.006/lib/MDOM/Document.pm0000644000175000001440000000010411626450246016477 0ustar agentzuserspackage MDOM::Document; use strict; use warnings; sub new { } 1; Makefile-DOM-0.006/lib/MDOM/Rule/0000755000175000001440000000000011626450365015301 5ustar agentzusersMakefile-DOM-0.006/lib/MDOM/Rule/Simple.pm0000644000175000001440000000355411626450246017075 0ustar agentzuserspackage MDOM::Rule::Simple; use strict; use warnings; #use Smart::Comments; use base 'MDOM::Rule'; use MDOM::Util qw( trim_tokens ); sub targets { my ($self) = @_; $self->_parse if !$self->{colon}; my $tokens = $self->{targets}; wantarray ? @$tokens : $tokens; } sub normal_prereqs { my ($self) = @_; $self->_parse if !$self->{colon}; my $tokens = $self->{normal_prereqs}; wantarray ? @$tokens : $tokens; } sub order_prereqs { my ($self) = @_; $self->_parse if !$self->{colon}; my $tokens = $self->{order_prereqs}; wantarray ? @$tokens : $tokens; } sub colon { my ($self) = @_; $self->_parse if !$self->{colon}; $self->{colon}; } sub command { my ($self) = @_; $self->_parse if !$self->{colon}; $self->{command}; } sub _parse { my ($self) = @_; my @elems = $self->elements; my (@targets, $colon, @normal_prereqs, @order_prereqs, $command); my $prereqs = \@normal_prereqs; ## @elems for my $elem (@elems) { if (!$colon) { if ($elem->class eq 'MDOM::Token::Separator') { $colon = $elem->content; } else { push @targets, $elem; } } elsif ($elem->class eq 'MDOM::Token::Comment') { last; } elsif ($elem->class eq 'MDOM::Command') { $command = $elem; last; } elsif ($elem->class eq 'MDOM::Token::Bare' and $elem->content eq '|') { $prereqs = \@order_prereqs; } else { push @$prereqs, $elem; } } trim_tokens(\@targets); trim_tokens(\@normal_prereqs); trim_tokens(\@order_prereqs); $self->{targets} = \@targets; $self->{colon} = $colon; $self->{normal_prereqs} = \@normal_prereqs; $self->{order_prereqs} = \@order_prereqs; $self->{command} = $command; ### $self } 1; Makefile-DOM-0.006/lib/MDOM/Rule/StaticPattern.pm0000644000175000001440000000011311626450246020415 0ustar agentzuserspackage MDOM::Rule::StaticPattern; use strict; use base 'MDOM::Rule'; 1; Makefile-DOM-0.006/lib/MDOM/Token.pm0000644000175000001440000001031711626450246016010 0ustar agentzuserspackage MDOM::Token; =pod =head1 NAME MDOM::Token - A single token of Makefile source code =head1 INHERITANCE MDOM::Token isa MDOM::Element =head1 DESCRIPTION C is the abstract base class for all Tokens. In MDOM terms, a "Token" is a L that directly represents bytes of source code. The implementation and POD are borrowed directly from L. =head1 METHODS =cut use strict; use base 'MDOM::Element'; use Params::Util '_INSTANCE'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.006'; } # We don't load the abstracts, they are loaded # as part of the 'use base' statements. # Load the token classes use MDOM::Token::Whitespace (); use MDOM::Token::Comment (); use MDOM::Token::Separator (); use MDOM::Token::Continuation (); use MDOM::Token::Bare (); use MDOM::Token::Interpolation (); use MDOM::Token::Modifier (); ##################################################################### # Constructor and Related sub new { if ( @_ == 2 ) { # MDOM::Token->new( $content ); my $class; if ($_[0] eq __PACKAGE__) { $class = 'MDOM::Token::Bare'; shift; } else { $class = shift; } return bless { content => (defined $_[0] ? "$_[0]" : ''), lineno => $., }, $class; } elsif ( @_ == 3 ) { # MDOM::Token->new( $class, $content ); my $class = substr( $_[0], 0, 12 ) eq 'MDOM::Token::' ? $_[1] : "MDOM::Token::$_[1]"; return bless { content => (defined $_[2] ? "$_[2]" : ''), lineno => $., }, $class; } # Invalid argument count undef; } sub set_class { my $self = shift; @_ or return undef; my $class = substr( $_[0], 0, 12 ) eq 'MDOM::Token::' ? shift : 'MDOM::Token::' . shift; # Find out if the current and new classes are complex my $old_quote = (ref($self) =~ /\b(?:Quote|Regex)\b/o) ? 1 : 0; my $new_quote = ($class =~ /\b(?:Quote|Regex)\b/o) ? 1 : 0; # No matter what happens, we will have to rebless bless $self, $class; # If we are changing to or from a Quote style token, we # can't just rebless and need to do some extra thing # Otherwise, we have done enough return 1 if ($old_quote - $new_quote) == 0; # Make a new token from the old content, and overwrite the current # token's attributes with the new token's attributes. my $token = $class->new( $self->{content} ) or return undef; delete $self->{$_} foreach keys %$self; $self->{$_} = $token->{$_} foreach keys %$token; 1; } ##################################################################### # MDOM::Token Methods =pod =head2 set_content $string The C method allows to set/change the string that the C object represents. Returns the string you set the Token to =cut sub set_content { $_[0]->{content} = $_[1]; } =pod =head2 add_content $string The C method allows you to add additional bytes of code to the end of the Token. Returns the new full string after the bytes have been added. =cut sub add_content { $_[0]->{content} .= $_[1] } =pod =head2 length The C method returns the length of the string in a Token. =cut sub length { &CORE::length($_[0]->{content}) } ##################################################################### # Overloaded MDOM::Element methods sub content { $_[0]->{content}; } # You can insert either a statement, or a non-significant token. sub insert_before { my $self = shift; my $Element = _INSTANCE(shift, 'MDOM::Element') or return undef; if ( $Element->isa('MDOM::Structure') ) { return $self->__insert_before($Element); } elsif ( $Element->isa('MDOM::Token') ) { return $self->__insert_before($Element); } ''; } # As above, you can insert a statement, or a non-significant token sub insert_after { my $self = shift; my $Element = _INSTANCE(shift, 'MDOM::Element') or return undef; if ( $Element->isa('MDOM::Structure') ) { return $self->__insert_after($Element); } elsif ( $Element->isa('MDOM::Token') ) { return $self->__insert_after($Element); } ''; } =pod =head2 source Returns the makefile source for the current token =cut sub source { my $self = shift; return $self->content; } 1; Makefile-DOM-0.006/lib/MDOM/Document/0000755000175000001440000000000011626450365016150 5ustar agentzusersMakefile-DOM-0.006/lib/MDOM/Document/Gmake.pm0000644000175000001440000003752211626450246017541 0ustar agentzuserspackage MDOM::Document::Gmake; use strict; use warnings; #use Smart::Comments; #use Smart::Comments '###', '####'; use Text::Balanced qw( gen_extract_tagged ); use Makefile::DOM; #use Data::Dump::Streamer; use base 'MDOM::Node'; use List::MoreUtils qw( before all any ); use List::Util qw( first ); my %_map; BEGIN { %_map = ( COMMENT => 1, # context for parsing multi-line comments COMMAND => 2, # context for parsing multi-line commands RULE => 3, # context for parsing rules VOID => 4, # void context UNKNOWN => 5, # context for parsing unexpected constructs ); } use constant \%_map; my %_rev_map = reverse %_map; my @keywords = qw( vpath include sinclude ifdef ifndef else endif define endef export unexport ); my $extract_interp_1 = gen_extract_tagged('\$[(]', '[)]', ''); my $extract_interp_2 = gen_extract_tagged('\$[{]', '[}]', ''); sub extract_interp { my ($res) = $extract_interp_1->($_[0]); if (!$res) { ($res) = $extract_interp_2->($_[0]); } $res; } my ($context, $saved_context); sub new { my $class = ref $_[0] ? ref shift : shift; my $input = shift; return undef if !defined $input; my $in; if (ref $input) { open $in, '<', $input or die; } else { open $in, $input or die "Can't open $input for reading: $!"; } my $self = $class->SUPER::new; $self->_tokenize($in); $self; } sub _tokenize { my ($self, $fh) = @_; $context = VOID; my @tokens; while (<$fh>) { ### Tokenizing : $_ ### ...with context : $_rev_map{$context} s/\r\n/\n/g; $_ .= "\n" if !/\n$/s; if ($context == VOID || $context == RULE) { if ($context == VOID && s/(?x) ^ (\t\s*) (?= \# ) //) { ### Found comment in VOID context... @tokens = ( MDOM::Token::Whitespace->new($1), _tokenize_comment($_) ); if ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Switching context to COMMENT... $saved_context = $context; $context = COMMENT; $tokens[-2]->add_content("\\\n"); pop @tokens; } $self->__add_elements( @tokens ); } elsif ($context == RULE and s/^\t//) { ### Found a command in RULE context... @tokens = _tokenize_command($_); #warn "*@tokens*"; ### Tokens for the command: @tokens unshift @tokens, MDOM::Token::Separator->new("\t"); if ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Switching context to COMMAND... $saved_context = $context; $context = COMMAND; pop @tokens; if ($tokens[-1]->class =~ /Bare$/) { $tokens[-1]->add_content("\\\n"); } else { push @tokens, MDOM::Token::Bare->new("\\\n"); } } my $cmd = MDOM::Command->new; $cmd->__add_elements(@tokens); $self->__add_element($cmd); ### command (post): $cmd next; } else { @tokens = _tokenize_normal($_); if (@tokens >= 2 && $tokens[-1]->isa('MDOM::Token::Continuation') && $tokens[-2]->isa('MDOM::Token::Comment')) { ### Found a trailing comment... ### Switching conext to COMMENT... $saved_context = $context; $context = COMMENT; $tokens[-2]->add_content("\\\n"); pop @tokens; $self->__add_elements( _parse_normal(@tokens) ); } elsif ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Found a line continuation... ### Switching context to UNKNOWN... $saved_context = $context; $context = UNKNOWN; } else { ### Parsing it as a normal line... $self->__add_elements( _parse_normal(@tokens) ); } } } elsif ($context == COMMENT) { @tokens = _tokenize_comment($_); if ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Slurping one more continued comment line... $tokens[-2]->add_content("\\\n"); pop @tokens; $self->last_token->add_content(join '', @tokens); } else { ### Completing comment slurping... ### Switching back to context: _state_str($saved_context) $context = $saved_context; my $last = pop @tokens; $self->last_token->add_content(join '', @tokens); $self->last_token->parent->__add_element($last); } } elsif ($context == COMMAND) { @tokens = _tokenize_command($_); ### more tokens for the cmd: @tokens if ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Slurping one more continued command line... $tokens[-2]->add_content("\\\n"); pop @tokens; for my $token (@tokens) { if ($token->class =~ /Interpolation/ or $self->last_token->class =~ /Interpolation/) { $self->last_token->parent->__add_element($token); } else { $self->last_token->add_content($token); } } } else { ### Completing command slurping: @tokens ### Switching back to context: _state_str($saved_context) $context = RULE; my $last = pop @tokens; ### last_token: $self->last_token for my $token (@tokens) { if ($token->class =~ /Interpolation/ or $self->last_token->class =~ /Interpolation/) { $self->last_token->parent->__add_element($token); } else { $self->last_token->add_content($token); } } $self->last_token->parent->__add_element($last); } } elsif ($context == UNKNOWN) { push @tokens, _tokenize_normal($_); if (@tokens >= 2 && $tokens[-1]->isa('MDOM::Token::Continuation') && $tokens[-2]->isa('MDOM::Token::Comment')) { $context = COMMENT; $tokens[-2]->add_content("\\\n"); pop @tokens; $self->__add_elements( _parse_normal(@tokens) ); } elsif ($tokens[-1]->isa('MDOM::Token::Continuation')) { ### Do nothing here...stay in the UNKNOWN context... } else { $self->__add_elements( _parse_normal(@tokens) ); $context = $saved_context; } } else { die "Unkown state: $context"; } } if ($context != RULE && $context != VOID) { warn "unexpected end of input at line $."; } } sub _tokenize_normal { local $_ = shift; my @tokens; my $pending_token = ''; my $next_token; ### TOKENIZING: $_ while (1) { # "token = $pending_token"; #warn pos; #warn '@tokens = ', _dump_tokens2(@tokens); if (/(?x) \G [\s\n]+ /gc) { $next_token = MDOM::Token::Whitespace->new($&); #push @tokens, $next_token; } elsif (/(?x) \G (?: :: | := | \?= | \+= | [=:;] )/gc) { $next_token = MDOM::Token::Separator->new($&); } elsif (/(?x) \G \| /gc) { # XXX This should be a separator... $next_token = MDOM::Token::Bare->new($&); } elsif (my $res = extract_interp($_)) { $next_token = MDOM::Token::Interpolation->new($res); } elsif (/(?x) \G \$. /gc) { $next_token = MDOM::Token::Interpolation->new($&); } elsif (/(?x) \G \\ ([\#\\\n:]) /gcs) { my $c = $1; if ($c eq "\n") { push @tokens, MDOM::Token::Bare->new($pending_token) if $pending_token ne ''; push @tokens, MDOM::Token::Continuation->new("\\\n"); return @tokens; } else { $pending_token .= "\\$c"; } } elsif (/(?x) \G (\# [^\n]*) \\ \n/sgc) { my $s = $1; push @tokens, MDOM::Token::Bare->new($pending_token) if $pending_token ne ''; push @tokens, MDOM::Token::Comment->new($s); push @tokens, MDOM::Token::Continuation->new("\\\n"); return @tokens; } elsif (/(?x) \G \# [^\n]* /gc) { $next_token = MDOM::Token::Comment->new($&); } elsif (/(?x) \G . /gc) { $pending_token .= $&; } else { last; } if ($next_token) { if ($pending_token ne '') { push @tokens, MDOM::Token::Bare->new($pending_token); $pending_token = ''; } push @tokens, $next_token; $next_token = undef; } } ### parse_normal result: @tokens @tokens; } sub _tokenize_command { my $s = shift; my @tokens; my $pending_token = ''; my $next_token; my $strlen = length $s; while ($s =~ /(?x) \G (\s*) ([\@+\-]) /gc) { my ($whitespace, $modifier) = ($1, $2); if ($whitespace) { push @tokens, MDOM::Token::Whitespace->new($whitespace); } push @tokens, MDOM::Token::Modifier->new($modifier); } while (1) { my $last = 0; if ($s =~ /(?x) \G \n /gc) { $next_token = MDOM::Token::Whitespace->new("\n"); #push @tokens, $next_token; } elsif (my $res = extract_interp($s)) { $next_token = MDOM::Token::Interpolation->new($res); } elsif ($s =~ /(?x) \G \$. /gc) { $next_token = MDOM::Token::Interpolation->new($&); } elsif ($s =~ /(?x) \G \\ ([\#\\\n:]) /gcs) { my $c = $1; if ($c eq "\n" && pos $s == $strlen) { $next_token = MDOM::Token::Continuation->new("\\\n"); } else { $pending_token .= "\\$c"; } } elsif ($s =~ /(?x) \G . /gc) { $pending_token .= $&; } else { $last = 1; } if ($next_token) { if ($pending_token) { push @tokens, MDOM::Token::Bare->new($pending_token); $pending_token = ''; } push @tokens, $next_token; $next_token = undef; } last if $last; } if ($pending_token) { push @tokens, MDOM::Token::Bare->new($pending_token); $pending_token = ''; } @tokens; } sub _tokenize_comment { local $_ = shift; my @tokens; my $pending_token = ''; while (1) { if (/(?x) \G \n /gc) { push @tokens, MDOM::Token::Comment->new($pending_token) if $pending_token ne ''; push @tokens, MDOM::Token::Whitespace->new("\n"); return @tokens; #push @tokens, $next_token; } elsif (/(?x) \G \\ ([\\\n#:]) /gcs) { my $c = $1; if ($c eq "\n") { push @tokens, MDOM::Token::Comment->new($pending_token) if $pending_token ne ''; push @tokens, MDOM::Token::Continuation->new("\\\n"); return @tokens; } else { $pending_token .= "\\$c"; } } elsif (/(?x) \G . /gc) { $pending_token .= $&; } else { last; } } @tokens; } sub _parse_normal { my @tokens = @_; ### fed to _parse_normal: @tokens my @sep = grep { $_->isa('MDOM::Token::Separator') } @tokens; #### Separators: @sep if (@tokens == 1) { return $tokens[0]; } # filter out significant tokens: my ($fst, $snd) = grep { $_->significant } @tokens; my $is_directive; if ($fst) { if ($fst eq '-include') { $fst->set_content('include'); unshift @tokens, MDOM::Token::Modifier->new('-'); $is_directive = 1; } elsif ($fst eq 'override' && $snd && $snd eq 'define' || _is_keyword($fst)) { $is_directive = 1; } if ($is_directive) { ##### Found directives... my $node = MDOM::Directive->new; $node->__add_elements(@tokens); return $node; } } if (@sep >= 2 && $sep[0] =~ /^::?$/ and $sep[1] eq ';') { #### Found simple rule with inlined command... my $rule = MDOM::Rule::Simple->new; my @t = before { $_ eq ';' } @tokens; $rule->__add_elements(@t); splice @tokens, 0, scalar(@t); my @prefix = shift @tokens; if ($tokens[0] && $tokens[0]->isa('MDOM::Token::Whitespace')) { push @prefix, shift @tokens; } @tokens = (@prefix, _tokenize_command(join '', @tokens)); if ($tokens[-1]->isa('MDOM::Token::Continuation')) { $saved_context = $context; $context = COMMAND; } my $cmd = MDOM::Command->new; $cmd->__add_elements(@tokens); $rule->__add_elements($cmd); $saved_context = RULE; $context = RULE if $context == VOID; return $rule; } elsif (@sep >= 2 && $sep[0] eq ':' and $sep[1] =~ /^::?$/) { #### Found static pattern rule... my $rule = MDOM::Rule::StaticPattern->new; my @t = before { $_ eq ';' } @tokens; $rule->__add_elements(@t); splice @tokens, 0, scalar(@t); if (@tokens) { my @prefix = shift @tokens; if ($tokens[0] && $tokens[0]->isa('MDOM::Token::Whitespace')) { push @prefix, shift @tokens; } @tokens = (@prefix, _tokenize_command(join '', @tokens)); if ($tokens[-1]->isa('MDOM::Token::Continuation')) { $saved_context = $context; $context = COMMAND; } my $cmd = MDOM::Command->new; $cmd->__add_elements(@tokens); $rule->__add_elements($cmd); } $saved_context = RULE; $context = RULE if $context == VOID; return $rule; } elsif (@sep == 1 && $sep[0] =~ /^::?$/) { #### Found simple rule without inlined command... my $rule = MDOM::Rule::Simple->new; $rule->__add_elements(@tokens); $saved_context = RULE; $context = RULE if $context == VOID; return $rule; } elsif (@sep && $sep[0] =~ /(?x) ^ (?: = | := | \+= | \?= ) $/) { my $assign = MDOM::Assignment->new; ### Assignment tokens: @tokens $assign->__add_elements(@tokens); $saved_context = VOID; $context = VOID if $context == RULE; return $assign; } elsif (all { $_->isa('MDOM::Token::Comment') || $_->isa('MDOM::Token::Whitespace') } @tokens) { @tokens; } else { #### Found unkown token sequence: @tokens @tokens = _tokenize_command(join '', @tokens); my $node = MDOM::Unknown->new; $node->__add_elements(@tokens); $node; } } sub _dump_tokens { my @tokens = map { $_->clone } @_; warn "??? ", (join ' ', map { s/\\/\\\\/g; s/\n/\\n/g; s/\t/\\t/g; "[$_]" } @tokens ), "\n"; } sub _state_str { $_rev_map{$saved_context} } sub _is_keyword { any { $_[0] eq $_ } @keywords; } 1; Makefile-DOM-0.006/lib/MDOM/Util.pm0000644000175000001440000000052511626450246015645 0ustar agentzuserspackage MDOM::Util; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw( trim_tokens ); sub trim_tokens ($) { my $tokens = shift; return if !@$tokens; if ($tokens->[0] =~ /^\s+$/) { shift @$tokens; } return if !@$tokens; if ($tokens->[-1] =~ /^\s+$/) { pop @$tokens; } } 1; Makefile-DOM-0.006/lib/MDOM/Directive.pm0000644000175000001440000000040411626450246016642 0ustar agentzuserspackage MDOM::Directive; use strict; use base 'MDOM::Node'; sub name { my ($self) = @_; # XXX need a better way to do this: return $self->schild(0); } sub value { my ($self) = @_; # XXX This is a hack return $self->schild(1); } 1; Makefile-DOM-0.006/lib/MDOM/Assignment.pm0000644000175000001440000000226211626450246017040 0ustar agentzuserspackage MDOM::Assignment; use strict; use warnings; #use Smart::Comments; use base 'MDOM::Node'; use MDOM::Util qw( trim_tokens ); sub lhs ($) { my ($self) = @_; $self->_parse if !defined $self->{op}; my $tokens = $self->{lhs}; wantarray ? @$tokens : $tokens; } sub rhs ($) { my ($self) = @_; $self->_parse if !defined $self->{op}; my $tokens = $self->{rhs}; wantarray ? @$tokens : $tokens; } sub op { my ($self) = @_; $self->_parse if !defined $self->{op}; $self->{op}; } sub _parse ($) { my ($self) = @_; my @elems = $self->elements; ### Assignment elems: @elems my (@lhs, @rhs, $op); for my $elem (@elems) { if (!$op) { if ($elem->class eq 'MDOM::Token::Separator') { $op = $elem; } else { push @lhs, $elem; } } elsif ($elem->class eq 'MDOM::Token::Comment') { last; } else { push @rhs, $elem; } } trim_tokens(\@lhs); pop @rhs if $rhs[-1] eq "\n"; shift @rhs if $rhs[0]->class eq 'MDOM::Token::Whitespace'; $self->{lhs} = \@lhs; $self->{rhs} = \@rhs; $self->{op} = $op; } 1; Makefile-DOM-0.006/lib/MDOM/Unknown.pm0000644000175000001440000000007711626450246016371 0ustar agentzuserspackage MDOM::Unknown; use strict; use base 'MDOM::Node'; 1; Makefile-DOM-0.006/lib/MDOM/Node.pm0000644000175000001440000004673411626450246015631 0ustar agentzuserspackage MDOM::Node; =pod =head1 NAME MDOM::Node - Abstract MDOM Node class, an Element that can contain other Elements =head1 INHERITANCE MDOM::Node isa MDOM::Element =head1 SYNOPSIS # Create a typical node (a Document in this case) my $Node = MDOM::Document->new; # Add an element to the node( in this case, a token ) my $Token = MDOM::Token::Word->new('my'); $Node->add_element( $Token ); # Get the elements for the Node my @elements = $Node->children; # Find all the barewords within a Node my $barewords = $Node->find( 'MDOM::Token::Word' ); # Find by more complex criteria my $my_tokens = $Node->find( sub { $_[1]->content eq 'my' } ); # Remove all the whitespace $Node->prune( 'MDOM::Token::Whitespace' ); # Remove by more complex criteria $Node->prune( sub { $_[1]->content eq 'my' } ); =head1 DESCRIPTION The C class provides an abstract base class for the Element classes that are able to contain other elements L, L, and L. As well as those listed below, all of the methods that apply to L objects also apply to C objects. =head1 METHODS =cut use strict; use base 'MDOM::Element'; use Carp (); use Scalar::Util 'refaddr'; use List::MoreUtils (); use Params::Util '_INSTANCE', '_CLASS'; use vars qw{$VERSION *_PARENT}; BEGIN { $VERSION = '0.006'; *_PARENT = *MDOM::Element::_PARENT; } ##################################################################### # The basic constructor sub new { my $class = ref $_[0] || $_[0]; bless { children => [], lineno => $. }, $class; } ##################################################################### # PDOM Methods =pod =head2 scope The C method returns true if the node represents a lexical scope boundary, or false if it does not. =cut ### XS -> MDOM/XS.xs:_MDOM_Node__scope 0.903+ sub scope { '' } =pod =head2 add_element $Element The C method adds a L object to the end of a C. Because Elements maintain links to their parent, an Element can only be added to a single Node. Returns true if the L was added. Returns C if the Element was already within another Node, or the method is not passed a L object. =cut sub add_element { my $self = shift; # Check the element my $Element = _INSTANCE(shift, 'MDOM::Element') or return undef; $_PARENT{refaddr $Element} and return undef; # Add the argument to the elements push @{$self->{children}}, $Element; Scalar::Util::weaken( $_PARENT{refaddr $Element} = $self ); 1; } # In a typical run profile, add_element is the number 1 resource drain. # This is a highly optimised unsafe version, for internal use only. sub __add_element { Scalar::Util::weaken( $_PARENT{refaddr $_[1]} = $_[0] ); push @{$_[0]->{children}}, $_[1]; } sub __add_elements { my $self = shift; for (@_) { $self->__add_element($_); } } =pod =head2 elements The C method accesses all child elements B within the C object. Note that in the base of the L classes, this C include the brace tokens at either end of the structure. Returns a list of zero or more L objects. Alternatively, if called in the scalar context, the C method returns a count of the number of elements. =cut sub elements { wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}}; } =pod =head2 first_element The C method accesses the first element structurally within the C object. As for the C method, this does include the brace tokens for L objects. Returns a L object, or C if for some reason the C object does not contain any elements. =cut # Normally the first element is also the first child sub first_element { $_[0]->{children}->[0]; } =pod =head2 last_element The C method accesses the last element structurally within the C object. As for the C method, this does include the brace tokens for L objects. Returns a L object, or C if for some reason the C object does not contain any elements. =cut # Normally the last element is also the last child sub last_element { $_[0]->{children}->[-1]; } =pod =head2 children The C method accesses all child elements lexically within the C object. Note that in the case of the L classes, this does B include the brace tokens at either end of the structure. Returns a list of zero of more L objects. Alternatively, if called in the scalar context, the C method returns a count of the number of lexical children. =cut # In the default case, this is the same as for the elements method sub children { wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}}; } =pod =head2 schildren The C method is really just a convenience, the significant-only variation of the normal C method. In list context, returns a list of significant children. In scalar context, returns the number of significant children. =cut sub schildren { my $self = shift; my @schildren = grep { $_->significant } $self->children; wantarray ? @schildren : scalar(@schildren); } =pod =head2 child $index The C method accesses a child L object by its position within the Node. Returns a L object, or C if there is no child element at that node. =cut sub child { $_[0]->{children}->[$_[1]]; } =pod =head2 schild $index The lexical structure of the Perl language ignores 'insignificant' items, such as whitespace and comments, while L treats these items as valid tokens so that it can reassemble the file at any time. Because of this, in many situations there is a need to find an Element within a Node by index, only counting lexically significant Elements. The C method returns a child Element by index, ignoring insignificant Elements. The index of a child Element is specified in the same way as for a normal array, with the first Element at index 0, and negative indexes used to identify a "from the end" position. =cut sub schild { my $self = shift; my $idx = 0 + shift; my $el = $self->{children}; if ( $idx < 0 ) { my $cursor = 0; while ( exists $el->[--$cursor] ) { return $el->[$cursor] if $el->[$cursor]->significant and ++$idx >= 0; } } else { my $cursor = -1; while ( exists $el->[++$cursor] ) { return $el->[$cursor] if $el->[$cursor]->significant and --$idx < 0; } } undef; } =pod =head2 contains $Element The C method is used to determine if another L object is logically "within" a C. For the special case of the brace tokens at either side of a L object, they are generally considered "within" a L object, even if they are not actually in the elements for the L. Returns true if the L is within us, false if not, or C on error. =cut sub contains { my $self = shift; my $Element = _INSTANCE(shift, 'MDOM::Element') or return undef; # Iterate up the Element's parent chain until we either run out # of parents, or get to ourself. while ( $Element = $Element->parent ) { return 1 if refaddr($self) == refaddr($Element); } ''; } =pod =head2 find $class | \&wanted The C method is used to search within a code tree for L objects that meet a particular condition. To specify the condition, the method can be provided with either a simple class name (full or shortened), or a C/function reference. # Find all single quotes in a Document (which is a Node) $Document->find('MDOM::Quote::Single'); # The same thing with a shortened class name $Document->find('Quote::Single'); # Anything more elaborate, we so with the sub $Document->find( sub { # At the top level of the file... $_[1]->parent == $_[0] and ( # ...find all comments and POD $_[1]->isa('MDOM::Token::Pod') or $_[1]->isa('MDOM::Token::Comment') ) } ); The function will be passed two arguments, the top-level C you are searching in and the current L that the condition is testing. The anonymous function should return one of three values. Returning true indicates a condition match, defined-false (C<0> or C<''>) indicates no-match, and C indicates no-match and no-descend. In the last case, the tree walker will skip over anything below the C-returning element and move on to the next element at the same level. To halt the entire search and return C immediately, a condition function should throw an exception (i.e. C). Note that this same wanted logic is used for all methods documented to have a C<\&wanted> parameter, as this one does. The C method returns a reference to an array of L objects that match the condition, false (but defined) if no Elements match the condition, or C if you provide a bad condition, or an error occurs during the search process. In the case of a bad condition, a warning will be emitted as well. =cut sub find { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use a queue based search, rather than a recursive one my @found = (); my @queue = $self->children; eval { while ( my $Element = shift @queue ) { my $rv = &$wanted( $self, $Element ); push @found, $Element if $rv; # Support "don't descend on undef return" next unless defined $rv; # Skip if the Element doesn't have any children next unless $Element->isa('MDOM::Node'); # Depth-first keeps the queue size down and provides a # better logical order. if ( $Element->isa('MDOM::Structure') ) { unshift @queue, $Element->finish if $Element->finish; unshift @queue, $Element->children; unshift @queue, $Element->start if $Element->start; } else { unshift @queue, $Element->children; } } }; if ( $@ ) { # Caught exception thrown from the wanted function return undef; } @found ? \@found : ''; } =pod =head2 find_first $class | \&wanted If the normal C method is like a grep, then C is equivalent to the L C function. Given an element class or a wanted function, it will search depth-first through a tree until it finds something that matches the condition, returning the first Element that it encounters. See the C method for details on the format of the search condition. Returns the first L object that matches the condition, false if nothing matches the condition, or C if given an invalid condition, or an error occurs. =cut sub find_first { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use the same queue-based search as for ->find my @queue = $self->children; my $rv = eval { while ( my $Element = shift @queue ) { my $rv = &$wanted( $self, $Element ); return $Element if $rv; # Support "don't descend on undef return" next unless defined $rv; # Skip if the Element doesn't have any children next unless $Element->isa('MDOM::Node'); # Depth-first keeps the queue size down and provides a # better logical order. if ( $Element->isa('MDOM::Structure') ) { unshift @queue, $Element->finish if $Element->finish; unshift @queue, $Element->children; unshift @queue, $Element->start if $Element->start; } else { unshift @queue, $Element->children; } } }; if ( $@ ) { # Caught exception thrown from the wanted function return undef; } $rv or ''; } =pod =head2 find_any $class | \&wanted The C method is a short-circuiting true/false method that behaves like the normal C method, but returns true as soon as it finds any Elements that match the search condition. See the C method for details on the format of the search condition. Returns true if any Elements that match the condition can be found, false if not, or C if given an invalid condition, or an error occurs. =cut sub find_any { my $self = shift; my $rv = $self->find_first(@_); $rv ? 1 : $rv; # false or undef } =pod =head2 remove_child $Element If passed a L object that is a direct child of the Node, the C method will remove the C intact, along with any of its children. As such, this method acts essentially as a 'cut' function. =cut sub remove_child { my $self = shift; my $child = _INSTANCE(shift, 'MDOM::Element') or return undef; # Find the position of the child my $key = refaddr $child; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; return undef unless defined $p; # Splice it out, and remove the child's parent entry splice( @{$self->{children}}, $p, 1 ); delete $_PARENT{refaddr $child}; $child; } =pod =head2 source Returns the makefile source for the current node =cut sub source { my $self = shift; join '', map { $_->source } $self->children; } =pod =head2 prune $class | \&wanted The C method is used to strip L objects out of a code tree. The argument is the same as for the C method, either a class name, or an anonymous subroutine which returns true/false. Any Element that matches the class|wanted will be deleted from the code tree, along with any of its children. The C method returns the number of C objects that matched and were removed, B. This might also be zero, so avoid a simple true/false test on the return false of the C method. It returns C on error, which you probably B test for. =cut sub prune { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use a depth-first queue search my $pruned = 0; my @queue = $self->children; eval { while ( my $element = shift @queue ) { my $rv = &$wanted( $self, $element ); if ( $rv ) { # Delete the child $element->delete or return undef; $pruned++; next; } # Support the undef == "don't descend" next unless defined $rv; if ( _INSTANCE($element, 'MDOM::Node') ) { # Depth-first keeps the queue size down unshift @queue, $element->children; } } }; if ( $@ ) { # Caught exception thrown from the wanted function return undef; } $pruned; } # This method is likely to be very heavily used, to take # it slowly and carefuly. ### NOTE: Renaming this function or changing either to self will probably ### break File::Find::Rule::MDOM sub _wanted { my $either = shift; my $it = defined $_[0] ? shift : do { Carp::carp('Undefined value passed as search condition') if $^W; return undef; }; # Has the caller provided a wanted function directly return $it if ref $it eq 'CODE'; if ( ref $it ) { # No other ref types are supported Carp::carp('Illegal non-CODE reference passed as search condition') if $^W; return undef; } # The first argument should be an Element class, possibly in shorthand $it = "MDOM::$it" unless substr($it, 0, 6) eq 'MDOM::'; unless ( _CLASS($it) and $it->isa('MDOM::Element') ) { # We got something, but it isn't an element Carp::carp("Cannot create search condition for '$it': Not a MDOM::Element") if $^W; return undef; } # Create the class part of the wanted function my $wanted_class = "\n\treturn '' unless \$_[1]->isa('$it');"; # Have we been given a second argument to check the content my $wanted_content = ''; if ( defined $_[0] ) { my $content = shift; if ( ref $content eq 'Regexp' ) { $content = "$content"; } elsif ( ref $content ) { # No other ref types are supported Carp::carp("Cannot create search condition for '$it': Not a MDOM::Element") if $^W; return undef; } else { $content = quotemeta $content; } # Complete the content part of the wanted function $wanted_content .= "\n\treturn '' unless defined \$_[1]->{content};"; $wanted_content .= "\n\treturn '' unless \$_[1]->{content} =~ /$content/;"; } # Create the complete wanted function my $code = "sub {" . $wanted_class . $wanted_content . "\n\t1;" . "\n}"; # Compile the wanted function $code = eval $code; (ref $code eq 'CODE') ? $code : undef; } #################################################################### # MDOM::Element overloaded methods sub tokens { map { $_->tokens } @{$_[0]->{children}}; } ### XS -> MDOM/XS.xs:_MDOM_Element__content 0.900+ sub content { join '', map { $_->content } @{$_[0]->{children}}; } # Clone as normal, but then go down and relink all the _PARENT entries sub clone { my $self = shift; my $clone = $self->SUPER::clone; $clone->__link_children; $clone; } sub location { my $self = shift; my $first = $self->{children}->[0] or return undef; $first->location; } ##################################################################### # Internal Methods sub DESTROY { local $_; if ( $_[0]->{children} ) { my @queue = $_[0]; while ( defined($_ = shift @queue) ) { unshift @queue, @{delete $_->{children}} if $_->{children}; # Remove all internal/private weird crosslinking so that # the cascading DESTROY calls will get called properly. %$_ = (); } } # Remove us from our parent node as normal delete $_PARENT{refaddr $_[0]}; } # Find the position of a child sub __position { my $key = refaddr $_[1]; List::MoreUtils::firstidx { refaddr $_ == $key } @{$_[0]->{children}}; } # Insert one or more elements before a child sub __insert_before_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p, 0, @_ ); 1; } # Insert one or more elements after a child sub __insert_after_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p + 1, 0, @_ ); 1; } # Replace a child sub __replace_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p, 1, @_ ); 1; } # Create PARENT links for an entire tree. # Used when cloning or thawing. sub __link_children { my $self = shift; # Relink all our children ( depth first ) my @queue = ( $self ); while ( my $Node = shift @queue ) { # Link our immediate children foreach my $Element ( @{$Node->{children}} ) { Scalar::Util::weaken( $_PARENT{refaddr($Element)} = $Node ); unshift @queue, $Element if $Element->isa('MDOM::Node'); } # If it's a structure, relink the open/close braces next unless $Node->isa('MDOM::Structure'); Scalar::Util::weaken( $_PARENT{refaddr($Node->start)} = $Node ) if $Node->start; Scalar::Util::weaken( $_PARENT{refaddr($Node->finish)} = $Node ) if $Node->finish; } 1; } 1; =pod =head1 TO DO - Move as much as possible to L =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/lib/MDOM/Command.pm0000644000175000001440000000007711626450246016310 0ustar agentzuserspackage MDOM::Command; use strict; use base 'MDOM::Node'; 1; Makefile-DOM-0.006/lib/MDOM/Token/0000755000175000001440000000000011626450365015452 5ustar agentzusersMakefile-DOM-0.006/lib/MDOM/Token/Interpolation.pm0000644000175000001440000000011511626450246020632 0ustar agentzuserspackage MDOM::Token::Interpolation; use strict; use base 'MDOM::Token'; 1; Makefile-DOM-0.006/lib/MDOM/Token/Whitespace.pm0000644000175000001440000000563511626450246020113 0ustar agentzuserspackage MDOM::Token::Whitespace; =pod =head1 NAME MDOM::Token::Whitespace - Tokens representing ordinary white space =head1 INHERITANCE MDOM::Token::Whitespace isa MDOM::Token isa MDOM::Element =head1 DESCRIPTION As a full "round-trip" parser, MDOM records every last byte in a file and ensure that it is included in the L object. This even includes whitespace. In fact, Perl documents are seen as "floating in a sea of whitespace", and thus any document will contain vast quantities of C objects. For the most part, you shouldn't notice them. Or at least, you shouldn't B to notice them. This means doing things like consistently using the "S for significant" series of L and L methods to do things. If you want the nth child element, you should be using C rather than C, and likewise C, C, and so on and so forth. =head1 METHODS Again, for the most part you should really B need to do anything very significant with whitespace. But there are a couple of convenience methods provided, beyond those provided by the parent L and L classes. =cut use strict; use base 'MDOM::Token'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.006'; } =pod =head2 null Because MDOM sees documents as sitting on a sort of substrate made of whitespace, there are a couple of corner cases that get particularly nasty if they don't find whitespace in certain places. Imagine walking down the beach to go into the ocean, and then quite unexpectedly falling off the side of the planet. Well it's somewhat equivalent to that, including the whole screaming death bit. The C method is a convenience provided to get some internals out of some of these corner cases. Specifically it create a whitespace token that represents nothing, or at least the null string C<''>. It's a handy way to have some "whitespace" right where you need it, without having to have any actual characters. =cut sub null { $_[0]->new('') } ### XS -> MDOM/XS.xs:_MDOM_Token_Whitespace__significant 0.900+ sub significant { '' } =pod =head2 tidy C is a convenience method for removing unneeded whitespace. Specifically, it removes any whitespace from the end of a line. Note that this B include POD, where you may well need to keep certain types of whitespace. The entire POD chunk lives in its own L object. =cut sub tidy { my $self = shift; $self->{content} =~ s/^\s+?(?>\n)//; 1; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/lib/MDOM/Token/Continuation.pm0000644000175000001440000000014411626450246020457 0ustar agentzuserspackage MDOM::Token::Continuation; use strict; use base 'MDOM::Token'; sub significant { '' } 1; Makefile-DOM-0.006/lib/MDOM/Token/Comment.pm0000644000175000001440000000464711626450246017423 0ustar agentzuserspackage MDOM::Token::Comment; =pod =head1 NAME MDOM::Token::Comment - A comment in Makefile source code =head1 INHERITANCE MDOM::Token::Comment isa MDOM::Token isa MDOM::Element =head1 SYNOPSIS # This is a MDOM::Token::Comment foo: bar # So is this one echo 'hello' =head1 DESCRIPTION In MDOM, comments are represented by C objects. These come in two flavours, line comment and inline comments. A C is a comment that stands on its own line. These comments hold their own newline and whitespace (both leading and trailing) as part of the one C object. An inline comment is a comment that appears after some code, and continues to the end of the line. This does B include whitespace, and the terminating newlines is considered a separate L token. This is largely a convenience, simplifying a lot of normal code relating to the common things people do with comments. Most commonly, it means when you C or C a comment, a line comment disappears taking the entire line with it, and an inline comment is removed from the inside of the line, allowing the newline to drop back onto the end of the code, as you would expect. It also means you can move comments around in blocks much more easily. For now, this is a suitably handy way to do things. However, I do reserve the right to change my mind on this one if it gets dangerously anachronistic somewhere down the line. =head1 METHODS Only very limited methods are available, beyond those provided by our parent L and L classes. =cut use strict; use base 'MDOM::Token'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.006'; } ### XS -> MDOM/XS.xs:_MDOM_Token_Comment__significant 0.900+ sub significant { '' } =pod =head2 line The C accessor returns true if the C is a line comment, or false if it is an inline comment. =cut sub line { # Entire line comments have a newline at the end $_[0]->{content} =~ /\n$/ ? 1 : 0; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/lib/MDOM/Token/Bare.pm0000644000175000001440000000012311626450246016653 0ustar agentzuserspackage MDOM::Token::Bare; use strict; use warnings; use base 'MDOM::Token'; 1; Makefile-DOM-0.006/lib/MDOM/Token/Modifier.pm0000644000175000001440000000010711626450246017542 0ustar agentzuserspackage MDOM::Token::Modifier; use strict; use base 'MDOM::Token'; 1;Makefile-DOM-0.006/lib/MDOM/Token/Separator.pm0000644000175000001440000000162211626450246017747 0ustar agentzuserspackage MDOM::Token::Separator; =pod =head1 NAME MDOM::Token::Separator - Makefile separators like colons and leading tabs =head1 INHERITANCE MDOM::Token::Separator isa MDOM::Token::Word isa MDOM::Token isa MDOM::Element =head1 DESCRIPTION =head1 METHODS This class has no methods beyond what is provided by its L, L and L parent classes. =cut use strict; use base 'MDOM::Token'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.006'; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2006 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut Makefile-DOM-0.006/MANIFEST.SKIP0000644000175000001440000000044411622763144014766 0ustar agentzusers^\w+\.txt$ ^\.git ~$ \.swp$ ^Makefile$ ^Makefile.old$ ^blib/ ^make-simple\.mk$ script/plmake$ \.db$ \.patched$ \.bak$ ^mech_t/ \.t_$ ^t/gmake/ ^pm_to_blib ^Makefile-DOM-\d ^t/sh/ ^test-\w+ tmp\.pl test\.mk ^trans.* update-mech-t \.pdf pgmake-db\.sh ^regression$ t/mdom/gmake/mdom-tests\.txt$ Makefile-DOM-0.006/README0000644000175000001440000002434711626450360013755 0ustar agentzusersNAME Makefile::DOM - Simple DOM parser for Makefiles VERSION This document describes Makefile::DOM 0.006 released on 28 August 2011. DESCRIPTION This libary can serve as an advanced lexer for (GNU) makefiles. It parses makefiles as "documents" and the parsing is lossless. The results are data structures similar to DOM trees. The DOM trees hold every single bit of the information in the original input files, including white spaces, blank lines and makefile comments. That means it's possible to reproduce the original makefiles from the DOM trees. In addition, each node of the DOM trees is modifiable and so is the whole tree, just like the PPI module used for Perl source parsing and the HTML::TreeBuilder module used for parsing HTML source. If you're looking for a true GNU make parser that generates an AST, please see Makefile::Parser::GmakeDB instead. The interface of "Makefile::DOM" mimics the API design of PPI. In fact, I've directly stolen the source code and POD documentation of PPI::Node, PPI::Element, and PPI::Dumper, with the full permission from the author of PPI, Adam Kennedy. "Makefile::DOM" tries to be independent of specific makefile's syntax. The same set of DOM node types is supposed to get shared by different makefile DOM generators. For example, MDOM::Document::Gmake parses GNU makefiles and returns an instance of MDOM::Document, i.e., the root of the DOM tree while the NMAKE makefile lexer in the future, "MDOM::Document::Nmake", also returns instances of the MDOM::Document class. Later, I'll also consider adding support for dmake and bsdmake. Structure of the DOM Makefile DOM (MDOM) is a structured set of a series of data types. They provide a flexible document model conformed to the makefile syntax. Below is a complete list of the 19 MDOM classes in the current implementation where the indentation indicates the class inheritance relationships. MDOM::Element MDOM::Node MDOM::Unknown MDOM::Assignment MDOM::Command MDOM::Directive MDOM::Document MDOM::Document::Gmake MDOM::Rule MDOM::Rule::Simple MDOM::Rule::StaticPattern MDOM::Token MDOM::Token::Bare MDOM::Token::Comment MDOM::Token::Continuation MDOM::Token::Interpolation MDOM::Token::Modifier MDOM::Token::Separator MDOM::Token::Whitespace It's not hard to see that all of the MDOM classes inherit from the MDOM::Element class. MDOM::Token and MDOM::Node are its direct children. The former represents a string token which is atomic from the perspective of the lexer while the latter represents a structured node, which usually has one or more children, and serves as the container for other DOM::Element objects. Next we'll show a few examples to demonstrate how to map DOM trees to particular makefiles. Case 1 Consider the following simple "hello, world" makefile: all : ; echo "hello, world" We can use the MDOM::Dumper class provided by Makefile::DOM to dump out the internal structure of its corresponding MDOM tree: MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo "hello, world"' MDOM::Token::Whitespace '\n' In this example, speparators ":" and ";" are all instances of the MDOM::Token::Separator class while spaces and new line characters are all represented as MDOM::Token::Whitespace. The other two leaf nodes, "all" and "echo "hello, world"" both belong to MDOM::Token::Bare. It's worth mentioning that, the space characters in the rule command "echo "hello, world"" were not represented as MDOM::Token::Whitespace. That's because in makefiles, the spaces in commands do not make any sense to "make" in syntax; those spaces are usually sent to shell programs verbatim. Therefore, the DOM parser does not try to recognize those spaces specifially so as to reduce memory use and the number of nodes. However, leading spaces and trailing new lines will still be recognized as MDOM::Token::Whitespace. On a higher level, it's a MDOM::Rule::Simple instance holding several "Token" and one MDOM::Command. On the highest level, it's the root node of the whole DOM tree, i.e., an instance of MDOM::Document::Gmake. Case 2 Below is a relatively complex example: a: foo.c bar.h $(baz) # hello! @echo ... It's corresponding DOM structure is MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo.c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar.h' MDOM::Token::Whitespace '\t' MDOM::Token::Interpolation '$(baz)' MDOM::Token::Whitespace ' ' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Bare 'echo ...' MDOM::Token::Whitespace '\n' Compared to the previous example, here appears several new node types. The variable interpolation "$(baz)" on the first line of the original makefile corresponds to a MDOM::Token::Interpolation node in its MDOM tree. Similarly, the comment "# hello" corresponds to a MDOM::Token::Comment node. On the second line, the rule command indented by a tab character is still represented by a MDOM::Command object. Its first child node (or its first element) is also an MDOM::Token::Seperator instance corresponding to that tab. The command modifier "@" follows the "Separator" immediately, which is of type MDOM::Token::Modifier. Case 3 Now let's study a sample makefile with various global structures: a: b foo = bar # hello! Here on the top level, there are three language structures: one rule ""a: b"", one assignment statement "foo = bar", and one comment "# hello!". Its MDOM tree is shown below: MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace '\n' MDOM::Assignment MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\t' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' We can see that below the root node MDOM::Document::Gmake, there are MDOM::Rule::Simple, MDOM::Assignment, and MDOM::Comment three elements, as well as two MDOM::Token::Whitespace objects. It can be observed from the examples above that the MDOM representation for the makefile's lexical elements is rather loose. It only provides very limited structural representation instead of making a bad guess. OPERATIONS FOR MDOM TREES Generating an MDOM tree from a GNU makefile only requires two lines of Perl code: use MDOM::Document::Gmake; my $dom = MDOM::Document::Gmake->new('Makefile'); If the makefile source code being parsed is already stored in a Perl variable, say, $var, then we can construct an MDOM via the following code: my $dom = MDOM::Document::Gmake->new(\$var); Now $dom becomes the reference to the root of the MDOM tree and its type is now MDOM::Document::Gmake, which is also an instance of the MDOM::Node class. Just as mentioned above, "MDOM::Node" is the container for other MDOM::Element instances. So we can retrieve some element node's value via its "child" method: $node = $dom->child(3); # or $node = $dom->elements(0); And we may also use the "elements" method to obtain the values of all the nodes: @elems = $dom->elements; For every MDOM node, its corresponding makefile source can be generated by invoking its "content" method. BUGS AND TODO The current implemenation of the MDOM::Document::Gmake lexer is based on a hand-written state machie. Although the efficiency of the engine is not bad, the code is rather complicated and messy, which hurts both extensibility and maintanabilty. So it's expected to rewrite the parser using some grammatical tools like the Perl 6 regex engine Pugs::Compiler::Rule or a yacc-style one like Parse::Yapp. SOURCE REPOSITORY You can always get the latest source code of this module from its GitHub repository: If you want a commit bit, please let me know. AUTHOR Zhang "agentzh" Yichun (章亦春) COPYRIGHT Copyright 2006-2011 by Zhang "agentzh" Yichun (章亦春). This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. SEE ALSO MDOM::Document, MDOM::Document::Gmake, PPI, Makefile::Parser::GmakeDB, makesimple. Makefile-DOM-0.006/TODO0000644000175000001440000000023011622740614013546 0ustar agentzusers* add tests to t/mdom/gmake/*.t * add POD to lib/*.pm * MDOM::Document::Gmake - rename $context to $inner_context and $saved_context to $outer_context Makefile-DOM-0.006/META.yml0000644000175000001440000000124311626450360014334 0ustar agentzusers--- abstract: 'Simple DOM parser for Makefiles' author: - "Zhang \"agentzh\" Yichun (章亦春) " build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.01' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Makefile-DOM no_index: directory: - inc - t requires: Clone: 0.18 Filter::Util::Call: 0 List::MoreUtils: 0.21 Params::Util: 0.22 perl: 5.6.1 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/agentzh/makefile-dom-pm version: 0.006 Makefile-DOM-0.006/t/0000755000175000001440000000000011626450365013333 5ustar agentzusersMakefile-DOM-0.006/t/mdom/0000755000175000001440000000000011626450365014267 5ustar agentzusersMakefile-DOM-0.006/t/mdom/node.t0000644000175000001440000000664111622740614015403 0ustar agentzusersuse strict; use warnings; use Test::More tests => 49; BEGIN { use_ok('MDOM::Token'); use_ok('MDOM::Node'); } { my $node = MDOM::Node->new; my $token = MDOM::Token->new('hello'); $node->add_element($token); is $token->parent, $node, '$token\'s parent ok'; ok !$token->previous_sibling, '$token\'s prev sibling is empty'; ok !$token->next_sibling, '$token\'s next sibling is empty too'; my @elems = $node->elements; is scalar(@elems), 1, 'only 1 elem'; is $elems[0], $token, 'token truly added'; is $node->child(0), $token, 'child 0'; is $node->first_element, $token, 'it is the first one'; is $node->last_element, $token, '...and also the last'; my $token2 = MDOM::Token->new('Whitespace', ' '); ok !$node->contains($token2), '$token2 not yet added'; $node->add_element($token2); is $token2->parent, $node, '$token2\'s parent ok'; is $token2->previous_sibling, $token, '$token2\'s prev sibling is $token'; ok !$token2->next_sibling, 'no next sibling for $token2'; is scalar($node->elements), 2, '2 elements'; @elems = $node->elements; is $elems[0], $token, '$token is the first one'; is $node->child(0), $token, 'child 0'; ok $node->contains($token), 'contains $token'; is $elems[1], $token2, '$token2 is the second one'; is $node->child(1), $token2, 'child 1'; ok $node->contains($token2), 'contains $token2'; is $elems[2], undef, 'no third one'; is join(':', @elems), 'hello: '; is $node->first_element, $token; is $node->last_element, $token2; my $token3 = MDOM::Token->new('world'); ok !$node->contains($token3), '$token3 not yet added'; $node->add_element($token3); is $token3->parent, $node, '$token3\'s parent ok'; is $token3->previous_sibling, $token2, '$token3\'s prev sibling is $token2'; ok !$token3->next_sibling, 'no next sibling for $token3'; is $token2->previous_sibling, $token, '$token2\'s prev sibling is $token'; is $token2->next_sibling, $token3, '$token2\'s next sibling is $token3'; my $res = $node->find('Token::Bare'); is scalar(@$res), 2, '2 bare tokens'; is join('', @$res), 'helloworld'; $res = $node->find('MDOM::Token::Bare'); is scalar(@$res), 2, '2 bare tokens'; is join('', @$res), 'helloworld'; $res = $node->find_first('Token::Bare'); is $res, $token, 'find the first one'; $res = $node->find_first('Token::Whitespace'); is $res, $token2, 'find the second one'; $res = $node->find('Token::Whitespace'); is scalar(@$res), 1, 'only 1 whitespace found'; is $res->[0], $token2, '$token2 found'; @elems = $node->children; is join('', @elems), 'hello world'; @elems = $node->schildren; is join('', @elems), 'helloworld'; is $node->schild(0), $token; is $node->schild(1), $token3; my $node2 = $node->clone; $node2->prune('MDOM::Token::Whitespace'); is join('', $node2->elements), 'helloworld'; $node2->prune('Token::Bare'); is join('', $node2->elements), ''; $node->prune('MDOM::Token::Bare'); is join('', $node->elements), ' '; } { my $node = MDOM::Node->new; my $token = MDOM::Token->new('hello'); $node->__add_element($token); my $token2 = MDOM::Token->new('Whitespace', ' '); $node->__add_element($token2); is scalar($node->elements), 2, '2 elements'; is $node->child(0), $token, 'child 0'; is $node->child(1), $token2, 'child 1'; } Makefile-DOM-0.006/t/mdom/gmake/0000755000175000001440000000000011626450365015353 5ustar agentzusersMakefile-DOM-0.006/t/mdom/gmake/directive-define.t0000644000175000001440000000146111622740614020743 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: multi-line var assignment (the 'define' directive) --- src define remote-file $(if $(filter unix, $($1.type)), \ /net/$($1.host)/$($1.path), \ //$($1.host)/$($1.path)) endef --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'define' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'remote-file' MDOM::Token::Whitespace '\n' MDOM::Unknown MDOM::Token::Bare ' ' MDOM::Token::Interpolation '$(if $(filter unix, $($1.type)), \\n /net/$($1.host)/$($1.path), \\n //$($1.host)/$($1.path))' MDOM::Token::Whitespace '\n' MDOM::Directive MDOM::Token::Bare 'endef' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/misc.t0000644000175000001440000000021211622740614016461 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: empty makefile --- src --- dom MDOM::Document::Gmake Makefile-DOM-0.006/t/mdom/gmake/directive-export.t0000644000175000001440000000077411622740614021040 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 13: export + assignment (:=) --- src export foo := 32 --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'export' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '32' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/rule-static-pattern.t0000644000175000001440000000347311622740614021451 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: static pattern rules with ";" command --- src foo.o bar.o: %.o: %.c ; echo blah %.c: ; echo $@ --- dom MDOM::Document::Gmake MDOM::Rule::StaticPattern MDOM::Token::Bare 'foo.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar.o' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.o' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.c' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo blah' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\n' MDOM::Rule::Simple MDOM::Token::Bare '%.c' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace '\n' === TEST 2: static pattern rules without ";" commands --- src foo.o bar.o: %.o: %.c @echo blah --- dom MDOM::Document::Gmake MDOM::Rule::StaticPattern MDOM::Token::Bare 'foo.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar.o' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.o' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.c' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Bare 'echo blah' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/directive-include.t0000644000175000001440000000475511622740614021145 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: the include directive --- src include foo *.mk $(bar) --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'include' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '*.mk' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$(bar)' MDOM::Token::Whitespace '\n' === TEST 2: multi-line include directive --- src include foo *.mk $(bar) \ blah blah --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'include' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '*.mk' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$(bar)' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'blah' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'blah' MDOM::Token::Whitespace '\n' === TEST 3: the -include directive --- src -include filenames... --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Modifier '-' MDOM::Token::Bare 'include' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'filenames...' MDOM::Token::Whitespace '\n' === TEST 4: multi-line -include directive --- src -include foo bar \ $@ $^ --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Modifier '-' MDOM::Token::Bare 'include' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$^' MDOM::Token::Whitespace '\n' === TEST 5: sinclude directive sinclude is another name for -include --- src sinclude %.c src --- dom M::D::G M::D M::T::B 'sinclude' M::T::W ' ' M::T::B '%.c' M::T::W ' ' M::T::B 'src' M::T::W '\n' Makefile-DOM-0.006/t/mdom/gmake/command.t0000644000175000001440000002005711622740614017155 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: blank lines and comment lines as comments blank lines and lines of just comments may appear among the command lines; they are ignored. --- src foo: first # This is ignored second --- dom M::D::G M::R::S M::T::B 'foo' M::T::S ':' M::T::W '\n' M::C M::T::S '\t' M::T::B 'first' M::T::W '\n' M::T::W '\n' M::T::W ' \n' M::T::C '# This is ignored' M::T::W '\n' M::C M::T::S '\t' M::T::B 'second' M::T::W '\n' === TEST 2: empty commands a blank line that begins with a tab is not blank; it's an empty command --- src foo: echo --- dom M::D::G M::R::S M::T::B 'foo' M::T::S ':' M::T::W '\n' M::C M::T::S '\t' M::T::W '\n' M::C M::T::S '\t' M::T::B 'echo' M::T::W '\n' === TEST 3: comments as commands a comment in a command line is not a make comment; it will be passed to the shell as-is. --- src foo: # This is a command, not a comment --- dom M::D::G M::R::S M::T::B 'foo' M::T::S ':' M::T::W '\n' M::C M::T::S '\t' M::T::B '# This is a command, not a comment' M::T::W '\n' === TEST 4: var def as commands a variable definition in a "rule context" which is indented by a tab as the first character on the line, will be considered a command line. --- src foo: var = value var := value var += value var ?= value --- dom M::D::G M::R::S M::T::B 'foo' M::T::S ':' M::T::W '\n' M::C M::T::S '\t' M::T::B 'var = value' M::T::W '\n' M::C M::T::S '\t' M::T::B 'var := value' M::T::W '\n' M::C M::T::S '\t' M::T::B 'var += value' M::T::W '\n' M::C M::T::S '\t' M::T::B 'var ?= value' M::T::W '\n' === TEST 5: conditional directives as commands a conditional expression (ifdef, ifeq, etc) in a "rule context" which is indented by a tab as the first character on the line, will be considered a command line --- src foo: ifdef $(foo) echo endif --- dom M::D::G M::R::S M::T::B 'foo' M::T::S ':' M::T::W '\n' M::C M::T::S '\t' M::T::B 'ifdef ' M::T::I '$(foo)' M::T::W '\n' M::C M::T::S '\t' M::T::B 'echo' M::T::W '\n' M::C M::T::S '\t' M::T::B 'endif' M::T::W '\n' === TEST 6: line continuations in commands --- src a : - mv \#\ + e \ \\ @ --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '-' MDOM::Token::Bare ' mv \#\\n\t+ e \\n \\' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Whitespace '\n' === TEST 7: line continuations in prereqs and "inline" commands --- src a: \ b;\ c \ d --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace '\t' MDOM::Token::Bare 'b' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Bare '\\n c \\n d' MDOM::Token::Whitespace '\n' === TEST 8: whitespace before command modifiers (@) --- src all: @ echo $@ --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Whitespace ' ' MDOM::Token::Modifier '@' MDOM::Token::Bare ' echo ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace '\n' === TEST 9: whitespace before command modifiers (+/-) --- src all: + echo $@ -blah! --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Whitespace ' ' MDOM::Token::Modifier '+' MDOM::Token::Bare ' echo ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Whitespace '\t' MDOM::Token::Modifier '-' MDOM::Token::Bare 'blah!' MDOM::Token::Whitespace '\n' === TEST 10: multi-line commands --- src compile_all: for d in $(source_dirs); \ do \ $(JAVAC) $$d/*.java; \ done --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'compile_all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'for d in ' MDOM::Token::Interpolation '$(source_dirs)' MDOM::Token::Bare '; \\n\tdo \\n\t\t' MDOM::Token::Interpolation '$(JAVAC)' MDOM::Token::Bare ' ' MDOM::Token::Interpolation '$$' MDOM::Token::Bare 'd/*.java; \\n\tdone' MDOM::Token::Whitespace '\n' === TEST 11: multi-modifiers --- src all: @ - exit -@ exit 1 @-exit 1 --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Whitespace ' ' MDOM::Token::Modifier '-' MDOM::Token::Bare ' exit' MDOM::Token::Whitespace '\n' MDOM::Unknown MDOM::Token::Whitespace ' ' MDOM::Token::Modifier '-' MDOM::Token::Modifier '@' MDOM::Token::Bare ' exit 1' MDOM::Token::Whitespace '\n' MDOM::Unknown MDOM::Token::Whitespace ' ' MDOM::Token::Modifier '@' MDOM::Token::Modifier '-' MDOM::Token::Bare 'exit 1' MDOM::Token::Whitespace '\n' === TEST 12: line continuations in commands --- src all: \ echo $@ --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare '\\n\techo ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace '\n' === TEST 13: ditto (with interpolations) --- src all: @echo $(FOO) \ $(BAR) \ $(BIT) --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Bare 'echo ' MDOM::Token::Interpolation '$(FOO)' MDOM::Token::Bare ' \\n ' MDOM::Token::Interpolation '$(BAR)' MDOM::Token::Bare ' \\n\t' MDOM::Token::Interpolation '$(BIT)' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/order_only.t0000644000175000001440000000236111622740614017711 0ustar agentzusersuse t::GmakeDOM; plan tests => 2 * blocks(); run_tests; __DATA__ === TEST 1: --- src foo:|bar; --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'foo' MDOM::Token::Separator ':' MDOM::Token::Bare '|' MDOM::Token::Bare 'bar' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace '\n' === TEST 2: --- src foo: a b| c d --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'foo' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'a' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Bare '|' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'd' MDOM::Token::Whitespace '\n' === TEST 3: --- src foo: a| --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'foo' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'a' MDOM::Token::Bare '|' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/interpolation.t0000644000175000001440000000436311622740614020430 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: variable references in prereq list --- src a: foo.c bar.h $(baz) # hello! @echo ... --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo.c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar.h' MDOM::Token::Whitespace '\t' MDOM::Token::Interpolation '$(baz)' MDOM::Token::Whitespace ' ' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '@' MDOM::Token::Bare 'echo ...' MDOM::Token::Whitespace '\n' === TEST 2: variable interpolation cannot be escaped by \ --- src all: ; echo \$a --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo \' MDOM::Token::Interpolation '$a' MDOM::Token::Whitespace '\n' === TEST 3: $@, $a, etc. --- src all: $a $(a) ${c} echo $@ $a ${a} ${abc} ${} --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$a' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$(a)' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '${c}' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'echo ' MDOM::Token::Interpolation '$@' MDOM::Token::Bare ' ' MDOM::Token::Interpolation '$a' MDOM::Token::Bare ' ' MDOM::Token::Interpolation '${a}' MDOM::Token::Bare ' ' MDOM::Token::Interpolation '${abc}' MDOM::Token::Bare ' ' MDOM::Token::Interpolation '${}' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/directive-vpath.t0000644000175000001440000000371611622740614020640 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: --- src vpath %.c src:../headers vpath %.d vpath --- dom M::D::G M::D M::T::B 'vpath' M::T::W ' ' M::T::B '%.c' M::T::W ' ' M::T::B 'src' M::T::S ':' M::T::B '../headers' M::T::W '\n' M::D M::T::B 'vpath' M::T::W ' ' M::T::B '%.d' M::T::W '\n' M::D M::T::B 'vpath' M::T::W '\n' === TEST 1: the vpath directive --- src vpath %.1 %.c src vpath %h include --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'vpath' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.1' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'src' MDOM::Token::Whitespace '\n' MDOM::Directive MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'vpath' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%h' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'include' MDOM::Token::Whitespace '\n' === TEST 2: multi-line vpath directive --- src vpath %.1 %.c src \ %h include --- dom MDOM::Document::Gmake MDOM::Directive MDOM::Token::Bare 'vpath' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.1' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%.c' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'src' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '%h' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'include' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/comment.t0000644000175000001440000001033011622740614017172 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: single-line comment --- src # This is a comment --- dom M::D::G M::T::C '# This is a comment' M::T::W '\n' === TEST 2: comment indented by spaces --- src # comment indented by spaces --- dom M::D::G M::T::W ' ' M::T::C '# comment indented by spaces' M::T::W '\n' === TEST 3: --- src foo.o : foo.c defs.h # module for twiddling the frobs cc -c -g foo.c --- dom M::D::G M::R::S M::T::B 'foo.o' M::T::W ' ' M::T::S ':' M::T::W ' ' M::T::B 'foo.c' M::T::W ' ' M::T::B 'defs.h' M::T::W ' ' M::T::C '# module for twiddling the frobs' M::T::W '\n' M::C M::T::S '\t' M::T::B 'cc -c -g foo.c' M::T::W '\n' === TEST 4: comments indented by a tab outside the "rule context" --- src # This is a comment rather than a command --- dom M::D::G M::T::W '\t' M::T::C '# This is a comment rather than a command' M::T::W '\n' === TEST 5: comments indented by a tab within the "rule context" --- src foo : bar # This is a shell command --- dom M::D::G M::R::S M::T::B 'foo' M::T::W ' ' M::T::S ':' M::T::W ' ' M::T::B 'bar' M::T::W '\n' M::C M::T::S '\t' M::T::B '# This is a shell command' M::T::W '\n' === TEST 6: line continuations in comments --- src a: b # hello! \ this is comment too! \ so is this line # this is a cmd +touch $$ --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace ' ' MDOM::Token::Comment '# hello! \\n\tthis is comment too! \\n so is this line' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare '# this is a cmd' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Modifier '+' MDOM::Token::Bare 'touch ' MDOM::Token::Interpolation '$$' MDOM::Token::Whitespace '\n' === TEST 7: unescaped '#' --- src all: foo\\# hello --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo\\' MDOM::Token::Comment '# hello' MDOM::Token::Whitespace '\n' === TEST 8: when no space between words and '#' --- src bar: foo#hello --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'bar' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Comment '#hello' MDOM::Token::Whitespace '\n' === TEST 9: '#' escaped by '\' --- src \#a: \#b \#c --- dom M::D::G M::R::S M::T::B '\#a' M::T::S ':' M::T::W ' ' M::T::B '\#b' M::T::W ' ' M::T::B '\#c' M::T::W '\n' === TEST 10: standalone single-line comment --- src # hello #world! --- dom MDOM::Document::Gmake MDOM::Token::Comment '# hello' MDOM::Token::Whitespace '\n' MDOM::Token::Comment '#world!' MDOM::Token::Whitespace '\n' === TEST 11: standalone multi-line comment --- src # hello \ world\ ! --- dom MDOM::Document::Gmake MDOM::Token::Comment '# hello \\n\tworld\\n !' MDOM::Token::Whitespace '\n' === TEST 12: comments indented by a tab --- src # blah --- dom MDOM::Document::Gmake MDOM::Token::Whitespace '\t' MDOM::Token::Comment '# blah' MDOM::Token::Whitespace '\n' === TEST 13: multi-line comment indented with tabs --- src # blah \ hello!\ # hehe --- dom MDOM::Document::Gmake MDOM::Token::Whitespace '\t' MDOM::Token::Comment '# blah \\nhello!\\n\t# hehe' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/assignment.t0000644000175000001440000001623511622740614017712 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: recursively expanded variable setting --- src foo = bar --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace '\n' === TEST 2: recursively expanded variable setting (more complex) --- src $(foo) = baz $(hey) --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Interpolation '$(foo)' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'baz' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$(hey)' MDOM::Token::Whitespace '\n' === TEST 3: var assignment changed the "rule context" to VOID --- src a: b foo = bar # hello! --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace '\n' MDOM::Assignment MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\t' MDOM::Token::Comment '# hello!' MDOM::Token::Whitespace '\n' === TEST 4: assignment indented by a tab which is not in the "rule context" --- src foo = bar # this line begins with a tab --- dom M::D::G MDOM::Assignment MDOM::Token::Whitespace '\t' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'bar' MDOM::Token::Whitespace ' ' MDOM::Token::Comment '# this line begins with a tab' MDOM::Token::Whitespace '\n' === TEST 5: simply-expanded var assignment --- src a := $($($(x))) --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'a' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':=' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$($($(x)))' MDOM::Token::Whitespace '\n' === TEST 6: multi-line var assignment (recursively-expanded) --- src SOURCES = count_words.c \ lexer.c \ counter.c --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'SOURCES' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'count_words.c' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'lexer.c' MDOM::Token::Whitespace '\t' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace '\t\t' MDOM::Token::Bare 'counter.c' MDOM::Token::Whitespace '\n' === TEST 7: multi-line var assignment (simply-expanded) --- src SOURCES := count_words.c \ lexer.c \ counter.c --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'SOURCES' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'count_words.c' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'lexer.c' MDOM::Token::Whitespace '\t' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace '\t\t' MDOM::Token::Bare 'counter.c' MDOM::Token::Whitespace '\n' === TEST 8: other assignment variations (simply-expanded) --- src override foo := 32 --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'override' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '32' MDOM::Token::Whitespace '\n' === TEST 9: override + assignment (=) --- src override foo = 32 --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'override' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '32' MDOM::Token::Whitespace '\n' === TEST 10: override + assignment (:=) --- src override foo := 32 --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'override' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'foo' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '32' MDOM::Token::Whitespace '\n' === TEST 11: override + assignment (+=) --- src override CFLAGS += $(patsubst %,-I%,$(subst :, ,$(VPATH))) --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'override' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'CFLAGS' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '+=' MDOM::Token::Whitespace ' ' MDOM::Token::Interpolation '$(patsubst %,-I%,$(subst :, ,$(VPATH)))' MDOM::Token::Whitespace '\n' === TEST 12: override + assignment (?=) --- src override files ?= main.o kbd.o command.o display.o \ insert.o search.o files.o utils.o --- dom MDOM::Document::Gmake MDOM::Assignment MDOM::Token::Bare 'override' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'files' MDOM::Token::Whitespace ' ' MDOM::Token::Separator '?=' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'main.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'kbd.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'command.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'display.o' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'insert.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'search.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'files.o' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'utils.o' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/gmake/rule-simple.t0000644000175000001440000001327311622740614017777 0ustar agentzusersuse t::GmakeDOM; plan tests => blocks() * 2; run_tests; __DATA__ === TEST 1: "hello world" one-linner (with whitespace) --- src all : ; echo "hello, world" --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'echo "hello, world"' MDOM::Token::Whitespace '\n' === TEST 2: "hello world" one-linner (without whitespace) --- src all:;echo "hello, world" --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Bare 'echo "hello, world"' MDOM::Token::Whitespace '\n' === TEST 3: "hello world" makefile --- src all: echo "hello, world" --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'echo "hello, world"' MDOM::Token::Whitespace '\n' === TEST 4: multiple commands --- src all : pwd cp t/a t/b perl -e 'print "hello, world!\n"' --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'all' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'pwd' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'cp t/a t/b' MDOM::Token::Whitespace '\n' MDOM::Command MDOM::Token::Separator '\t' MDOM::Token::Bare 'perl -e \'print "hello, world!\n"\'' MDOM::Token::Whitespace '\n' === TEST 5: simple rule with an empty command --- src a: b ; --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace '\n' === TEST 6: simple rule without any commands --- src a : b --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'b' MDOM::Token::Whitespace '\n' === TEST 7: weird target/prereq names --- src @a: @b @c+! --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare '@a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '@b' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '@c+!' MDOM::Token::Whitespace '\n' === TEST 8: line continuations in prereq list and weird target names --- src @a:\ @b @c @b : ; @c:;; --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare '@a' MDOM::Token::Separator ':' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace '\t ' MDOM::Token::Bare '@b' MDOM::Token::Whitespace ' ' MDOM::Token::Bare '@c' MDOM::Token::Whitespace '\n' MDOM::Token::Whitespace '\n' MDOM::Rule::Simple MDOM::Token::Bare '@b' MDOM::Token::Whitespace ' ' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Whitespace '\n' MDOM::Rule::Simple MDOM::Token::Bare '@c' MDOM::Token::Separator ':' MDOM::Command MDOM::Token::Separator ';' MDOM::Token::Bare ';' MDOM::Token::Whitespace '\n' === TEST 9: line continuations in prereq list --- src a: \ b\ c \ d --- dom MDOM::Document::Gmake MDOM::Rule::Simple MDOM::Token::Bare 'a' MDOM::Token::Separator ':' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace '\t' MDOM::Token::Bare 'b' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'c' MDOM::Token::Whitespace ' ' MDOM::Token::Continuation '\\n' MDOM::Token::Whitespace ' ' MDOM::Token::Bare 'd' MDOM::Token::Whitespace '\n' === TEST 10: suffix (-like) rules --- src .SUFFIXES: .c.o: echo "hello $ blocks() * 2; run_tests; __DATA__ === TEST 1: unknown entities --- src a $(foo) echo $@ --- dom MDOM::Document::Gmake MDOM::Unknown MDOM::Token::Bare 'a ' MDOM::Token::Interpolation '$(foo)' MDOM::Token::Whitespace '\n' MDOM::Unknown MDOM::Token::Bare '\techo ' MDOM::Token::Interpolation '$@' MDOM::Token::Whitespace '\n' Makefile-DOM-0.006/t/mdom/token.t0000644000175000001440000000305711622740614015574 0ustar agentzusersuse strict; use warnings; # Execute the tests use Test::More tests => 26; BEGIN { use_ok('MDOM::Token'); } my $token = MDOM::Token->new('hello!'); ok $token, 'obj ok'; isa_ok $token, 'MDOM::Token::Bare', 'bare ok'; isa_ok $token, 'MDOM::Token', 'token ok'; is "$token", 'hello!', 'stringify ok'; ok $token->significant, 'plain tokens are significant by default'; $token->set_content('wow'); is $token->content, 'wow', 'set/get_content ok'; $token->add_content('~~~'); is $token->content, 'wow~~~', 'add_content ok'; $token = MDOM::Token->new('Whitespace', "\n\t "); isa_ok $token, 'MDOM::Token::Whitespace'; isa_ok $token, 'MDOM::Token'; is $token->content, "\n\t ", 'ws content ok'; ok !$token->significant, 'ws is not significant'; $token = MDOM::Token->new('Separator', ":="); isa_ok $token, 'MDOM::Token::Separator'; isa_ok $token, 'MDOM::Token'; is $token->content, ':=', 'sp content ok'; ok $token->significant, 'separators are significant'; $token = MDOM::Token->new('Comment', "# blah blah blah"); isa_ok $token, 'MDOM::Token::Comment'; isa_ok $token, 'MDOM::Token'; is $token->content, "# blah blah blah", 'cmt content ok'; $token->add_content("\n hey!"); is "$token", "# blah blah blah\n hey!", 'cmt add_content ok'; ok !$token->significant, 'comments are not significant'; $token = MDOM::Token->new('Continuation', "\\\n"); isa_ok $token, 'MDOM::Token::Continuation'; isa_ok $token, 'MDOM::Token'; is $token->content, "\\\n"; ok !$token->significant, 'line continuations are not significant'; $token = MDOM::Token::Whitespace->new("\n"); is $token->content, "\n"; Makefile-DOM-0.006/t/mdom/assignment.t0000644000175000001440000000261711622740614016625 0ustar agentzusersuse lib 'inc'; use Test::Base; use MDOM::Document::Gmake; plan tests => 8 * blocks(); run { my $block = shift; my $name = $block->name; my $dom = MDOM::Document::Gmake->new(\$block->src); ok $dom, "DOM tree okay - $name"; my $assign = $dom->child(0); ok $assign, "Assignment obj okay - $name"; my @got_lhs = $assign->lhs; my @expected_lhs = eval $block->lhs; die "eval lhs failed ($name) - $@" if $@; is fmt(@got_lhs), fmt(@expected_lhs), "lhs array okay - $name"; is join('', @{ scalar($assign->lhs) }), join('', @expected_lhs), "lhs calar okay - $name"; ok $assign, "Assignment obj okay - $name"; my @got_rhs = $assign->rhs; my @expected_rhs = eval $block->rhs; die "eval rhs failed ($name) - $@" if $@; is fmt(@got_rhs), fmt(@expected_rhs), "rhs array okay - $name"; is join('', @{ scalar($assign->rhs) }), join('', @expected_rhs), "rhs calar okay - $name"; is $assign->op, $block->op, "op okay - $name"; }; sub fmt { join ', ', map { "'$_'" } @_; } __DATA__ === TEST 1: --- src a := 3 --- lhs 'a' --- op: := --- rhs '3' === TEST 2: --- src foo bar=hello, world ! # this is a comment --- lhs 'foo', ' ', 'bar' --- op: = --- rhs 'hello,', ' ', 'world', ' ', '!', ' ' === TEST 3: --- src @D ?= hello \ world! --- lhs '@D' --- op: ?= --- rhs 'hello', ' ', "\\\n", "\t", 'world!' Makefile-DOM-0.006/t/mdom/rule-simple.t0000644000175000001440000000314211622740614016705 0ustar agentzusersuse lib 'inc'; use Test::Base; use MDOM::Document::Gmake; #use Smart::Comments; plan tests => 8 * blocks(); run { my $block = shift; my $name = $block->name; my $dom = MDOM::Document::Gmake->new(\$block->src); ok $dom, "DOM tree okay - $name"; my $rule = $dom->child(0); ok $rule, "Assignment obj okay - $name"; my @got_targets = $rule->targets; my @expected_targets = eval $block->targets; die "eval targets failed ($name) - $@" if $@; is fmt(@got_targets), fmt(@expected_targets), "targets array okay - $name"; is join('', @{ scalar($rule->targets) }), join('', @expected_targets), "targets calar okay - $name"; ok $rule, "Assignment obj okay - $name"; my @got_prereqs = $rule->normal_prereqs; my @expected_prereqs = eval $block->prereqs; die "eval prereqs failed ($name) - $@" if $@; is fmt(@got_prereqs), fmt(@expected_prereqs), "prereqs array okay - $name"; is join('', @{ scalar($rule->normal_prereqs) }), join('', @expected_prereqs), "prereqs calar okay - $name"; is $rule->colon, $block->colon, "colon okay - $name"; }; sub fmt { join ', ', map { "'$_'" } @_; } __DATA__ === TEST 1: --- src a.c b.cpp : a.h dir/hello.h --- targets 'a.c', ' ', 'b.cpp' --- colon: : --- prereqs 'a.h', ' ', 'dir/hello.h' === TEST 2: --- src abc:: hello, world # this is a comment --- targets 'abc' --- colon: :: --- prereqs 'hello,', ' ', 'world' === TEST 3: --- src %.a :: b \ c \ d --- targets '%.a' --- colon: :: --- prereqs 'b', ' ', "\\\n", ' ', 'c', ' ', "\\\n", ' ', 'd' Makefile-DOM-0.006/t/GmakeDOM.pm0000644000175000001440000000250611622740614015253 0ustar agentzuserspackage t::GmakeDOM; use lib 'inc'; use Test::Base -Base; use MDOM::Document::Gmake; use MDOM::Dumper; our @EXPORT = qw( run_tests ); sub run_test ($) { my $block = shift; my $name = $block->name; my $src = $block->src; my $dom = MDOM::Document::Gmake->new( \$src ); ok $dom, "$name - DOM defined"; my $dumper = MDOM::Dumper->new($dom); my $got = $dumper->string; my $expected = $block->dom; # canonicalize the whitespace: $got =~ s/(?x) ^ ( \s* [\w:]+ ) [ \t]+/$1\t\t/gm; $expected =~ s/(?x) ^ ( \s* [\w:]+ ) [ \t]+/$1\t\t/gm; # process abbreviations: $expected =~ s/\bM::D::G\b/MDOM::Document::Gmake/gs; $expected =~ s/\bM::D\b/MDOM::Directive/gs; $expected =~ s/\bM::R::S\b/MDOM::Rule::Simple/gs; $expected =~ s/\bM::T::C\b/MDOM::Token::Comment/gs; $expected =~ s/\bM::T::W\b/MDOM::Token::Whitespace/gs; $expected =~ s/\bM::T::S\b/MDOM::Token::Separator/gs; $expected =~ s/\bM::T::B\b/MDOM::Token::Bare/gs; $expected =~ s/\bM::T::M\b/MDOM::Token::Modifier/gs; $expected =~ s/\bM::T::I\b/MDOM::Token::Interpolation/gs; $expected =~ s/\bM::C\b/MDOM::Command/gs; is $got, $expected, "$name - DOM structure ok"; #warn $dumper->string if $name =~ /TEST 0/; } sub run_tests () { for my $block (blocks()) { run_test($block); } } 1; Makefile-DOM-0.006/t/lib/0000755000175000001440000000000011626450365014101 5ustar agentzusersMakefile-DOM-0.006/t/lib/Test/0000755000175000001440000000000011626450365015020 5ustar agentzusersMakefile-DOM-0.006/t/lib/Test/Make/0000755000175000001440000000000011626450365015675 5ustar agentzusersMakefile-DOM-0.006/t/lib/Test/Make/Base.pm0000644000175000001440000001271511622740614017106 0ustar agentzusers#: t/Backend/Base.pm package Test::Make::Base; #use Smart::Comments; use lib 'inc'; use Test::Base -Base; use Test::Make::Util; use File::Temp qw( tempdir tempfile ); use Cwd (); use File::Spec (); use FindBin; use IPC::Run3; use Time::HiRes qw( time ); #use Data::Dumper::Simple; our @EXPORT = qw( run_test run_tests create_file use_source_ditto $MAKE $PERL $SHELL $PWD ); our @EXPORT_BASE = qw(set_make set_shell set_filters); our ($SHELL, $PERL, $MAKE, $MAKEPATH, $MAKEFILE, $PWD); our (@MakeExe, %Filters); our ($UseSourceDitto, $SavedSource); # default filters for expected values #filters { # stdout => [qw< preprocess >], # stdour_like => [qw< preprocess_like >], # stderr => [qw< preprocess >], # stderr_like => [qw< preprocess_like >], #}; sub set_make ($$) { my ($env_name, $default) = @_; $MAKEPATH = $ENV{$env_name} || $default; $MAKEPATH =~ s,\\,/,g; my $stderr; run3 [split(/\s+/, $MAKEPATH), '-f', 'no/no/no'], \undef, \undef, \$stderr; #die $stderr; if ($stderr =~ /^(\S+)\s*:/) { $MAKE = $1; $MAKE =~ s/(.*[\\\/])//; } else { $MAKE = ''; } ### $MAKE #$MAKE =~ s{\\}{/}g; } sub set_shell ($$) { my ($env_name, $default) = @_; $SHELL = $ENV{$env_name} || $default; } BEGIN { if ($^O =~ / /) { $PERL = 'perl'; } else { $PERL = $^X; } #warn $PERL; # Get a clean environment clean_env(); # Delay the Test::Base filters filters_delay(); } sub use_source_ditto () { $UseSourceDitto = 1; } sub run_test ($) { my $block = shift; my $tempdir = tempdir( 'backend_XXXXXX', TMPDIR => 1, CLEANUP => 1 ); my $saved_cwd = Cwd::cwd; chdir $tempdir; $PWD = $tempdir; $PWD =~ s,\\,/,g; %::ExtraENV = (); my $filename = $block->filename; chomp $filename if $filename; my $source = $block->source; if (defined $source) { my $fh; if (not $filename) { ($fh, $filename) = tempfile( "Makefile_XXXXX", DIR => '.', UNLINK => 1 ); } else { open $fh, "> $filename" or confess("can't open $filename for writing: $!"); } $MAKEFILE = $filename; $MAKEFILE =~ s,\\,/,g; $block->run_filters; $SavedSource = $block->source if $UseSourceDitto; print $fh $block->source; close $fh; } else { $block->run_filters; $filename = $block->filename; } process_pre($block); process_touch($block); process_utouch($block); { no warnings 'uninitialized'; local %ENV = %ENV; %ENV = (%ENV, %::ExtraENV) if %::ExtraENV; run_make($block, $filename); process_post($block); process_found($block); process_not_found($block); %::ExtraENV = (); } chdir $saved_cwd; #warn "\nstderr: $stderr\nstdout: $stdout\n"; } sub run_tests () { for my $block (blocks()) { run_test($block); } } sub create_file ($$) { my ($filename, $content) = @_; my $fh; if (not $filename) { ($fh, $filename) = tempfile( "create_file_XXXXX", DIR => '.', UNLINK => 1 ); } else { open $fh, "> $filename" or confess("can't open $filename for writing: $!"); } #$content .= "\n\nSHELL=$SHELL" if $SHELL; print $fh $content; close $fh; return $filename; } sub process_touch ($) { my $block = shift; my $buf = $block->touch; return if not $buf; touch(split /\s+/, $buf); } sub process_utouch ($) { my $block = shift; my $buf = $block->utouch; return if not $buf; my @pairs = split /\s+/, $buf; ### @pairs while (@pairs) { my $time = shift @pairs; my $file = shift @pairs; utouch($time => $file); } } sub set_filters (@) { %Filters = @_; } # returns ($errcode, $stdout, $stderr) or $errcode sub run_make($$) { my ($block, $filename) = @_; my $options = $block->options || ''; my $goals = $block->goals || ''; @MakeExe = split_arg($MAKEPATH) if not @MakeExe; #warn Dumper($filename); my (@pre, @post); if ($filename and $options !~ /-f\s+\S+/) { push @pre, '-f', $filename; } if ($SHELL and $options !~ m/SHELL\s*=\s*/ and $^O eq 'MSWin32') { push @post, "SHELL=$SHELL"; } my $cmd = [ @MakeExe, @pre, process_args("$options $goals"), @post, ]; #warn Dumper($cmd); test_shell_command( $block, $cmd, %Filters ); } package Test::Make::Base::Filter; use Test::Base::Filter -Base; sub quote { qq/"$_[0]"/; } sub preprocess { my $s = shift; return if not defined $s; ### $Test::Make::Bae::MAKE $s =~ s/\#MAKE\#/$Test::Make::Base::MAKE/gsi; $s =~ s/\#MAKEPATH\#/$Test::Make::Base::MAKEPATH/gs; $s =~ s/\#MAKEFILE\#/$Test::Make::Base::MAKEFILE/gs; $s =~ s/\#PWD\#/$Test::Make::Base::PWD/gs; return $s; } sub preprocess_like { my $s = shift; return if not defined $s; $s =~ s/\#MAKE\#/quotemeta $Test::Make::Base::MAKE/gse; $s =~ s/\#MAKEPATH\#/quotemeta $Test::Make::Base::MAKEPATH/gse; $s =~ s/\#MAKEFILE\#/quotemeta $Test::Make::Base::MAKEFILE/gse; $s =~ s/\#PWD\#/quotemeta $Test::Make::Base::PWD/gse; return $s; } sub expand { my $s = shift; return if not $s; return eval(qq{"$s"}); } sub ditto { if (!defined $UseSourceDitto) { die "Error: ditto found while no use_source_ditto call.\n"; } $SavedSource; } 1; Makefile-DOM-0.006/t/lib/Test/Make/Util.pm0000644000175000001440000000361411622740614017147 0ustar agentzuserspackage Test::Make::Util; use Test::Util -Base; #use Data::Dumper::Simple; our @EXPORT = qw( process_args touch utouch clean_env ); sub process_args ($) { my $text = shift; my @args = split_arg($text); foreach (@args) { #warn "----------\n"; #warn Dumper(@args, $_); #warn "----------\n"; if (/^"(.*)"$/) { #warn "---------"; #warn qq{Pusing "$1" into args\n}; $_ = $1; process_escape( $_, q{"\\$@\#} ); } elsif (/^'(.*)'$/) { #warn " Pusing '$1' into args\n"; $_ = $1; } } return @args; } sub touch (@) { utouch(0, @_); } # Touch with a time offset. To DTRT, call touch() then use stat() to get the # access/mod time for each file and apply the offset. sub utouch ($@) { my $off = shift; my @files = @_; foreach my $file (@files) { my $in; open $in, ">>$file" or print $in '' or close $in or die "Can't touch $file: $!"; } my (@s) = stat($files[0]); utime($s[8] + $off, $s[9] + $off, @files); } # the current implementation of clean_env is buggy. haven't found a better approach sub clean_env () { # Get a clean environment my %makeENV = (); # Pull in benign variables from the user's environment # foreach (# UNIX-specific things 'TZ', 'LANG', 'TMPDIR', 'HOME', 'USER', 'LOGNAME', 'PATH', # Purify things 'PURIFYOPTIONS', # Windows NT-specific stuff 'Path', 'SystemRoot', 'TMP', 'SystemDrive', 'TEMP', 'OS', 'HOMEPATH', # DJGPP-specific stuff 'DJDIR', 'DJGPP', 'SHELL', 'COMSPEC', 'HOSTNAME', 'LFN', 'FNCASE', '387', 'EMU387', 'GROUP', 'GNU_MAKE_PATH', 'GNU_SHELL_PATH', 'INC', 'path', ) { $makeENV{$_} = $ENV{$_} if defined $ENV{$_}; } %ENV = (); %ENV = %makeENV; } 1; Makefile-DOM-0.006/t/lib/Test/Util/0000755000175000001440000000000011626450365015735 5ustar agentzusersMakefile-DOM-0.006/t/lib/Test/Util/Base.pm0000644000175000001440000000222211622740614017136 0ustar agentzusers#: facilities used by script/sh and also shared by the testers package Test::Util::Base; use Spiffy -Base; use Text::Balanced qw( gen_delimited_pat ); our @EXPORT = qw( split_arg process_escape ); our $DelimPat; BEGIN { $DelimPat = gen_delimited_pat(q{"}); } sub extract_many (@) { my $text = shift; my @flds; while (1) { #warn '@flds = ', Dumper(@flds); if ($text =~ /\G\s* ( ; | >>? | < | \|\| | \&\& ) /gcox) { push @flds, $1; } elsif ($text =~ /\G\s* ( (?:\\.)+ [^'";><\|\&\s]* )/gcox) { push @flds, $1; } elsif ($text =~ /\G\s*('[^']*')/gco) { push @flds, $1; } elsif ($text =~ /\G\s*($DelimPat)/gco) { push @flds, $1; } elsif ($text =~ /\G\s*( \S (?:[^ ; > < ' " \s \\ \| \& ]|\\.)* )/gcox) { push @flds, $1; } else { last; } } return @flds; } sub split_arg ($) { my $text = shift; return () if not defined $text; return extract_many($text); } sub process_escape (@) { return if $_[0] !~ /\\/; my $list = quotemeta $_[1]; $_[0] =~ s/\\[$list]/substr($&,1,1)/eg; } 1; Makefile-DOM-0.006/t/lib/Test/Util.pm0000644000175000001440000000667111622740614016300 0ustar agentzuserspackage Test::Util; use Test::Util::Base -Base; use Carp qw( confess ); use IPC::Run3; #use Data::Dumper::Simple; our @EXPORT = qw( test_shell_command run_shell split_arg join_list process_pre process_post process_found process_not_found ); sub process_pre ($) { my $block = shift; my $code = $block->pre; return if not $code; { package main; eval $code; } confess "error in `pre' section: $@" if $@; } sub process_post ($) { my $block = shift; my $code = $block->post; return if not $code; { package main; eval $code; } confess "error in `post' section: $@" if $@; } sub process_found ($) { my $block = shift; my $buf = $block->found; return if not $buf; my @files = split /\s+/s, $buf; for my $file (@files) { Test::More::ok( (-f $file), "File $file should be found - ".$block->name ); } } sub process_not_found ($) { my $block = shift; my $buf = $block->not_found; return if not $buf; my @files = split /\s+/s, $buf; for my $file (@files) { Test::More::ok( !(-f $file), "File $file should NOT be found - ".$block->name ); } } sub compare ($$$) { my ($got, $expected, $desc) = @_; return if not defined $expected; if ($desc =~ /\w+_like/) { Test::More::like($got, qr/^$expected$/ms, $desc); } else { Test::More::is($got, $expected, $desc); } } sub join_list (@) { my @args = @_; for (@args) { if (ref $_ eq 'ARRAY') { $_ = join('', @$_); } } return wantarray ? @args : $args[0]; } sub test_shell_command ($$@) { my $block = shift; my $cmd = shift; my %filters = @_; return if not defined $cmd; my ($stdout, $stderr); run3($cmd, \undef, \$stdout, \$stderr); my $errcode = $?; $errcode >>= 8; my $success = ($errcode == 0); my $errcode2 = $block->error_code; if ($errcode2 and $errcode2 =~ /\d+/) { $errcode2 = $&; } my $success2 = $block->success; if ($success2 and $success2 =~ /\w+/) { $success2 = lc($&); } my $name = $block->name; while (my ($key, $val) = each %filters) { #warn "$key $val"; if ($key eq 'stdout') { $stdout = $val->($stdout); } elsif ($key eq 'stderr') { $stderr = $val->($stderr); } } #warn "!!!~~~~ $stdout"; #warn "!!!~~~~ ", $block->stdout; #use Test::Differences; #eq_or_diff $stdout, $block->stdout; compare $stdout, $block->stdout, "stdout - $name"; compare $stdout, $block->stdout_like, "stdout_like - $name"; compare $stderr, $block->stderr, "stderr - $name"; compare $stderr, $block->stderr_like, "stderr_like - $name"; compare $errcode, $errcode2, "error_code - $name"; compare ( $success ? 'true' : 'false', $success2, "success - $name", ); if (not defined $block->stderr() and not defined $block->stderr_like() and $stderr) { warn $stderr; } } # returns ($error_code, $stdout, $stderr) sub run_shell (@) { my ($cmd, $verbose) = @_; #$IPC::Cmd::USE_IPC_RUN = 1; #confess Dumper($cmd); my ($stdout, $stderr); run3($cmd, \undef, \$stdout, \$stderr); my $errcode = $?; #warn "HERE!"; #warn "^^^ Output: $res[2][0]"; return ($errcode, $stdout, $stderr); } 1; Makefile-DOM-0.006/t/pod-coverage.t0000644000175000001440000000023011626447256016073 0ustar agentzusersuse Test::More; eval "use Test::Pod::Coverage"; plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@; all_pod_coverage_ok(); Makefile-DOM-0.006/t/pod.t0000644000175000001440000000017011626447543014304 0ustar agentzusersuse Test::More; eval "use Test::Pod"; plan skip_all => "Test::Pod required for testing POD" if $@; all_pod_files_ok(); Makefile-DOM-0.006/t/Gmake.pm0000644000175000001440000000206711622740614014715 0ustar agentzuserspackage t::Gmake; use lib 't/lib'; use Test::Make::Base -Base; use FindBin; #use Smart::Comments; my $UTIL_PATH = File::Spec->catdir($FindBin::Bin, '../../../script'); my $MAIN_PATH = File::Spec->catdir($FindBin::Bin, '../../../script'); my $sh_vm = $PERL . ' ' . File::Spec->catfile($UTIL_PATH, 'sh'); $sh_vm = $^O eq 'MSWin32' ? 'sh' : '/bin/sh'; my $pgmake = $PERL . ' ' . File::Spec->catfile($MAIN_PATH, 'pgmake'); $pgmake = 'make'; $ENV{MAKELEVEL} = 0; set_make('GNU_MAKE_PATH', $pgmake); set_shell('GNU_SHELL_PATH', $sh_vm); set_filters( stdout => sub { my ($s) = @_; return $s if ! $s; return $s; }, stderr => sub { my ($s) = @_; return $s if ! $s; $s =~ s/^$MAKE(?:\[\d+\])?:\s+Warning:\s+File `\S+' has modification time \S+ s in the future\n//gsmi; $s =~ s/^$MAKE(?:\[\d+\])?:\s+warning: Clock skew detected\. Your build may be incomplete\.\n//gsmi; $s =~ s{\.\\Makefile_}{./Makefile_}g; return $s; }, ); # to ease debugging (the output is normally small) #no_diff(); 1; Makefile-DOM-0.006/t/Shell.pm0000644000175000001440000000331611622740614014736 0ustar agentzusers#: t/Shell.pm #: Testing framework for t/sh/*.t #: Copyright (c) 2006 Zhang "agentzh" Yichun #: 2006-02-02 2006-02-10 package t::Shell; use lib 't/lib'; use lib 'inc'; use Test::Base -Base; use Test::Util; use FindBin; use Cwd; use File::Temp qw( tempdir ); #use Data::Dumper::Simple; our @EXPORT = qw( run_tests run_test ); filters { cmd => [qw< chomp >], error_code => [qw< eval >], }; our $SHELL; BEGIN { $SHELL = $ENV{TEST_SHELL_PATH} || "$^X $FindBin::Bin/../../script/sh"; no_diff(); } sub run_test ($) { my $block = shift; #warn Dumper($block->cmd); my $tempdir = tempdir( 'backend_XXXXXX', TMPDIR => 1, CLEANUP => 1 ); my $saved_cwd = Cwd::cwd; chdir $tempdir; process_pre($block); my $cmd = [ split_arg($SHELL), '-c', $block->cmd() ]; if ($^O eq 'MSWin32' and $block->stdout and $block->stdout eq qq{\\"\n}) { workaround($block, $cmd); } else { test_shell_command($block, $cmd); } process_found($block); process_not_found($block); process_post($block); chdir $saved_cwd; } sub workaround (@) { my ($block, $cmd) = @_; my ($error_code, $stdout, $stderr) = run_shell( $cmd ); #warn Dumper($stdout); my $stdout2 = $block->stdout; my $stderr2 = $block->stderr; my $error_code2 = $block->error_code; my $name = $block->name; SKIP: { skip 'Skip the test uncovers quoting issue on Win32', 3 if 1; is ($stdout, $stdout2, "stdout - $name"); is ($stderr, $stderr2, "stderr - $name"); is ($error_code, $error_code2, "error_code - $name"); } } sub run_tests () { for my $block (blocks) { run_test($block); } } 1; Makefile-DOM-0.006/script/0000755000175000001440000000000011626450365014374 5ustar agentzusersMakefile-DOM-0.006/script/sh0000644000175000001440000001264711622740614014736 0ustar agentzusers#!perl #: sh #: Perl simulator for /bin/sh (Bourne Shell) #: 2006-02-01 2006-02-13 use strict; use warnings; use FindBin; use lib "$FindBin::Bin/.."; use lib "$FindBin::Bin/../t/lib"; use Test::Util::Base; #use Smart::Comments; use Getopt::Std; use Time::HiRes qw( sleep ); my %opts; getopts('c', \%opts); my $ExitCode = 0; my $RedirectIndex; $| = 1; if ($opts{c}) { eval { process_shell(join ' ', @ARGV); }; warn $@ if $@; exit($ExitCode); } else { print '$ '; process_prompt(); exit(0); } sub process_prompt { while () { chomp; ### Got shell: $_ last if /^\s*exit(?:\s+\d+)?\s*$/; eval { process_shell($_); }; if ($@) { warn "$@\n"; warn "[Error code $ExitCode returned.]\n"; } print '$ '; } } sub process_shell { my $cmd = shift; #warn Dumper($cmd); $cmd =~ s/\n+/ /gso; my @raw_args = split_arg($cmd); ### @raw_args my @args = process_args(0, @raw_args); return eval_cmd(@args); } sub process_args ($$) { #warn "!!!!!!!!!!!!!!!!!!!!!!"; my $level = shift; my @raw_args = @_; my @args; foreach (@raw_args) { #warn "----------\n"; #warn Dumper(@args, $_, @raw_args); #warn "----------\n"; if ($_ eq ';') { eval_cmd(@args); @args = (); } elsif ($_ eq '>' or $_ eq '>>' or $_ eq '<') { $RedirectIndex = $#args; push @args, $_; } elsif ($_ eq '&&') { eval_cmd(@args); return if $ExitCode != 0; @args = (); } elsif ($_ eq '||') { eval_cmd(@args); return if $ExitCode == 0; $ExitCode = 0; @args = (); } elsif (/^"(.*)"$/o) { #warn "---------"; #warn qq{Pusing "$1" into args\n}; my $s = $1; process_escape( $s, q{\\@$\#} ); #warn "$s"; subs_env($s); push @args, $s if $s ne ''; } elsif (/^'(.*)'$/o) { #warn " Pusing '$1' into args\n"; push @args, $1 if $1 ne ''; } elsif (/^['"]/o) { $ExitCode = 1; die "sh: unexpected EOF while looking for matching `$&'\n"; } else { #warn " Remaining: $_\n"; my $s = $_; if ($level == 0 and $s =~ /^\#/o) { return @args; } process_unquoted($s, $level, \@args); #warn "~~~~~~~~~~~~~~\n"; #warn Dumper(@args, $_, @raw_args); #warn "~~~~~~~~~~~~~~\n"; } } return @args; } sub process_unquoted { my ($s, $level, $rargs) = @_; return if $s eq ''; ## before: $s $s =~ s/\\(.)/$1/gso; ## after: $s subs_env($s); my @subargs = split_arg($s) if $s =~ / /o; #warn Dumper(@subargs); if (@subargs > 1) { push @$rargs, process_args ($level+1, @subargs); } else { my @files = glob $s; if (@files > 1) { push @$rargs, @files; } else { push @$rargs, $s if $s ne ''; } } } sub subs_env { $_[0] =~ s/\$(\w+)/defined $ENV{$1} ? "$ENV{$1}" : ''/geo; } sub touch (@) { my @files = @_; foreach my $file (@files) { my $in; open $in, ">>$file" and print $in '' and close $in or die "Can't touch $file: $!"; } } sub eval_cmd { my @args = @_; return 0 if not @args; my $redir = $RedirectIndex; undef $RedirectIndex; my $exec = shift @args; if ($exec =~ /^\s+$/) { $exec = shift @args; } ### Got exec: $exec ### Got args: @args if ($exec eq 'echo') { if ($redir) { my $op = $args[$redir]; my @elems = @args[0..$redir-1]; if ($op eq '>') { my $file = $args[$redir+1]; open my $out, "> $file" or die "Can't open $file for writing: $!\n"; print $out "@elems\n"; close $out; } elsif ($op eq '>>') { my $file = $args[$redir+1]; open my $out, ">> $file" or die "Can't open $file for writing: $!\n"; print $out "@elems\n"; close $out; } elsif ($op eq '<') { print "@elems\n"; } else { die "Unexpected redirection operator: $op"; } } else { print "@args\n"; } return 0; } elsif ($exec eq 'rm') { foreach my $file (@args) { $file =~ s/\s+$//; if (not unlink $file) { warn "rm: cannot lstat `$file': $!\n"; $ExitCode = 1; return; } } return 0; } elsif ($exec eq 'sleep') { sleep ($args[0]); } elsif ($exec eq 'pwd') { require 'Cwd.pm'; print Cwd::cwd(), "\n"; } elsif ($exec eq 'cd') { chdir $args[0]; } elsif ($exec eq 'touch') { touch(@args); $ExitCode = 0; return; } elsif ($exec eq ':') { return; } elsif ($exec eq 'exit') { $ExitCode = $args[0] if defined $args[0]; exit($ExitCode); } elsif ($exec =~ /make/i or ($args[0] and $args[0] =~ /make/i)) { $ExitCode = system $exec, @args; return; } else { warn "sh: unknown shell command: $exec"; $ExitCode = 1; return; } } Makefile-DOM-0.006/script/checkenv0000755000175000001440000000053311622740614016104 0ustar agentzusers#!/usr/bin/env perl # Check environment settings for the testers. use strict; use warnings; sub check ($$) { my ($env, $desc) = @_; my $val = $ENV{$env} || ''; print "$desc\t=>\t$env = $val\n"; } check 'TEST_SHELL_PATH', 't/sh/*.t'; print "\n"; check 'GNU_MAKE_PATH', 't/gnu/*/*.t'; check 'GNU_SHELL_PATH', 't/gnu/*/*.t'; Makefile-DOM-0.006/script/mdom-dump0000755000175000001440000000032511622740614016214 0ustar agentzusers#!/usr/bin/env perl use strict; use warnings; use MDOM::Document::Gmake; use MDOM::Dumper; my $doc = MDOM::Document::Gmake->new(shift); die unless $doc; my $dumper = MDOM::Dumper->new( $doc ); $dumper->print; Makefile-DOM-0.006/script/p4_to_t.pl0000755000175000001440000002577611622740614016320 0ustar agentzusers#!/usr/bin/env perl use strict; use warnings; #use Smart::Comments; use Getopt::Std; use PPI; use IPC::Run3; use File::Path; use File::Slurp; use List::MoreUtils qw( any ); my @dummy_comments = ( '# Create the answer to what should be produced by this Makefile', '# The Contents of the MAKEFILE ...', '# COMPARE RESULTS', '# END of Contents of MAKEFILE', ); my %opts; getopts('o:', \%opts); die "No output directory specified\n" unless $opts{o}; my $outdir = $opts{o}; eval { mkpath($outdir) }; if ($@) { print "Couldn't create $outdir: $@"; } my @files = map glob, @ARGV; die "No input file specified.\n" unless @files; for my $infile (@files) { next if -d $infile or $infile =~ /(\.swp|~)$/; my $p4 = read_file($infile); $p4 =~ s/<<\s*\\EOF\b/<<'EOF'/smg; my $doc = PPI::Document->new(\$p4); my @matched; for my $elem ($doc->elements) { my $content = $elem->content; if ($elem->class =~ /Comment$/) { chomp($content); next if (any { $_ eq $content } @dummy_comments) or $content =~ /-\*-perl-\*-/i or $content =~ /^\s*#\s*$/ or $content =~ /^\s*#\s*-+\s*$/; push @matched, $content; } } my $body = process_comments($p4, \@matched); my $pattern = <<'_EOC_'; if\s+\(((?:!\s*)?-[a-z])\s+(\S+)\)\s+\{ \s+\$test_passed = (\d+); \} _EOC_ my $count = $body =~ s/$pattern/\&X::file_test('$1', $2, $3);\n/g; $pattern = <<'_EOC_'; if \(\(-f (\S+)\)\|\|\(-f (\S+)\)\|\|\(-f (\S+)\)\|\|\(-f (\S+)\)\) \{ \s+\$test_passed = 0; \} _EOC_ $count += 4 * ($body =~ s/$pattern/ \&X::file_test('-f', $1, 0); \&X::file_test('-f', $2, 0); \&X::file_test('-f', $3, 0); \&X::file_test('-f', $4, 0);/g); if ($body =~ /\$test_passed\b/) { warn "WARNING: \$test_passed involved...\n"; } warn "info: $count file test(s) found\n" if $count; write_file('tmp.pl', preamble(), $body); my $stdout; run3 [$^X, 'tmp.pl'], undef, \$stdout, undef; #print $stdout; if ($infile =~ /([^\/\\]+)$/) { my $base = $1; my $outfile = "$outdir/$base.t"; warn "Generating $outfile...\n"; write_file($outfile, $stdout); } } sub process_comments { my $p4 = shift; my $matched = shift; for my $match (@$matched) { (my $value = $match) =~ s/^#\s+//g; (my $quoted = $value) =~ s/\\/\\\\/g; $quoted =~ s/'/\\'/g; if ($p4 =~ s/\G(.*?)\Q$match\E/${1}\&X::comment('$quoted');/ms) { } else { die "Can't find matched comment '$match' in the source"; } } $p4; } sub preamble { return <<'_EOC_'; use strict; use warnings; package X; use File::Slurp; our ($block, @blocks, %utouch); our $count = 0; our $extra_tests = 0; sub file_test ($$$) { my ($op, $file, $passed) = @_; if ($op eq '-f') { if ($passed) { $X::block->{found} .= " $file"; } else { $X::block->{not_found} .= " $file"; } $extra_tests++; } else { die "Not supported yet: $op $file $passed"; } } sub comment ($) { my $cmt = shift; if ($cmt =~ /^TEST\s+#?\d+\b/i) { $X::block->{name} = $cmt; } else { $X::block->{description} .= "$cmt\n" } } package main; #use Smart::Comments; use subs qw(unlink cwd); use Test::MockClass qw(Cwd); my $makefile = 'test.mk'; my $mkpath = '#MAKE#'; my $make_path = 'make'; my $workdir = '.'; my $pathsep = '/'; my $description = ''; my $details = ''; my ($answer, $example); my $delete_command = 'rm'; my $rm_command = 'rm'; my $has_POSIX = eval { require "POSIX.pm" }; my $parallel_jobs = 1; my $make_name = '#MAKE#'; my $port_type = ($^O eq 'MSWin32' || $^O eq 'Cygwin') ? 'MSWin32' : 'UNIX'; my %extraENV = (); my $pwd = '#PWD#'; # local vars used by the test scripts my (@touchedfiles, $VP, $cleanit_error, $delete_error_code); $delete_error_code = 2; my $test_passed; my $vos = 0; sub cwd { #die "Called!"; "#PWD#"; } sub resetENV () { %extraENV = (); } sub get_tmpfile { $makefile } sub unlink { #die "unlink called!"; rmfiles(@_); } sub rmfiles { for my $file (@_) { if (!exists $utouch{$file}) { warn "WARNING: removing file $file which is not touched before\n"; } else { delete $utouch{$file}; } } } sub utouch ($@) { my $time = shift; for my $file (@_) { $X::utouch{$file} = $time; } } sub touch ($@) { utouch(0, @_); } sub get_logfile { 1; } sub run_make_with_options ($$$$) { my $infile = shift; $X::block->{filename} = $infile; $X::block->{options} = shift; shift; $X::block->{error_code} = shift; $X::block->{source} = X::read_file($infile) if $infile; $X::block->{utouch} = {%X::utouch}; $X::block->{env} = {%extraENV}; } sub compare_output ($$) { $X::block->{stdout} = shift; push @X::blocks, $X::block; $X::block = {}; } sub run_make_test ($$$@) { my $source = shift; if (!defined $source) { $source = $X::prev_src; } else { $X::prev_src = $source; } $X::block->{source} = $source; $X::block->{options} = shift; $X::block->{stdout} = shift; my $error_code = shift; $error_code = 0 if !defined $error_code; $X::block->{error_code} = $error_code; $X::block->{utouch} = {%X::utouch}; $X::block->{env} = {%extraENV}; push @X::blocks, $X::block; $X::block = {}; } END { ### @X::blocks; package X; my $use_ditto = ''; my @groups; my $i; my $prev_source; my $leading_empty_lines; for my $block (@blocks) { $i++; # === TEST $name # $description my $str = "=== " . ($block->{name} || "TEST $i:") . "\n"; $str .= $block->{description} . "\n" if $block->{description}; # --- source my $source = $block->{source}; if (defined $source) { if (defined $prev_source and $source eq $prev_source) { $use_ditto = "\nuse_source_ditto;\n"; $str .= "--- source ditto\n"; } else { if ($source =~ /^\n+/s) { $leading_empty_lines = length($&); #die "LEADING: $leading_empty_lines"; } my $opt = ''; if ($source =~ /#[A-Z]+#/) { $opt = ' preprocess'; } $str .= "--- source$opt\n" . $source . "\n"; } } $prev_source = $source; # --- pre: $ExtraENV{$var} = $value my %env = %{ $block->{env} }; if (%env) { my @ln; while (my ($k, $v) = each %env) { $k =~ s/\\/\\\\/g; $k =~ s/'/\\'/g; $v =~ s/\\/\\\\/g; $v =~ s/'/\\'/g; push @ln, qq[\$::ExtraENV{'$k'} = '$v']; } if (@ln > 1) { $str .= "\n--- pre\n" . join(";\n", @ln) . ";\n"; } else { $str .= "\n--- pre: @ln;\n"; } } # --- touch # --- utouch my (@touch, @utouch); my %utouch = %{ $block->{utouch} }; while (my ($file, $time) = each %utouch) { if ($time == 0) { push @touch, $file; } else { push @utouch, "$time $file"; } } if (@touch) { $str .= "--- touch: " . join(" ", @touch) . "\n"; } if (@utouch == 1) { $str .= "--- utouch: $utouch[0]\n"; } elsif (@utouch > 1) { $str .= "--- utouch\n" . join("\n", @utouch) . "\n"; } # --- options # --- goals my $options = $block->{options}; #die $options if $options =~ /other/; $options =~ s/\\(.)/$1/g; if (defined $options and $options ne '') { $options =~ s/^\s+|\s+$//g; if ($options =~ /(?:\w+|\S+=\S+|-[\w-]+|\s+)+/) { my @args = split /\s+/, $options; my @goals = grep { /^\w+$/ } @args; $options = join ' ', grep { !/^\w+$/ } @args; if (@goals) { $str .= "--- goals: @goals\n"; } } $options =~ s/\n+/ /; my $opt = ''; if ($options =~ /#[A-Z]+#/) { $opt = ' preprocess'; } $str .= "--- options$opt: $options\n" if $options !~ /^\s*$/; } # --- stdout my $stdout = $block->{stdout}; my $stderr; $stdout =~ s{^[^\n]*?(?:Error \d+|No such file or directory| Stop\.|warning)[^\n]*\n?} {$stderr .= $&; ''}emsg; if (defined $stdout and $stdout ne '') { my $opt = ''; if ($stdout =~ /#[A-Z]+#/) { $opt = ' preprocess'; } if ($stdout =~ /^\s+$/s) { $stdout =~ s/\n/\\n/g; $str .= qq{--- stdout eval: "$stdout"\n}; } else { $str .= "--- stdout$opt\n$stdout\n"; } } else { $str .= "--- stdout\n"; } # --- stderr #$stderr = $block->{stderr}; if (defined $stderr and $stderr ne '') { if ($leading_empty_lines) { $stderr =~ s/^(#MAKEFILE#:)(\d): / my $n = $2 - $leading_empty_lines; $n = 1 if $n < 1; $1 . $n . ": "/esmg; } my $opt = ''; if ($stderr =~ /#[A-Z]+#/) { $opt = ' preprocess'; } $str .= "--- stderr$opt\n$stderr\n"; } else { $str .= "--- stderr\n"; } # --- error_code my $error_code = $block->{error_code}; if (defined $error_code) { $error_code >>= 8; $str .= "--- error_code: $error_code\n"; } else { $extra_tests--; } # --- not_found my $not_found = $block->{not_found}; if (defined $not_found and $not_found !~ /^\s*$/) { $str .= "--- not_found: $not_found\n"; } # --- found my $found = $block->{found}; if (defined $found and $found !~ /^\s*$/) { $str .= "--- found: $found\n"; } # --- filename my $filename = $block->{filename}; #die $filename; if (defined $filename && index($str, $filename) >= 0) { $str =~ s/^--- /--- filename: $filename\n--- /ms; } push @groups, $str; } $details =~ s/^/# /gms; $description =~ s/^/# /gms; my $data = join "\n\n\n", @groups; my $tests = ''; if ($extra_tests > 0) { $tests = " + $extra_tests"; } elsif ($extra_tests < 0) { $tests = " - " . -$extra_tests; } print <<_EOF_; # Description: $description # # Details: $details use t::Gmake; plan tests => 3 * blocks()$tests; $use_ditto run_tests; __DATA__ $data _EOF_ } no strict; no warnings; _EOC_ } Makefile-DOM-0.006/inc/0000755000175000001440000000000011626450365013641 5ustar agentzusersMakefile-DOM-0.006/inc/Spiffy.pm0000644000175000001440000003623111626450360015437 0ustar agentzusers#line 1 package Spiffy; use strict; use 5.006001; use warnings; use Carp; require Exporter; our $VERSION = '0.30'; our @EXPORT = (); our @EXPORT_BASE = qw(field const stub super); our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); my $stack_frame = 0; my $dump = 'yaml'; my $bases_map = {}; sub WWW; sub XXX; sub YYY; sub ZZZ; # This line is here to convince "autouse" into believing we are autousable. sub can { ($_[1] eq 'import' and caller()->isa('autouse')) ? \&Exporter::import # pacify autouse's equality test : $_[0]->SUPER::can($_[1]) # normal case } # TODO # # Exported functions like field and super should be hidden so as not to # be confused with methods that can be inherited. # sub new { my $class = shift; $class = ref($class) || $class; my $self = bless {}, $class; while (@_) { my $method = shift; $self->$method(shift); } return $self; } my $filtered_files = {}; my $filter_dump = 0; my $filter_save = 0; our $filter_result = ''; sub import { no strict 'refs'; no warnings; my $self_package = shift; # XXX Using parse_arguments here might cause confusion, because the # subclass's boolean_arguments and paired_arguments can conflict, causing # difficult debugging. Consider using something truly local. my ($args, @export_list) = do { local *boolean_arguments = sub { qw( -base -Base -mixin -selfless -XXX -dumper -yaml -filter_dump -filter_save ) }; local *paired_arguments = sub { qw(-package) }; $self_package->parse_arguments(@_); }; return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) if $args->{-mixin}; $filter_dump = 1 if $args->{-filter_dump}; $filter_save = 1 if $args->{-filter_save}; $dump = 'yaml' if $args->{-yaml}; $dump = 'dumper' if $args->{-dumper}; local @EXPORT_BASE = @EXPORT_BASE; if ($args->{-XXX}) { push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} unless grep /^XXX$/, @EXPORT_BASE; } spiffy_filter() if ($args->{-selfless} or $args->{-Base}) and not $filtered_files->{(caller($stack_frame))[1]}++; my $caller_package = $args->{-package} || caller($stack_frame); push @{"$caller_package\::ISA"}, $self_package if $args->{-Base} or $args->{-base}; for my $class (@{all_my_bases($self_package)}) { next unless $class->isa('Spiffy'); my @export = grep { not defined &{"$caller_package\::$_"}; } ( @{"$class\::EXPORT"}, ($args->{-Base} or $args->{-base}) ? @{"$class\::EXPORT_BASE"} : (), ); my @export_ok = grep { not defined &{"$caller_package\::$_"}; } @{"$class\::EXPORT_OK"}; # Avoid calling the expensive Exporter::export # if there is nothing to do (optimization) my %exportable = map { ($_, 1) } @export, @export_ok; next unless keys %exportable; my @export_save = @{"$class\::EXPORT"}; my @export_ok_save = @{"$class\::EXPORT_OK"}; @{"$class\::EXPORT"} = @export; @{"$class\::EXPORT_OK"} = @export_ok; my @list = grep { (my $v = $_) =~ s/^[\!\:]//; $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; } @export_list; Exporter::export($class, $caller_package, @list); @{"$class\::EXPORT"} = @export_save; @{"$class\::EXPORT_OK"} = @export_ok_save; } } sub spiffy_filter { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = $data; my @my_subs; s[^(sub\s+\w+\s+\{)(.*\n)] [${1}my \$self = shift;$2]gm; s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] [${1}${2}]gm; s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; my $preclare = ''; if (@my_subs) { $preclare = join ',', map "\$$_", @my_subs; $preclare = "my($preclare);"; } $_ = "use strict;use warnings;$preclare${_};1;\n$end"; if ($filter_dump) { print; exit } if ($filter_save) { $filter_result = $_; $_ = $filter_result; } $done = 1; } ); } sub base { push @_, -base; goto &import; } sub all_my_bases { my $class = shift; return $bases_map->{$class} if defined $bases_map->{$class}; my @bases = ($class); no strict 'refs'; for my $base_class (@{"${class}::ISA"}) { push @bases, @{all_my_bases($base_class)}; } my $used = {}; $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; } my %code = ( sub_start => "sub {\n", set_default => " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", init => " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . " unless \$#_ > 0 or defined \$_[0]->{%s};\n", weak_init => " return do {\n" . " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . " \$_[0]->{%s};\n" . " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", return_if_get => " return \$_[0]->{%s} unless \$#_ > 0;\n", set => " \$_[0]->{%s} = \$_[1];\n", weaken => " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", sub_end => " return \$_[0]->{%s};\n}\n", ); sub field { my $package = caller; my ($args, @values) = do { no warnings; local *boolean_arguments = sub { (qw(-weak)) }; local *paired_arguments = sub { (qw(-package -init)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; die "Cannot have a default for a weakened field ($field)" if defined $default && $args->{-weak}; return if defined &{"${package}::$field"}; require Scalar::Util if $args->{-weak}; my $default_string = ( ref($default) eq 'ARRAY' and not @$default ) ? '[]' : (ref($default) eq 'HASH' and not keys %$default ) ? '{}' : default_as_code($default); my $code = $code{sub_start}; if ($args->{-init}) { my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; } $code .= sprintf $code{set_default}, $field, $default_string, $field if defined $default; $code .= sprintf $code{return_if_get}, $field; $code .= sprintf $code{set}, $field; $code .= sprintf $code{weaken}, $field, $field if $args->{-weak}; $code .= sprintf $code{sub_end}, $field; my $sub = eval $code; die $@ if $@; no strict 'refs'; *{"${package}::$field"} = $sub; return $code if defined wantarray; } sub default_as_code { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; my $code = Data::Dumper::Dumper(shift); $code =~ s/^\$VAR1 = //; $code =~ s/;$//; return $code; } sub const { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { $default } } sub stub { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { require Carp; Carp::confess "Method $field in package $package must be subclassed"; } } sub parse_arguments { my $class = shift; my ($args, @values) = ({}, ()); my %booleans = map { ($_, 1) } $class->boolean_arguments; my %pairs = map { ($_, 1) } $class->paired_arguments; while (@_) { my $elem = shift; if (defined $elem and defined $booleans{$elem}) { $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) ? shift : 1; } elsif (defined $elem and defined $pairs{$elem} and @_) { $args->{$elem} = shift; } else { push @values, $elem; } } return wantarray ? ($args, @values) : $args; } sub boolean_arguments { () } sub paired_arguments { () } # get a unique id for any node sub id { if (not ref $_[0]) { return 'undef' if not defined $_[0]; \$_[0] =~ /\((\w+)\)$/o or die; return "$1-S"; } require overload; overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; return $1; } #=============================================================================== # It's super, man. #=============================================================================== package DB; { no warnings 'redefine'; sub super_args { my @dummy = caller(@_ ? $_[0] : 2); return @DB::args; } } package Spiffy; sub super { my $method; my $frame = 1; while ($method = (caller($frame++))[3]) { $method =~ s/.*::// and last; } my @args = DB::super_args($frame); @_ = @_ ? ($args[0], @_) : @args; my $class = ref $_[0] ? ref $_[0] : $_[0]; my $caller_class = caller; my $seen = 0; my @super_classes = reverse grep { ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; } reverse @{all_my_bases($class)}; for my $super_class (@super_classes) { no strict 'refs'; next if $super_class eq $class; if (defined &{"${super_class}::$method"}) { ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} if $method eq 'AUTOLOAD'; return &{"${super_class}::$method"}; } } return; } #=============================================================================== # This code deserves a spanking, because it is being very naughty. # It is exchanging base.pm's import() for its own, so that people # can use base.pm with Spiffy modules, without being the wiser. #=============================================================================== my $real_base_import; my $real_mixin_import; BEGIN { require base unless defined $INC{'base.pm'}; $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; $real_base_import = \&base::import; $real_mixin_import = \&mixin::import; no warnings; *base::import = \&spiffy_base_import; *mixin::import = \&spiffy_mixin_import; } # my $i = 0; # while (my $caller = caller($i++)) { # next unless $caller eq 'base' or $caller eq 'mixin'; # croak <isa('Spiffy'); } @base_classes; my $inheritor = caller(0); for my $base_class (@base_classes) { next if $inheritor->isa($base_class); croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", "See the documentation of Spiffy.pm for details\n " unless $base_class->isa('Spiffy'); $stack_frame = 1; # tell import to use different caller import($base_class, '-base'); $stack_frame = 0; } } sub mixin { my $self = shift; my $target_class = ref($self); spiffy_mixin_import($target_class, @_) } sub spiffy_mixin_import { my $target_class = shift; $target_class = caller(0) if $target_class eq 'mixin'; my $mixin_class = shift or die "Nothing to mixin"; eval "require $mixin_class"; my @roles = @_; my $pseudo_class = join '-', $target_class, $mixin_class, @roles; my %methods = spiffy_mixin_methods($mixin_class, @roles); no strict 'refs'; no warnings; @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; @{"$target_class\::ISA"} = ($pseudo_class); for (keys %methods) { *{"$pseudo_class\::$_"} = $methods{$_}; } } sub spiffy_mixin_methods { my $mixin_class = shift; no strict 'refs'; my %methods = spiffy_all_methods($mixin_class); map { $methods{$_} ? ($_, \ &{"$methods{$_}\::$_"}) : ($_, \ &{"$mixin_class\::$_"}) } @_ ? (get_roles($mixin_class, @_)) : (keys %methods); } sub get_roles { my $mixin_class = shift; my @roles = @_; while (grep /^!*:/, @roles) { @roles = map { s/!!//g; /^!:(.*)/ ? do { my $m = "_role_$1"; map("!$_", $mixin_class->$m); } : /^:(.*)/ ? do { my $m = "_role_$1"; ($mixin_class->$m); } : ($_) } @roles; } if (@roles and $roles[0] =~ /^!/) { my %methods = spiffy_all_methods($mixin_class); unshift @roles, keys(%methods); } my %roles; for (@roles) { s/!!//g; delete $roles{$1}, next if /^!(.*)/; $roles{$_} = 1; } keys %roles; } sub spiffy_all_methods { no strict 'refs'; my $class = shift; return if $class eq 'Spiffy'; my %methods = map { ($_, $class) } grep { defined &{"$class\::$_"} and not /^_/ } keys %{"$class\::"}; my %super_methods; %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) if @{"$class\::ISA"}; %{{%super_methods, %methods}}; } # END of naughty code. #=============================================================================== # Debugging support #=============================================================================== sub spiffy_dump { no warnings; if ($dump eq 'dumper') { require Data::Dumper; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Indent = 1; return Data::Dumper::Dumper(@_); } require YAML; $YAML::UseVersion = 0; return YAML::Dump(@_) . "...\n"; } sub at_line_number { my ($file_path, $line_number) = (caller(1))[1,2]; " at $file_path line $line_number\n"; } sub WWW { warn spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub XXX { die spiffy_dump(@_) . at_line_number; } sub YYY { print spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub ZZZ { require Carp; Carp::confess spiffy_dump(@_); } 1; __END__ #line 1066 Makefile-DOM-0.006/inc/Module/0000755000175000001440000000000011626450365015066 5ustar agentzusersMakefile-DOM-0.006/inc/Module/Install.pm0000644000175000001440000003013511626450360017027 0ustar agentzusers#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.01'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2011 Adam Kennedy. Makefile-DOM-0.006/inc/Module/Install/0000755000175000001440000000000011626450365016474 5ustar agentzusersMakefile-DOM-0.006/inc/Module/Install/Fetch.pm0000644000175000001440000000462711626450360020067 0ustar agentzusers#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Makefile-DOM-0.006/inc/Module/Install/Makefile.pm0000644000175000001440000002703211626450360020546 0ustar agentzusers#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 541 Makefile-DOM-0.006/inc/Module/Install/TestBase.pm0000644000175000001440000000103311626450360020534 0ustar agentzusers#line 1 package Module::Install::TestBase; use strict; use warnings; use Module::Install::Base; use vars qw($VERSION @ISA); BEGIN { $VERSION = '0.60'; @ISA = 'Module::Install::Base'; } sub use_test_base { my $self = shift; $self->include('Test::Base'); $self->include('Test::Base::Filter'); $self->include('Spiffy'); $self->include('Test::More'); $self->include('Test::Builder'); $self->include('Test::Builder::Module'); $self->requires('Filter::Util::Call'); } 1; =encoding utf8 #line 70 Makefile-DOM-0.006/inc/Module/Install/WriteAll.pm0000644000175000001440000000237611626450360020560 0ustar agentzusers#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Makefile-DOM-0.006/inc/Module/Install/Base.pm0000644000175000001440000000214711626450360017703 0ustar agentzusers#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.01'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Makefile-DOM-0.006/inc/Module/Install/Metadata.pm0000644000175000001440000004312311626450360020550 0ustar agentzusers#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Makefile-DOM-0.006/inc/Module/Install/Win32.pm0000644000175000001440000000340311626450360017727 0ustar agentzusers#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Makefile-DOM-0.006/inc/Module/Install/Include.pm0000644000175000001440000000101511626450360020405 0ustar agentzusers#line 1 package Module::Install::Include; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; Makefile-DOM-0.006/inc/Module/Install/AutoInstall.pm0000644000175000001440000000363211626450360021270 0ustar agentzusers#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; my @features_require = Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); my %seen; my @requires = map @$_, map @$_, grep ref, $self->requires; while (my ($mod, $ver) = splice(@requires, 0, 2)) { $seen{$mod}{$ver}++; } my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { $seen{$mod}{$ver}++; } my @deduped; while (my ($mod, $ver) = splice(@features_require, 0, 2)) { push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; } $self->requires(@deduped); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; Makefile-DOM-0.006/inc/Module/Install/Can.pm0000644000175000001440000000333311626450360017530 0ustar agentzusers#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.01'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Makefile-DOM-0.006/inc/Module/AutoInstall.pm0000644000175000001440000005423111626450360017663 0ustar agentzusers#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. my $cur = _load($mod); if (_version_cmp ($cur, $arg) >= 0) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { if (not defined $cur) # indeed missing { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; } else { # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above print "too old. ($cur < $arg)\n"; } push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; return (@Existing, @Missing); } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89') { if ($cpan_env) { return _running_under('CPAN'); } return; # CPAN.pm new enough, don't need to check further } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and $CPAN::Config and not @_; require CPAN; # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to # CPAN::HandleConfig->load. CPAN reports that the redirection # is deprecated in a warning printed at the user. # CPAN-1.81 expects CPAN::HandleConfig->load, does not have # $CPAN::HandleConfig::VERSION but cannot handle # CPAN::Config->load # Which "versions expect CPAN::Config->load? if ( $CPAN::HandleConfig::VERSION || CPAN::HandleConfig->can('load') ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison # return values same as <=> sub _version_cmp { my ( $cur, $min ) = @_; return -1 unless defined $cur; # if 0 keep comparing return 1 unless $min; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return version->new($cur) <=> version->new($min); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return Sort::Versions::versioncmp( $cur, $min ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return $cur <=> $min; } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1071 Makefile-DOM-0.006/inc/Test/0000755000175000001440000000000011626450365014560 5ustar agentzusersMakefile-DOM-0.006/inc/Test/Builder.pm0000644000175000001440000007376511626450360016521 0ustar agentzusers#line 1 package Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) BEGIN { if( $] < 5.008 ) { require Test::Builder::IO::Scalar; } } # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; # Load threads::shared when threads are turned on. # 5.8.0's threads are so busted we no longer support them. if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { require threads::shared; # Hack around YET ANOTHER threads::shared bug. It would # occassionally forget the contents of the variable when sharing it. # So we first copy the data, then share, then put our copy back. *share = sub (\[$@%]) { my $type = ref $_[0]; my $data; if( $type eq 'HASH' ) { %$data = %{ $_[0] }; } elsif( $type eq 'ARRAY' ) { @$data = @{ $_[0] }; } elsif( $type eq 'SCALAR' ) { $$data = ${ $_[0] }; } else { die( "Unknown type: " . $type ); } $_[0] = &threads::shared::share( $_[0] ); if( $type eq 'HASH' ) { %{ $_[0] } = %$data; } elsif( $type eq 'ARRAY' ) { @{ $_[0] } = @$data; } elsif( $type eq 'SCALAR' ) { ${ $_[0] } = $$data; } else { die( "Unknown type: " . $type ); } return $_[0]; }; } # 5.8.0's threads::shared is busted when threads are off # and earlier Perls just don't have that module at all. else { *share = sub { return $_[0] }; *lock = sub { 0 }; } } #line 117 my $Test = Test::Builder->new; sub new { my($class) = shift; $Test ||= $class->create; return $Test; } #line 139 sub create { my $class = shift; my $self = bless {}, $class; $self->reset; return $self; } #line 158 our $Level; sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my($self) = @_; # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Have_Output_Plan} = 0; $self->{Original_Pid} = $$; share( $self->{Curr_Test} ); $self->{Curr_Test} = 0; $self->{Test_Results} = &share( [] ); $self->{Exported_To} = undef; $self->{Expected_Tests} = 0; $self->{Skip_All} = 0; $self->{Use_Nums} = 1; $self->{No_Header} = 0; $self->{No_Ending} = 0; $self->{Todo} = undef; $self->{Todo_Stack} = []; $self->{Start_Todo} = 0; $self->{Opened_Testhandles} = 0; $self->_dup_stdhandles; return; } #line 219 my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; local $Level = $Level + 1; $self->croak("You tried to plan twice") if $self->{Have_Plan}; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $self->croak("plan() doesn't understand @args"); } return 1; } sub _plan_tests { my($self, $arg) = @_; if($arg) { local $Level = $Level + 1; return $self->expected_tests($arg); } elsif( !defined $arg ) { $self->croak("Got an undefined number of tests"); } else { $self->croak("You said to run 0 tests"); } return; } #line 275 sub expected_tests { my $self = shift; my($max) = @_; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $self->{Expected_Tests} = $max; $self->{Have_Plan} = 1; $self->_output_plan($max) unless $self->no_header; } return $self->{Expected_Tests}; } #line 299 sub no_plan { my($self, $arg) = @_; $self->carp("no_plan takes no arguments") if $arg; $self->{No_Plan} = 1; $self->{Have_Plan} = 1; return 1; } #line 333 sub _output_plan { my($self, $max, $directive, $reason) = @_; $self->carp("The plan was already output") if $self->{Have_Output_Plan}; my $plan = "1..$max"; $plan .= " # $directive" if defined $directive; $plan .= " $reason" if defined $reason; $self->_print("$plan\n"); $self->{Have_Output_Plan} = 1; return; } #line 384 sub done_testing { my($self, $num_tests) = @_; # If done_testing() specified the number of tests, shut off no_plan. if( defined $num_tests ) { $self->{No_Plan} = 0; } else { $num_tests = $self->current_test; } if( $self->{Done_Testing} ) { my($file, $line) = @{$self->{Done_Testing}}[1,2]; $self->ok(0, "done_testing() was already called at $file line $line"); return; } $self->{Done_Testing} = [caller]; if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } else { $self->{Expected_Tests} = $num_tests; } $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; $self->{Have_Plan} = 1; return 1; } #line 429 sub has_plan { my $self = shift; return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; return('no_plan') if $self->{No_Plan}; return(undef); } #line 446 sub skip_all { my( $self, $reason ) = @_; $self->{Skip_All} = 1; $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; exit(0); } #line 468 sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } #line 498 sub ok { my( $self, $test, $name ) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; lock $self->{Curr_Test}; $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. $self->_unoverload_str( \$name ); $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR # Capture the value of $TODO for the rest of this ok() call # so it can more easily be found by other routines. my $todo = $self->todo(); my $in_todo = $self->in_todo; local $self->{Todo} = $todo if $in_todo; $self->_unoverload_str( \$todo ); my $out; my $result = &share( {} ); unless($test) { $out .= "not "; @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } $out .= "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } if( $self->in_todo ) { $out .= " # TODO $todo"; $result->{reason} = $todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; $out .= "\n"; $self->_print($out); unless($test) { my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; my( undef, $file, $line ) = $self->caller; if( defined $name ) { $self->diag(qq[ $msg test '$name'\n]); $self->diag(qq[ at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } return $test ? 1 : 0; } sub _unoverload { my $self = shift; my $type = shift; $self->_try(sub { require overload; }, die_on_fail => 1); foreach my $thing (@_) { if( $self->_is_object($$thing) ) { if( my $string_meth = overload::Method( $$thing, $type ) ) { $$thing = $$thing->$string_meth(); } } } return; } sub _is_object { my( $self, $thing ) = @_; return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; } sub _unoverload_str { my $self = shift; return $self->_unoverload( q[""], @_ ); } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', @_ ); for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } return; } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my( $self, $val ) = @_; # Objects are not dualvars. return 0 if ref $val; no warnings 'numeric'; my $numval = $val + 0; return $numval != 0 and $numval ne $val ? 1 : 0; } #line 649 sub is_eq { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_str( \$got, \$expect ); if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; return $test; } return $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; $self->_unoverload_num( \$got, \$expect ); if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; return $test; } return $self->cmp_ok( $got, '==', $expect, $name ); } sub _diag_fmt { my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } return; } sub _is_diag { my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: $expect DIAGNOSTIC } sub _isnt_diag { my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: anything else DIAGNOSTIC } #line 746 sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; return $test; } return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; return $test; } return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } #line 797 sub like { my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; return $self->_regex_ok( $this, $regex, '=~', $name ); } sub unlike { my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; return $self->_regex_ok( $this, $regex, '!~', $name ); } #line 821 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $test; my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $self->caller(); $test = eval qq[ #line 1 "cmp_ok [from $file line $line]" \$got $type \$expect; ]; $error = $@; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->diag(<<"END") if $error; An error occurred while using $type: ------------------------------------ $error ------------------------------------ END unless($ok) { $self->$unoverload( \$got, \$expect ); if( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { $self->_isnt_diag( $got, $type ); } else { $self->_cmp_diag( $got, $type, $expect ); } } return $ok; } sub _cmp_diag { my( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); $got $type $expect DIAGNOSTIC } sub _caller_context { my $self = shift; my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } #line 920 sub BAIL_OUT { my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); exit 255; } #line 933 *BAILOUT = \&BAIL_OUT; #line 944 sub skip { my( $self, $why ) = @_; $why ||= ''; $self->_unoverload_str( \$why ); lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, } ); my $out = "ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # skip"; $out .= " $why" if length $why; $out .= "\n"; $self->_print($out); return 1; } #line 985 sub todo_skip { my( $self, $why ) = @_; $why ||= ''; lock( $self->{Curr_Test} ); $self->{Curr_Test}++; $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } ); my $out = "not ok"; $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; $self->_print($out); return 1; } #line 1062 sub maybe_regex { my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my( $re, $opts ); # Check for qr/foo/ if( _is_qr($regex) ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _is_qr { my $regex = shift; # is_regexp() checks for regexes in a robust manner, say if they're # blessed. return re::is_regexp($regex) if defined &re::is_regexp; return ref $regex eq 'Regexp'; } sub _regex_ok { my( $self, $this, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless( defined $usable_regex ) { local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { ## no critic (BuiltinFunctions::ProhibitStringyEval) my $test; my $code = $self->_caller_context; local( $@, $!, $SIG{__DIE__} ); # isolate eval # Yes, it has to look like this or 5.4.5 won't see the #line # directive. # Don't ask me, man, I just work here. $test = eval " $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. #line 1162 sub _try { my( $self, $code, %opts ) = @_; my $error; my $return; { local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. $return = eval { $code->() }; $error = $@; } die $error if $error and $opts{die_on_fail}; return wantarray ? ( $return, $error ) : $return; } #line 1191 sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || # 5.5.4's tied() and can() doesn't like getting undef eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; } #line 1235 sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } #line 1267 sub use_numbers { my( $self, $use_nums ) = @_; if( defined $use_nums ) { $self->{Use_Nums} = $use_nums; } return $self->{Use_Nums}; } #line 1300 foreach my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; my $code = sub { my( $self, $no ) = @_; if( defined $no ) { $self->{$attribute} = $no; } return $self->{$attribute}; }; no strict 'refs'; ## no critic *{ __PACKAGE__ . '::' . $method } = $code; } #line 1353 sub diag { my $self = shift; $self->_print_comment( $self->_diag_fh, @_ ); } #line 1368 sub note { my $self = shift; $self->_print_comment( $self->output, @_ ); } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } sub _print_comment { my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape the beginning, _print will take care of the rest. $msg =~ s/^/# /; local $Level = $Level + 1; $self->_print_to_fh( $fh, $msg ); return 0; } #line 1418 sub explain { my $self = shift; return map { ref $_ ? do { $self->_try(sub { require Data::Dumper }, die_on_fail => 1); my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } #line 1447 sub _print { my $self = shift; return $self->_print_to_fh( $self->output, @_ ); } sub _print_to_fh { my( $self, $fh, @msgs ) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse return if $^C; my $msg = join '', @msgs; local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. $msg =~ s{\n(?!\z)}{\n# }sg; # Stick a newline on the end if it needs it. $msg .= "\n" unless $msg =~ /\n\z/; return print $fh $msg; } #line 1506 sub output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Out_FH} = $self->_new_fh($fh); } return $self->{Out_FH}; } sub failure_output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); } return $self->{Fail_FH}; } sub todo_output { my( $self, $fh ) = @_; if( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); } return $self->{Todo_FH}; } sub _new_fh { my $self = shift; my($file_or_fh) = shift; my $fh; if( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } elsif( ref $file_or_fh eq 'SCALAR' ) { # Scalar refs as filehandles was added in 5.8. if( $] >= 5.008 ) { open $fh, ">>", $file_or_fh or $self->croak("Can't open scalar ref $file_or_fh: $!"); } # Emulate scalar ref filehandles with a tie. else { $fh = Test::Builder::IO::Scalar->new($file_or_fh) or $self->croak("Can't tie scalar ref $file_or_fh"); } } else { open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; return; } my( $Testout, $Testerr ); sub _dup_stdhandles { my $self = shift; $self->_open_testhandles; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush($Testout); _autoflush( \*STDOUT ); _autoflush($Testerr); _autoflush( \*STDERR ); $self->reset_outputs; return; } sub _open_testhandles { my $self = shift; return if $self->{Opened_Testhandles}; # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; # $self->_copy_io_layers( \*STDOUT, $Testout ); # $self->_copy_io_layers( \*STDERR, $Testerr ); $self->{Opened_Testhandles} = 1; return; } sub _copy_io_layers { my( $self, $src, $dst ) = @_; $self->_try( sub { require PerlIO; my @src_layers = PerlIO::get_layers($src); binmode $dst, join " ", map ":$_", @src_layers if @src_layers; } ); return; } #line 1631 sub reset_outputs { my $self = shift; $self->output ($Testout); $self->failure_output($Testerr); $self->todo_output ($Testout); return; } #line 1657 sub _message_at_caller { my $self = shift; local $Level = $Level + 1; my( $pack, $file, $line ) = $self->caller; return join( "", @_ ) . " at $file line $line.\n"; } sub carp { my $self = shift; return warn $self->_message_at_caller(@_); } sub croak { my $self = shift; return die $self->_message_at_caller(@_); } #line 1697 sub current_test { my( $self, $num ) = @_; lock( $self->{Curr_Test} ); if( defined $num ) { $self->{Curr_Test} = $num; # If the test counter is being pushed forward fill in the details. my $test_results = $self->{Test_Results}; if( $num > @$test_results ) { my $start = @$test_results ? @$test_results : 0; for( $start .. $num - 1 ) { $test_results->[$_] = &share( { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef } ); } } # If backward, wipe history. Its their funeral. elsif( $num < @$test_results ) { $#{$test_results} = $num - 1; } } return $self->{Curr_Test}; } #line 1739 sub summary { my($self) = shift; return map { $_->{'ok'} } @{ $self->{Test_Results} }; } #line 1794 sub details { my $self = shift; return @{ $self->{Test_Results} }; } #line 1823 sub todo { my( $self, $pack ) = @_; return $self->{Todo} if defined $self->{Todo}; local $Level = $Level + 1; my $todo = $self->find_TODO($pack); return $todo if defined $todo; return ''; } #line 1845 sub find_TODO { my( $self, $pack ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; return unless $pack; no strict 'refs'; ## no critic return ${ $pack . '::TODO' }; } #line 1863 sub in_todo { my $self = shift; local $Level = $Level + 1; return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; } #line 1913 sub todo_start { my $self = shift; my $message = @_ ? shift : ''; $self->{Start_Todo}++; if( $self->in_todo ) { push @{ $self->{Todo_Stack} } => $self->todo; } $self->{Todo} = $message; return; } #line 1935 sub todo_end { my $self = shift; if( !$self->{Start_Todo} ) { $self->croak('todo_end() called without todo_start()'); } $self->{Start_Todo}--; if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { $self->{Todo} = pop @{ $self->{Todo_Stack} }; } else { delete $self->{Todo}; } return; } #line 1968 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self, $height ) = @_; $height ||= 0; my $level = $self->level + $height + 1; my @caller; do { @caller = CORE::caller( $level ); $level--; } until @caller; return wantarray ? @caller : $caller[0]; } #line 1985 #line 1999 #'# sub _sanity_check { my $self = shift; $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!' ); return; } #line 2020 sub _whoa { my( $self, $check, $desc ) = @_; if($check) { local $Level = $Level + 1; $self->croak(<<"WHOA"); WHOA! $desc This should never happen! Please contact the author immediately! WHOA } return; } #line 2044 sub _my_exit { $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) return 1; } #line 2056 sub _ending { my $self = shift; my $real_exit_code = $?; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } # Ran tests but never declared a plan or hit done_testing if( !$self->{Have_Plan} and $self->{Curr_Test} ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); } # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. if( !$self->{Have_Plan} ) { return; } # Don't do an ending if we bailed out. if( $self->{Bailed_Out} ) { return; } # Figure out if we passed or failed and print helpful messages. my $test_results = $self->{Test_Results}; if(@$test_results) { # The plan? We have no plan. if( $self->{No_Plan} ) { $self->_output_plan($self->{Curr_Test}) unless $self->no_header; $self->{Expected_Tests} = $self->{Curr_Test}; } # Auto-extended arrays and elements which aren't explicitly # filled in with a shared reference will puke under 5.8.0 # ithreads. So we have to fill them in by hand. :( my $empty_result = &share( {} ); for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { $test_results->[$idx] = $empty_result unless defined $test_results->[$idx]; } my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; if( $num_extra != 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. FAIL } if($num_failed) { my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. FAIL _my_exit($real_exit_code) && return; } my $exit_code; if($num_failed) { $exit_code = $num_failed <= 254 ? $num_failed : 254; } elsif( $num_extra != 0 ) { $exit_code = 255; } else { $exit_code = 0; } _my_exit($exit_code) && return; } elsif( $self->{Skip_All} ) { _my_exit(0) && return; } elsif($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code before it could output anything. FAIL _my_exit($real_exit_code) && return; } else { $self->diag("No tests run!\n"); _my_exit(255) && return; } $self->_whoa( 1, "We fell off the end of _ending()" ); } END { $Test->_ending if defined $Test and !$Test->no_ending; } #line 2236 1; Makefile-DOM-0.006/inc/Test/Builder/0000755000175000001440000000000011626450365016146 5ustar agentzusersMakefile-DOM-0.006/inc/Test/Builder/Module.pm0000644000175000001440000000261611626450360017731 0ustar agentzusers#line 1 package Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export( $callpkg, @_ ); }; #line 82 sub import { my($class) = shift; # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); $class->$_export_to_level( 1, $class, @imports ); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } #line 145 sub import_extra { } #line 175 sub builder { return Test::Builder->new; } 1; Makefile-DOM-0.006/inc/Test/Base.pm0000644000175000001440000004306311626450360015771 0ustar agentzusers#line 1 package Test::Base; use 5.006001; use Spiffy 0.30 -Base; use Spiffy ':XXX'; our $VERSION = '0.60'; my @test_more_exports; BEGIN { @test_more_exports = qw( ok isnt like unlike is_deeply cmp_ok skip todo_skip pass fail eq_array eq_hash eq_set plan can_ok isa_ok diag use_ok $TODO ); } use Test::More import => \@test_more_exports; use Carp; our @EXPORT = (@test_more_exports, qw( is no_diff blocks next_block first_block delimiters spec_file spec_string filters filters_delay filter_arguments run run_compare run_is run_is_deeply run_like run_unlike skip_all_unless_require is_deep run_is_deep WWW XXX YYY ZZZ tie_output no_diag_on_only find_my_self default_object croak carp cluck confess )); field '_spec_file'; field '_spec_string'; field _filters => [qw(norm trim)]; field _filters_map => {}; field spec => -init => '$self->_spec_init'; field block_list => -init => '$self->_block_list_init'; field _next_list => []; field block_delim => -init => '$self->block_delim_default'; field data_delim => -init => '$self->data_delim_default'; field _filters_delay => 0; field _no_diag_on_only => 0; field block_delim_default => '==='; field data_delim_default => '---'; my $default_class; my $default_object; my $reserved_section_names = {}; sub default_object { $default_object ||= $default_class->new; return $default_object; } my $import_called = 0; sub import() { $import_called = 1; my $class = (grep /^-base$/i, @_) ? scalar(caller) : $_[0]; if (not defined $default_class) { $default_class = $class; } # else { # croak "Can't use $class after using $default_class" # unless $default_class->isa($class); # } unless (grep /^-base$/i, @_) { my @args; for (my $ii = 1; $ii <= $#_; ++$ii) { if ($_[$ii] eq '-package') { ++$ii; } else { push @args, $_[$ii]; } } Test::More->import(import => \@test_more_exports, @args) if @args; } _strict_warnings(); goto &Spiffy::import; } # Wrap Test::Builder::plan my $plan_code = \&Test::Builder::plan; my $Have_Plan = 0; { no warnings 'redefine'; *Test::Builder::plan = sub { $Have_Plan = 1; goto &$plan_code; }; } my $DIED = 0; $SIG{__DIE__} = sub { $DIED = 1; die @_ }; sub block_class { $self->find_class('Block') } sub filter_class { $self->find_class('Filter') } sub find_class { my $suffix = shift; my $class = ref($self) . "::$suffix"; return $class if $class->can('new'); $class = __PACKAGE__ . "::$suffix"; return $class if $class->can('new'); eval "require $class"; return $class if $class->can('new'); die "Can't find a class for $suffix"; } sub check_late { if ($self->{block_list}) { my $caller = (caller(1))[3]; $caller =~ s/.*:://; croak "Too late to call $caller()" } } sub find_my_self() { my $self = ref($_[0]) eq $default_class ? splice(@_, 0, 1) : default_object(); return $self, @_; } sub blocks() { (my ($self), @_) = find_my_self(@_); croak "Invalid arguments passed to 'blocks'" if @_ > 1; croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; my $blocks = $self->block_list; my $section_name = shift || ''; my @blocks = $section_name ? (grep { exists $_->{$section_name} } @$blocks) : (@$blocks); return scalar(@blocks) unless wantarray; return (@blocks) if $self->_filters_delay; for my $block (@blocks) { $block->run_filters unless $block->is_filtered; } return (@blocks); } sub next_block() { (my ($self), @_) = find_my_self(@_); my $list = $self->_next_list; if (@$list == 0) { $list = [@{$self->block_list}, undef]; $self->_next_list($list); } my $block = shift @$list; if (defined $block and not $block->is_filtered) { $block->run_filters; } return $block; } sub first_block() { (my ($self), @_) = find_my_self(@_); $self->_next_list([]); $self->next_block; } sub filters_delay() { (my ($self), @_) = find_my_self(@_); $self->_filters_delay(defined $_[0] ? shift : 1); } sub no_diag_on_only() { (my ($self), @_) = find_my_self(@_); $self->_no_diag_on_only(defined $_[0] ? shift : 1); } sub delimiters() { (my ($self), @_) = find_my_self(@_); $self->check_late; my ($block_delimiter, $data_delimiter) = @_; $block_delimiter ||= $self->block_delim_default; $data_delimiter ||= $self->data_delim_default; $self->block_delim($block_delimiter); $self->data_delim($data_delimiter); return $self; } sub spec_file() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_file(shift); return $self; } sub spec_string() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_string(shift); return $self; } sub filters() { (my ($self), @_) = find_my_self(@_); if (ref($_[0]) eq 'HASH') { $self->_filters_map(shift); } else { my $filters = $self->_filters; push @$filters, @_; } return $self; } sub filter_arguments() { $Test::Base::Filter::arguments; } sub have_text_diff { eval { require Text::Diff; 1 } && $Text::Diff::VERSION >= 0.35 && $Algorithm::Diff::VERSION >= 1.15; } sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; if ($ENV{TEST_SHOW_NO_DIFFS} or not defined $actual or not defined $expected or $actual eq $expected or not($self->have_text_diff) or $expected !~ /\n./s ) { Test::More::is($actual, $expected, $name); } else { $name = '' unless defined $name; ok $actual eq $expected, $name . "\n" . Text::Diff::diff(\$expected, \$actual); } } sub run(&;$) { (my ($self), @_) = find_my_self(@_); my $callback = shift; for my $block (@{$self->block_list}) { $block->run_filters unless $block->is_filtered; &{$callback}($block); } } my $name_error = "Can't determine section names"; sub _section_names { return @_ if @_ == 2; my $block = $self->first_block or croak $name_error; my @names = grep { $_ !~ /^(ONLY|LAST|SKIP)$/; } @{$block->{_section_order}[0] || []}; croak "$name_error. Need two sections in first block" unless @names == 2; return @names; } sub _assert_plan { plan('no_plan') unless $Have_Plan; } sub END { run_compare() unless $Have_Plan or $DIED or not $import_called; } sub run_compare() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; if (ref $block->$x) { is_deeply($block->$x, $block->$y, $block->name ? $block->name : ()); } elsif (ref $block->$y eq 'Regexp') { my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : ()); } else { is($block->$x, $block->$y, $block->name ? $block->name : ()); } } } sub run_is() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_is_deeply() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deeply($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_like() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : () ); } } sub run_unlike() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; unlike($block->$x, $regexp, $block->name ? $block->name : () ); } } sub skip_all_unless_require() { (my ($self), @_) = find_my_self(@_); my $module = shift; eval "require $module; 1" or Test::More::plan( skip_all => "$module failed to load" ); } sub is_deep() { (my ($self), @_) = find_my_self(@_); require Test::Deep; Test::Deep::cmp_deeply(@_); } sub run_is_deep() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deep($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub _pre_eval { my $spec = shift; return $spec unless $spec =~ s/\A\s*<<<(.*?)>>>\s*$//sm; my $eval_code = $1; eval "package main; $eval_code"; croak $@ if $@; return $spec; } sub _block_list_init { my $spec = $self->spec; $spec = $self->_pre_eval($spec); my $cd = $self->block_delim; my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); my $blocks = $self->_choose_blocks(@hunks); $self->block_list($blocks); # Need to set early for possible filter use my $seq = 1; for my $block (@$blocks) { $block->blocks_object($self); $block->seq_num($seq++); } return $blocks; } sub _choose_blocks { my $blocks = []; for my $hunk (@_) { my $block = $self->_make_block($hunk); if (exists $block->{ONLY}) { diag "I found ONLY: maybe you're debugging?" unless $self->_no_diag_on_only; return [$block]; } next if exists $block->{SKIP}; push @$blocks, $block; if (exists $block->{LAST}) { return $blocks; } } return $blocks; } sub _check_reserved { my $id = shift; croak "'$id' is a reserved name. Use something else.\n" if $reserved_section_names->{$id} or $id =~ /^_/; } sub _make_block { my $hunk = shift; my $cd = $self->block_delim; my $dd = $self->data_delim; my $block = $self->block_class->new; $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; my $name = $1; my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; my $description = shift @parts; $description ||= ''; unless ($description =~ /\S/) { $description = $name; } $description =~ s/\s*\z//; $block->set_value(description => $description); my $section_map = {}; my $section_order = []; while (@parts) { my ($type, $filters, $value) = splice(@parts, 0, 3); $self->_check_reserved($type); $value = '' unless defined $value; $filters = '' unless defined $filters; if ($filters =~ /:(\s|\z)/) { croak "Extra lines not allowed in '$type' section" if $value =~ /\S/; ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; $value = '' unless defined $value; $value =~ s/^\s*(.*?)\s*$/$1/; } $section_map->{$type} = { filters => $filters, }; push @$section_order, $type; $block->set_value($type, $value); } $block->set_value(name => $name); $block->set_value(_section_map => $section_map); $block->set_value(_section_order => $section_order); return $block; } sub _spec_init { return $self->_spec_string if $self->_spec_string; local $/; my $spec; if (my $spec_file = $self->_spec_file) { open FILE, $spec_file or die $!; $spec = ; close FILE; } else { $spec = do { package main; no warnings 'once'; ; }; } return $spec; } sub _strict_warnings() { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = "use strict;use warnings;$data$end"; $done = 1; } ); } sub tie_output() { my $handle = shift; die "No buffer to tie" unless @_; tie *$handle, 'Test::Base::Handle', $_[0]; } sub no_diff { $ENV{TEST_SHOW_NO_DIFFS} = 1; } package Test::Base::Handle; sub TIEHANDLE() { my $class = shift; bless \ $_[0], $class; } sub PRINT { $$self .= $_ for @_; } #=============================================================================== # Test::Base::Block # # This is the default class for accessing a Test::Base block object. #=============================================================================== package Test::Base::Block; our @ISA = qw(Spiffy); our @EXPORT = qw(block_accessor); sub AUTOLOAD { return; } sub block_accessor() { my $accessor = shift; no strict 'refs'; return if defined &$accessor; *$accessor = sub { my $self = shift; if (@_) { Carp::croak "Not allowed to set values for '$accessor'"; } my @list = @{$self->{$accessor} || []}; return wantarray ? (@list) : $list[0]; }; } block_accessor 'name'; block_accessor 'description'; Spiffy::field 'seq_num'; Spiffy::field 'is_filtered'; Spiffy::field 'blocks_object'; Spiffy::field 'original_values' => {}; sub set_value { no strict 'refs'; my $accessor = shift; block_accessor $accessor unless defined &$accessor; $self->{$accessor} = [@_]; } sub run_filters { my $map = $self->_section_map; my $order = $self->_section_order; Carp::croak "Attempt to filter a block twice" if $self->is_filtered; for my $type (@$order) { my $filters = $map->{$type}{filters}; my @value = $self->$type; $self->original_values->{$type} = $value[0]; for my $filter ($self->_get_filters($type, $filters)) { $Test::Base::Filter::arguments = $filter =~ s/=(.*)$// ? $1 : undef; my $function = "main::$filter"; no strict 'refs'; if (defined &$function) { local $_ = (@value == 1 and not defined($value[0])) ? undef : join '', @value; my $old = $_; @value = &$function(@value); if (not(@value) or @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ ) { if ($value[0] && $_ eq $old) { Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); } @value = ($_); } } else { my $filter_object = $self->blocks_object->filter_class->new; die "Can't find a function or method for '$filter' filter\n" unless $filter_object->can($filter); $filter_object->current_block($self); @value = $filter_object->$filter(@value); } # Set the value after each filter since other filters may be # introspecting. $self->set_value($type, @value); } } $self->is_filtered(1); } sub _get_filters { my $type = shift; my $string = shift || ''; $string =~ s/\s*(.*?)\s*/$1/; my @filters = (); my $map_filters = $self->blocks_object->_filters_map->{$type} || []; $map_filters = [ $map_filters ] unless ref $map_filters; my @append = (); for ( @{$self->blocks_object->_filters}, @$map_filters, split(/\s+/, $string), ) { my $filter = $_; last unless length $filter; if ($filter =~ s/^-//) { @filters = grep { $_ ne $filter } @filters; } elsif ($filter =~ s/^\+//) { push @append, $filter; } else { push @filters, $filter; } } return @filters, @append; } { %$reserved_section_names = map { ($_, 1); } keys(%Test::Base::Block::), qw( new DESTROY ); } __DATA__ =encoding utf8 #line 1374 Makefile-DOM-0.006/inc/Test/More.pm0000644000175000001440000004054511626450360016023 0ustar agentzusers#line 1 package Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '0.92'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain BAIL_OUT ); #line 163 sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } else { push @other, $item; } $idx++; } @$list = @other; return; } #line 216 sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } #line 289 sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } #line 367 sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } *isn't = \&isnt; #line 411 sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } #line 426 sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } #line 471 sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } #line 506 sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } #line 572 sub isa_ok ($$;$) { my( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; if( !defined $object ) { $obj_name = 'The thing' unless defined $obj_name; $diag = "$obj_name isn't defined"; } else { my $whatami = ref $object ? 'object' : 'class'; # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); if($error) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference $obj_name = 'The reference' unless defined $obj_name; if( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } elsif( $error =~ /Can't call method "isa" without a package/ ) { # It's something that can't even be a class $diag = "$obj_name isn't a class or reference"; } else { die <isa on your $whatami and got some weird error. Here's the error. $error WHOA } } else { $obj_name = "The $whatami" unless defined $obj_name; if( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } } my $name = "$obj_name isa $class"; my $ok; if($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } else { $ok = $tb->ok( 1, $name ); } return $ok; } #line 650 sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; $object_name = "The object" unless defined $object_name; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $tb->ok( 0, "new() died" ); $tb->diag(" Error was: $error"); } return $obj; } #line 690 sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } #line 753 sub use_ok ($;@) { my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my( $pack, $filename, $line ) = caller; my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; my $pack = caller; # Try to deterine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(<builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } #line 1059 sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } #line 1085 sub explain { return Test::More->builder->explain(@_); } #line 1151 ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } #line 1238 sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } #line 1293 sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } #line 1332 #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { # Quiet uninitialized value warnings when comparing undefs. no warnings 'uninitialized'; $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both defined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } #line 1465 sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } #line 1522 sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } #line 1735 1; Makefile-DOM-0.006/inc/Test/Base/0000755000175000001440000000000011626450365015432 5ustar agentzusersMakefile-DOM-0.006/inc/Test/Base/Filter.pm0000644000175000001440000001576611626450360017227 0ustar agentzusers#line 1 #=============================================================================== # This is the default class for handling Test::Base data filtering. #=============================================================================== package Test::Base::Filter; use Spiffy -Base; use Spiffy ':XXX'; field 'current_block'; our $arguments; sub current_arguments { return undef unless defined $arguments; my $args = $arguments; $args =~ s/(\\s)/ /g; $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; return $args; } sub assert_scalar { return if @_ == 1; require Carp; my $filter = (caller(1))[3]; $filter =~ s/.*:://; Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; } sub _apply_deepest { my $method = shift; return () unless @_; if (ref $_[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_apply_deepest($method, @$aref); } return @_; } $self->$method(@_); } sub _split_array { map { [$self->split($_)]; } @_; } sub _peel_deepest { return () unless @_; if (ref $_[0] eq 'ARRAY') { if (ref $_[0]->[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_peel_deepest(@$aref); } return @_; } return map { $_->[0] } @_; } return @_; } #=============================================================================== # these filters work on the leaves of nested arrays #=============================================================================== sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } sub Reverse { $self->_apply_deepest(reverse => @_) } sub Split { $self->_apply_deepest(_split_array => @_) } sub Sort { $self->_apply_deepest(sort => @_) } sub append { my $suffix = $self->current_arguments; map { $_ . $suffix } @_; } sub array { return [@_]; } sub base64_decode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::decode_base64(shift); } sub base64_encode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::encode_base64(shift); } sub chomp { map { CORE::chomp; $_ } @_; } sub chop { map { CORE::chop; $_ } @_; } sub dumper { no warnings 'once'; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; Data::Dumper::Dumper(@_); } sub escape { $self->assert_scalar(@_); my $text = shift; $text =~ s/(\\.)/eval "qq{$1}"/ge; return $text; } sub eval { $self->assert_scalar(@_); my @return = CORE::eval(shift); return $@ if $@; return @return; } sub eval_all { $self->assert_scalar(@_); my $out = ''; my $err = ''; Test::Base::tie_output(*STDOUT, $out); Test::Base::tie_output(*STDERR, $err); my $return = CORE::eval(shift); no warnings; untie *STDOUT; untie *STDERR; return $return, $@, $out, $err; } sub eval_stderr { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDERR, $output); CORE::eval(shift); no warnings; untie *STDERR; return $output; } sub eval_stdout { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDOUT, $output); CORE::eval(shift); no warnings; untie *STDOUT; return $output; } sub exec_perl_stdout { my $tmpfile = "/tmp/test-blocks-$$"; $self->_write_to($tmpfile, @_); open my $execution, "$^X $tmpfile 2>&1 |" or die "Couldn't open subprocess: $!\n"; local $/; my $output = <$execution>; close $execution; unlink($tmpfile) or die "Couldn't unlink $tmpfile: $!\n"; return $output; } sub flatten { $self->assert_scalar(@_); my $ref = shift; if (ref($ref) eq 'HASH') { return map { ($_, $ref->{$_}); } sort keys %$ref; } if (ref($ref) eq 'ARRAY') { return @$ref; } die "Can only flatten a hash or array ref"; } sub get_url { $self->assert_scalar(@_); my $url = shift; CORE::chomp($url); require LWP::Simple; LWP::Simple::get($url); } sub hash { return +{ @_ }; } sub head { my $size = $self->current_arguments || 1; return splice(@_, 0, $size); } sub join { my $string = $self->current_arguments; $string = '' unless defined $string; CORE::join $string, @_; } sub lines { $self->assert_scalar(@_); my $text = shift; return () unless length $text; my @lines = ($text =~ /^(.*\n?)/gm); return @lines; } sub norm { $self->assert_scalar(@_); my $text = shift; $text = '' unless defined $text; $text =~ s/\015\012/\n/g; $text =~ s/\r/\n/g; return $text; } sub prepend { my $prefix = $self->current_arguments; map { $prefix . $_ } @_; } sub read_file { $self->assert_scalar(@_); my $file = shift; CORE::chomp $file; open my $fh, $file or die "Can't open '$file' for input:\n$!"; CORE::join '', <$fh>; } sub regexp { $self->assert_scalar(@_); my $text = shift; my $flags = $self->current_arguments; if ($text =~ /\n.*?\n/s) { $flags = 'xism' unless defined $flags; } else { CORE::chomp($text); } $flags ||= ''; my $regexp = eval "qr{$text}$flags"; die $@ if $@; return $regexp; } sub reverse { CORE::reverse(@_); } sub slice { die "Invalid args for slice" unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; my ($x, $y) = ($1, $2); $y = $x if not defined $y; die "Invalid args for slice" if $x > $y; return splice(@_, $x, 1 + $y - $x); } sub sort { CORE::sort(@_); } sub split { $self->assert_scalar(@_); my $separator = $self->current_arguments; if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { my $regexp = $1; $separator = qr{$regexp}; } $separator = qr/\s+/ unless $separator; CORE::split $separator, shift; } sub strict { $self->assert_scalar(@_); <<'...' . shift; use strict; use warnings; ... } sub tail { my $size = $self->current_arguments || 1; return splice(@_, @_ - $size, $size); } sub trim { map { s/\A([ \t]*\n)+//; s/(?<=\n)\s*\z//g; $_; } @_; } sub unchomp { map { $_ . "\n" } @_; } sub write_file { my $file = $self->current_arguments or die "No file specified for write_file filter"; if ($file =~ /(.*)[\\\/]/) { my $dir = $1; if (not -e $dir) { require File::Path; File::Path::mkpath($dir) or die "Can't create $dir"; } } open my $fh, ">$file" or die "Can't open '$file' for output\n:$!"; print $fh @_; close $fh; return $file; } sub yaml { $self->assert_scalar(@_); require YAML; return YAML::Load(shift); } sub _write_to { my $filename = shift; open my $script, ">$filename" or die "Couldn't open $filename: $!\n"; print $script @_; close $script or die "Couldn't close $filename: $!\n"; } __DATA__ #line 636