XML-SAX-Writer-0.53/000755 000765 000024 00000000000 11416644002 014764 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/Changes000755 000765 000024 00000006423 11416643316 016276 0ustar00perigrinstaff000000 000000 Revision history for XML::SAX::Writer ------------------------------------- 0.53 - 2010-07-12 - Switch from Text::IconV to Encode (David Pinkowitz) - Update package Module::Install metadata discovery 0.52 - 2008-11-19 - Fix spelling of QuoteCharacter 0.51 - 2008-11-19 - Added QuoteCharecter parameter to new() to control quoting of attributes (perigrin) - Added Tests and Docs 0.50 - Sep 14, 2006 - fixed redundant skipped entity at start_dtd (RT.cpan.org #18546) - attribute_decl expects Mode instead of ValueDefault property to fit to Perl SAX 2.1 (ValueDefault still supported) - fixed make test failure with Text::Iconv 1.3 or higher (RT.cpan.org #7436 and #9690) - fixed make test failure on VMS (RT.cpan.org #18663) - fixed dropped output on encoding conversion errors (RT.cpan.org #17177) 0.43 - 0.44 fri 20020906 18:27 - made the basic tests work again despite the fact we now return a BufferText object - fixed a bug reported by Grant that prevented proper use of output FH under some conditions. 0.42 - thu 20020801 17:17 - fixed a serious bug in StringConsumer, thanks to help from Barrie Slaymaker, Adam Turoff, and Eric Cholet. 0.40 - 0.41 sat 20020706 18:01 - implemented the subclassable SAX writing framework - documented the converter API - made comments be escaped differently - fixed doctype writing (Michel Rodriguez) - fixed a warning (Joshua Keroes) - requires correct version of Test::More (Richard Dice) - fixed CDATA escaping - we return a BufferText object now, to make sure that multiple charater escapes work - lots of stuff thanks to Barrie Slaymaker: - Rewrite of all consumers to be smaller and faster. - XML::SAX::Writer::ConsumerInterface::new is now a real constructor which all derived classes should call. - finalize is now not called unless it exists. - A file name of "0" will not cause an exception. - One error message now reports the package name properly if it was subclassed. - base.pm is no longer used. - the test suite runs events through Writer and in to CodeConsumer and a custom consumer. - Custom consumers are better documented (barries). 0.39 wed 20020116 22:15:41 - fixed an FH problem (Dave Rolsky) - the null converter was so null that it converted strings to nothing (Graham Barr) 0.38 wed 20020116 21:41:41 - several major bugfixes that prevented some consumers (mostly Handle and File) from working at all. - the beginning of a test suite. It doesn't test the correctness of the XML that is created yet, but it does at least go through all the basic functions that are needed for that to work. 0.37 wed 20020116 16:11:15 - on Solaris it would seem that iconv has problems converting an encoding to itself (at least, utf-8 to utf-8). Given that this is a useless operation, it is now detected and replaced with a noop (thanks to David N. Blank-Edelman for reporting this). 0.02 - 0.36 - many bugfixes thanks to many helpful people, notably Barrie Slaymaker, Dave Rolsky, Sean M. Burke, and others. 0.01 mon 20011126 02:31:58 - original version XML-SAX-Writer-0.53/inc/000755 000765 000024 00000000000 11416644002 015535 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/lib/000755 000765 000024 00000000000 11416644002 015532 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/Makefile.PL000755 000765 000024 00000000557 11416643011 016747 0ustar00perigrinstaff000000 000000 use inc::Module::Install; name 'XML-SAX-Writer'; all_from 'lib/XML/SAX/Writer.pm'; requires 'Encode' => '2.12'; requires 'XML::SAX::Exception' => '1.01'; requires 'XML::NamespaceSupport' => '1.00'; requires 'XML::Filter::BufferText' => '1.00'; build_requires 'Test::More' => '0.40'; auto_set_repository; auto_manifest; WriteAll;XML-SAX-Writer-0.53/MANIFEST000644 000765 000024 00000000766 11416644002 016126 0ustar00perigrinstaff000000 000000 Changes inc/Module/Install.pm inc/Module/Install/AutoManifest.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Repository.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/XML/SAX/Writer.pm lib/XML/SAX/Writer/XML.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/05basic.t t/10consumers.t t/20bugs.t test_file1 test_file2 test_file_for_output XML-SAX-Writer-0.53/MANIFEST.SKIP000644 000765 000024 00000000335 11416643042 016666 0ustar00perigrinstaff000000 000000 ^\.git ^_build ^Build$ ^blib ~$ \.bak$ CVS \.svn \.DS_Store cover_db \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^MakeMaker-\d ^blibdirs$ \.old$ ^#.*#$ ^\.# ^TODO$ ^PLANS$ ^doc/ ^benchmarks ^\._.*$ ^t\/600_todo_tests\/$ \.shipit XML-SAX-Writer-0.53/META.yml000644 000765 000024 00000001161 11416643344 016244 0ustar00perigrinstaff000000 000000 --- abstract: 'SAX2 Writer' author: - 'Robin Berjon, robin@knowscape.com' build_requires: ExtUtils::MakeMaker: 6.42 Test::More: 0.40 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-SAX-Writer no_index: directory: - inc - t requires: Encode: 2.12 XML::Filter::BufferText: 1.00 XML::NamespaceSupport: 1.00 XML::SAX::Exception: 1.01 resources: license: http://dev.perl.org/licenses/ repository: origin version: 0.53 XML-SAX-Writer-0.53/README000755 000765 000024 00000002333 11110371036 015643 0ustar00perigrinstaff000000 000000 XML::SAX::Writer - SAX2 XML Writer ================================== About this module ----------------- This module has been developed by Robin Berjon . Since version 0.50, it is maintained by means of the Perl XML project [perl-xml.sourceforge.net]: - The sources are stored in the SourceForge Subversion repository: repository: https://svn.sourceforge.net/svnroot/perl-xml - Requests and comments should be sent to the Perl-XML@listserv.ActiveState.com mailing list - Bugs should be reported to RT.cpan.org Robin considered this module alpha but after years of testing on humans we believe it can be considered beta now. The version 0.50 has been created by Petr Cimprich , using patches and sugestions from RT.cpan.org. Thanks go to all those who reported bugs and suggested fixes. Usage ----- use XML::SAX::Writer; use XML::SAX::SomeDriver; my $w = XML::SAX::Writer->new; my $d = XML::SAX::SomeDriver->new(Handler => $w); $d->parse('some options...'); See http://perl-xml.sourceforge.net/perl-sax/ for more details about Perl SAX 2. License ------- This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-SAX-Writer-0.53/t/000755 000765 000024 00000000000 11416644002 015227 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/test_file1000644 000765 000024 00000000021 11416644002 016737 0ustar00perigrinstaff000000 000000 FILE ONE FILE ONEXML-SAX-Writer-0.53/test_file2000644 000765 000024 00000000021 11416644002 016740 0ustar00perigrinstaff000000 000000 FILE TWO FILE TWOXML-SAX-Writer-0.53/test_file_for_output000644 000765 000024 00000000000 11416644001 021140 0ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/t/05basic.t000755 000765 000024 00000010052 11225002361 016635 0ustar00perigrinstaff000000 000000 ### # XML::SAX::Writer tests # Robin Berjon # 06/01/2002 - v0.01 ### use strict; use Test::More tests => 30; BEGIN { use_ok('XML::SAX::Writer'); } # VMS has different names for codepages my $isoL1 = ($^O eq 'VMS') ? 'iso8859-1' : 'iso-8859-1'; my $isoL2 = ($^O eq 'VMS') ? 'iso8859-2' : 'iso-8859-2'; # default options of XML::SAX::Writer my $w1 = XML::SAX::Writer->new->{Handler}; ok( $w1->{EncodeFrom} eq 'utf-8', 'default EncodeFrom'); ok( $w1->{EncodeTo} eq 'utf-8', 'default EncodeTo'); isa_ok( $w1->{Output}, 'IO::Handle', 'default Output'); is_deeply( $w1->{Format}, {}, 'default Format'); is_deeply( $w1->{Escape}, \%XML::SAX::Writer::DEFAULT_ESCAPE, 'default Escape'); is( $w1->{QuoteCharacter}, q['], 'default QuoteCharacter'); # set default options of XML::SAX::Writer my %fmt2 = ( FooBar => 1 ); my $o2 = \''; my $w2 = XML::SAX::Writer->new({ EncodeFrom => $isoL1, EncodeTo => $isoL2, Output => $o2, Format => \%fmt2, Escape => {}, QuoteCharacter => q["], })->{Handler}; ok( $w2->{EncodeFrom} eq $isoL1, 'set EncodeFrom'); ok( $w2->{EncodeTo} eq $isoL2, 'set EncodeTo'); ok( "$w2->{Output}" eq "$o2", 'set Output'); is_deeply( $w2->{Format}, \%fmt2, 'set Format'); is_deeply( $w2->{Escape}, {}, 'set Escape'); is( $w2->{QuoteCharacter}, q["], 'set QuoteCharacter'); # options after initialisation $w1->start_document; isa_ok($w1->{Encoder}, 'XML::SAX::Writer::NullConverter', 'null converter for noop encoding'); my $w3 = XML::SAX::Writer->new({ EncodeFrom => $isoL1, EncodeTo => $isoL2, })->{Handler}; $w3->start_document; isa_ok($w3->{Encoder}, 'XML::SAX::Writer::Encode', 'converter for encoding using Encode'); isa_ok($w1->{NSHelper}, 'XML::NamespaceSupport', 'ns support'); ok(ref($w1->{EscaperRegex}) eq 'Regexp', 'escaper regex'); ok(ref($w1->{NSDecl}) eq 'ARRAY', 'ns stack'); ok(@{$w1->{NSDecl}} == 0, 'ns stack is clear'); isa_ok($w1->{Consumer}, 'XML::SAX::Writer::ConsumerInterface', 'consumer is set'); # different inits (mostly for Consumer DWIM) $w1->{EncodeFrom} = $isoL1; $w1->start_document; $w1->{Output} = 'test_file_for_output'; $w1->start_document; isa_ok($w1->{Consumer}, 'XML::SAX::Writer::FileConsumer', 'consumer is FileConsumer'); my $ot = ''; $w1->{Output} = \$ot; $w1->start_document; isa_ok($w1->{Consumer}, 'XML::SAX::Writer::StringConsumer', 'consumer is StringConsumer'); $w1->{Output} = []; $w1->start_document; isa_ok($w1->{Consumer}, 'XML::SAX::Writer::ArrayConsumer', 'consumer is ArrayConsumer'); $w1->{Output} = *STDOUT; $w1->start_document; isa_ok($w1->{Consumer}, 'XML::SAX::Writer::HandleConsumer', 'consumer is HandleConsumer'); $w1->{Output} = bless [], 'Test__XSW1'; sub Test__XSW1::output {} $w1->start_document; isa_ok($w1->{Consumer}, 'Test__XSW1', 'consumer is custom'); $w1->{Output} = bless [], 'Test__XSW2'; eval { $w1->start_document; }; ok($@, 'bad consumer'); isa_ok($@, 'XML::SAX::Writer::Exception', 'bad consumer exception'); # escaping my $esc1 = '<>&"\''; my $eq1 = '<>&"''; my $res1 = $w1->escape($esc1); is($res1, $eq1, 'escaping (default)'); # converting my $conv1 = XML::SAX::Writer::NullConverter->new; my $str1 = 'TEST'; my $res_1 = $conv1->convert($str1); is($str1, $res_1, 'noop converter'); my $conv2 = XML::SAX::Writer::Encode->new('iso-8859-1', 'utf-8'); my $str2 = 'Cnvert'; my $res_2 = $conv2->convert($str2); use Encode; Encode::from_to($str2, 'iso-8859-1', 'utf-8'); is($str2, $res_2, 'Encode converter'); XML-SAX-Writer-0.53/t/10consumers.t000755 000765 000024 00000004667 11110371036 017606 0ustar00perigrinstaff000000 000000 ### # XML::SAX::Writer tests # Robin Berjon # 06/01/2002 - v0.01 ### use strict; package MyConsumer; @MyConsumer::ISA = qw( XML::SAX::Writer::ConsumerInterface ); sub new { my $self = shift->SUPER::new( my $output ); $$self = '' ; # Note the extra '$' return $self; } sub output { my $self = shift; $$self .= uc shift; } sub get_output { my $self = shift; return $$self; } package main; use Test::More tests => 15; use XML::SAX::Writer qw(); # StringConsumer my $ref1 = 'MUST_CLEAR'; my $str = XML::SAX::Writer::StringConsumer->new(\$ref1); isa_ok($str, 'XML::SAX::Writer::StringConsumer', 'StringConsumer'); $str->output('CONTENT'); my $res1 = $str->finalize; ok($$res1 eq 'CONTENT', 'content is set'); # ArrayConsumer my $arr = XML::SAX::Writer::ArrayConsumer->new([]); isa_ok($arr, 'XML::SAX::Writer::ArrayConsumer', 'ArrayConsumer'); $arr->output('CONTENT0'); $arr->output('CONTENT1'); my $res2 = $arr->finalize; ok($res2->[0] eq 'CONTENT0', 'content (1)'); ok($res2->[1] eq 'CONTENT1', 'content (2)'); # HandleConsumer and FileConsumer my $fil1 = XML::SAX::Writer::FileConsumer->new('test_file1'); isa_ok($fil1, 'XML::SAX::Writer::FileConsumer', 'FileConsumer'); isa_ok($fil1, 'XML::SAX::Writer::HandleConsumer', 'HandleConsumer'); $fil1->output('FILE ONE'); my $fil2 = XML::SAX::Writer::FileConsumer->new('test_file2'); $fil2->output('FILE TWO'); $fil1->output(' FILE ONE'); $fil2->output(' FILE TWO'); $fil1->finalize; $fil2->finalize; open FH1, "test_file1" or die $!; my $cnt1 = ; close FH1; open FH2, "test_file2" or die $!; my $cnt2 = ; close FH2; ok($cnt1 eq 'FILE ONE FILE ONE', 'file content (1)'); ok($cnt2 eq 'FILE TWO FILE TWO', 'file content (2)'); ## ## Now, test some of the consumers "in situ" ## sub push_events { my $w = XML::SAX::Writer->new( Output => shift ); $w->start_document( {} ); $w->start_element( { Name => "foo" } ); $w->end_element( { Name => "foo" } ); $w->end_document( {} ); } { my @events; push_events( sub { push @events, [ @_ ] } ); ok @events >= 3; ok $events[0]->[0], "start_document"; ok $events[1]->[0], "data"; ok $events[-1]->[0], "end_document"; ## This next test might break id X::S::W ever stops ## putting that space in there. ok join( "", map $_->[1], @events ), ""; } ## ## A custom consumer ## { my $c = MyConsumer->new; push_events( $c ); ok $c->get_output, ""; } XML-SAX-Writer-0.53/t/20bugs.t000755 000765 000024 00000003347 11110371036 016523 0ustar00perigrinstaff000000 000000 ### # XML::SAX::Writer tests # Petr Cimprich # 09/11/2006 - v0.01 ### use strict; use Test::More tests => 2; use XML::SAX::Writer qw(); my $isoL1 = ($^O eq 'VMS') ? 'iso8859-1' : 'iso-8859-1'; my $out = ''; my $str1 = 'foo'; my $str2 = 'žščřďťňáéíóůúý'; # can't be encoded in iso-8859-1 ################################################## # encoding test my $w = XML::SAX::Writer->new({ EncodeFrom => 'utf-8', EncodeTo => $isoL1, Output => \$out, })->{Handler}; $w->start_document; $w->start_element({Name => 'root', Prefix => '', LocalName => 'root', NamespaceURI => '', Attributes => {}}); $w->characters({Data => $str1}); $w->end_element({Name => 'root', Prefix => '', LocalName => 'root', NamespaceURI => ''}); $w->end_document; #print $out; ok($out eq "$str1", 'ASCII characters'); ################################################## # encoding error - char does not exist in a codepage $w = XML::SAX::Writer->new({ EncodeFrom => 'utf-8', EncodeTo => $isoL1, Output => \$out, })->{Handler}; # silent warnings since now $SIG{__WARN__} = sub {}; $w->start_document; $w->start_element({Name => 'root', Prefix => '', LocalName => 'root', NamespaceURI => '', Attributes => {}}); $w->characters({Data => $str2}); $w->end_element({Name => 'root', Prefix => '', LocalName => 'root', NamespaceURI => ''}); $w->end_document; ok($out eq "_LOST_DATA_", 'Latin2 characters'); XML-SAX-Writer-0.53/lib/XML/000755 000765 000024 00000000000 11416644002 016172 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/lib/XML/SAX/000755 000765 000024 00000000000 11416644002 016625 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/lib/XML/SAX/Writer/000755 000765 000024 00000000000 11416644002 020101 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/lib/XML/SAX/Writer.pm000755 000765 000024 00000053476 11416643276 020475 0ustar00perigrinstaff000000 000000 ### # XML::SAX::Writer - SAX2 XML Writer # Robin Berjon ### package XML::SAX::Writer; use strict; use vars qw($VERSION %DEFAULT_ESCAPE %COMMENT_ESCAPE); $VERSION = '0.53'; use Encode qw(); use XML::SAX::Exception qw(); use XML::SAX::Writer::XML qw(); use XML::Filter::BufferText qw(); @XML::SAX::Writer::Exception::ISA = qw(XML::SAX::Exception); %DEFAULT_ESCAPE = ( '&' => '&', '<' => '<', '>' => '>', '"' => '"', "'" => ''', ); %COMMENT_ESCAPE = ( '--' => '--', ); #-------------------------------------------------------------------# # new #-------------------------------------------------------------------# sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $opt = (@_ == 1) ? { %{shift()} } : {@_}; # default the options $opt->{Writer} ||= 'XML::SAX::Writer::XML'; $opt->{Escape} ||= \%DEFAULT_ESCAPE; $opt->{CommentEscape} ||= \%COMMENT_ESCAPE; $opt->{EncodeFrom} ||= 'utf-8'; $opt->{EncodeTo} ||= 'utf-8'; $opt->{Format} ||= {}; # needs options w/ defaults, we'll see later $opt->{Output} ||= *{STDOUT}{IO}; $opt->{QuoteCharacter} ||= q[']; eval "use $opt->{Writer};"; my $obj = bless $opt, $opt->{Writer}; $obj->init; # we need to buffer the text to escape it right my $bf = XML::Filter::BufferText->new( Handler => $obj ); return $bf; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # init #-------------------------------------------------------------------# sub init {} # noop, for subclasses #-------------------------------------------------------------------# #-------------------------------------------------------------------# # setConverter #-------------------------------------------------------------------# sub setConverter { my $self = shift; if (lc($self->{EncodeFrom}) ne lc($self->{EncodeTo})) { $self->{Encoder} = XML::SAX::Writer::Encode->new($self->{EncodeFrom}, $self->{EncodeTo}); } else { $self->{Encoder} = XML::SAX::Writer::NullConverter->new; } return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # setConsumer #-------------------------------------------------------------------# sub setConsumer { my $self = shift; # create the Consumer my $ref = ref $self->{Output}; if ($ref eq 'SCALAR') { $self->{Consumer} = XML::SAX::Writer::StringConsumer->new($self->{Output}); } elsif ($ref eq 'CODE') { $self->{Consumer} = XML::SAX::Writer::CodeConsumer->new($self->{Output}); } elsif ($ref eq 'ARRAY') { $self->{Consumer} = XML::SAX::Writer::ArrayConsumer->new($self->{Output}); } elsif ( $ref eq 'GLOB' or UNIVERSAL::isa(\$self->{Output}, 'GLOB') or UNIVERSAL::isa($self->{Output}, 'IO::Handle')) { $self->{Consumer} = XML::SAX::Writer::HandleConsumer->new($self->{Output}); } elsif (not $ref) { $self->{Consumer} = XML::SAX::Writer::FileConsumer->new($self->{Output}); } elsif (UNIVERSAL::can($self->{Output}, 'output')) { $self->{Consumer} = $self->{Output}; } else { XML::SAX::Writer::Exception->throw( Message => 'Unknown option for Output' ); } return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # setEscaperRegex #-------------------------------------------------------------------# sub setEscaperRegex { my $self = shift; $self->{EscaperRegex} = eval 'qr/' . join( '|', map { $_ = "\Q$_\E" } keys %{$self->{Escape}}) . '/;' ; return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # setCommentEscaperRegex #-------------------------------------------------------------------# sub setCommentEscaperRegex { my $self = shift; $self->{CommentEscaperRegex} = eval 'qr/' . join( '|', map { $_ = "\Q$_\E" } keys %{$self->{CommentEscape}}) . '/;' ; return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # escape #-------------------------------------------------------------------# sub escape { my $self = shift; my $str = shift; $str =~ s/($self->{EscaperRegex})/$self->{Escape}->{$1}/oge; return $str; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # escapeComment #-------------------------------------------------------------------# sub escapeComment { my $self = shift; my $str = shift; $str =~ s/($self->{CommentEscaperRegex})/$self->{CommentEscape}->{$1}/oge; return $str; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # convert and checking the return value #-------------------------------------------------------------------# sub safeConvert { my $self = shift; my $str = shift; my $out = $self->{Encoder}->convert($str); if (!defined $out and defined $str) { warn "Conversion error returned by Encoder [$self->{Encoder}], string: '$str'"; $out = '_LOST_DATA_'; } return $out; } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The Empty Consumer ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# # this package is only there to provide a smooth upgrade path in case # new methods are added to the interface package XML::SAX::Writer::ConsumerInterface; sub new { my $class = shift; my $ref = shift; ## $self is a reference to the reference that we will send output ## to. This allows us to bless $self without blessing $$self. return bless \$ref, ref $class || $class; } sub output {} sub finalize {} #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The String Consumer `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::StringConsumer; @XML::SAX::Writer::StringConsumer::ISA = qw(XML::SAX::Writer::ConsumerInterface); #-------------------------------------------------------------------# # new #-------------------------------------------------------------------# sub new { my $self = shift->SUPER::new( @_ ); ${${$self}} = ''; return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # output #-------------------------------------------------------------------# sub output { ${${$_[0]}} .= $_[1] } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # finalize #-------------------------------------------------------------------# sub finalize { ${$_[0]} } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The Code Consumer `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::CodeConsumer; @XML::SAX::Writer::CodeConsumer::ISA = qw(XML::SAX::Writer::ConsumerInterface ); #-------------------------------------------------------------------# # new #-------------------------------------------------------------------# sub new { my $self = shift->SUPER::new( @_ ); $$self->( 'start_document', '' ); return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # output #-------------------------------------------------------------------# sub output { ${$_[0]}->('data', pop) } ## Avoid an extra copy #-------------------------------------------------------------------# #-------------------------------------------------------------------# # finalize #-------------------------------------------------------------------# sub finalize { ${$_[0]}->('end_document', '') } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The Array Consumer ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::ArrayConsumer; @XML::SAX::Writer::ArrayConsumer::ISA = qw(XML::SAX::Writer::ConsumerInterface); #-------------------------------------------------------------------# # new #-------------------------------------------------------------------# sub new { my $self = shift->SUPER::new( @_ ); @$$self = (); return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # output #-------------------------------------------------------------------# sub output { push @${$_[0]}, pop } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # finalize #-------------------------------------------------------------------# sub finalize { return ${$_[0]} } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The Handle Consumer `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::HandleConsumer; @XML::SAX::Writer::HandleConsumer::ISA = qw(XML::SAX::Writer::ConsumerInterface); #-------------------------------------------------------------------# # output #-------------------------------------------------------------------# sub output { my $fh = ${$_[0]}; print $fh pop or XML::SAX::Exception->throw( Message => "Could not write to handle: $fh ($!)" ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # finalize #-------------------------------------------------------------------# sub finalize { return 0 } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The File Consumer `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::FileConsumer; @XML::SAX::Writer::FileConsumer::ISA = qw(XML::SAX::Writer::HandleConsumer); #-------------------------------------------------------------------# # new #-------------------------------------------------------------------# sub new { my ( $proto, $file ) = ( shift, shift ); XML::SAX::Writer::Exception->throw( Message => "No filename provided to " . ref( $proto || $proto ) ) unless defined $file; local *XFH; open XFH, ">$file" or XML::SAX::Writer::Exception->throw( Message => "Error opening file $file: $!" ); return $proto->SUPER::new( *{XFH}{IO}, @_ ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # finalize #-------------------------------------------------------------------# sub finalize { close ${$_[0]}; return 0; } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Noop Converter ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::NullConverter; sub new { return bless [], __PACKAGE__ } sub convert { $_[1] } #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Encode Converter ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# package XML::SAX::Writer::Encode; sub new { my $class = shift; my $self = { from_enc => shift, to_enc => shift, }; return bless $self, $class; } sub convert { my $self = shift; my $data = shift; eval { Encode::from_to( $data, $self->{from_enc}, $self->{to_enc}, Encode::FB_CROAK ); }; return $@ ? undef : $data; }; 1; #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# =pod =head1 NAME XML::SAX::Writer - SAX2 Writer =head1 SYNOPSIS use XML::SAX::Writer; use XML::SAX::SomeDriver; my $w = XML::SAX::Writer->new; my $d = XML::SAX::SomeDriver->new(Handler => $w); $d->parse('some options...'); =head1 DESCRIPTION =head2 Why yet another XML Writer ? A new XML Writer was needed to match the SAX2 effort because quite naturally no existing writer understood SAX2. My first intention had been to start patching XML::Handler::YAWriter as it had previously been my favourite writer in the SAX1 world. However the more I patched it the more I realised that what I thought was going to be a simple patch (mostly adding a few event handlers and changing the attribute syntax) was turning out to be a rewrite due to various ideas I'd been collecting along the way. Besides, I couldn't find a way to elegantly make it work with SAX2 without breaking the SAX1 compatibility which people are probably still using. There are of course ways to do that, but most require user interaction which is something I wanted to avoid. So in the end there was a new writer. I think it's in fact better this way as it helps keep SAX1 and SAX2 separated. =head1 METHODS =over 4 =item * new(%hash) This is the constructor for this object.  It takes a number of parameters, all of which are optional. =item -- Output This parameter can be one of several things.  If it is a simple scalar, it is interpreted as a filename which will be opened for writing.  If it is a scalar reference, output will be appended to this scalar.  If it is an array reference, output will be pushed onto this array as it is generated.  If it is a filehandle, then output will be sent to this filehandle. Finally, it is possible to pass an object for this parameter, in which case it is assumed to be an object that implements the consumer interface L. If this parameter is not provided, then output is sent to STDOUT. =item -- Escape This should be a hash reference where the keys are characters sequences that should be escaped and the values are the escaped form of the sequence.  By default, this module will escape the ampersand (&), less than (<), greater than (>), double quote ("), and apostrophe ('). Note that some browsers don't support the ' escape used for apostrophes so that you should be careful when outputting XHTML. If you only want to add entries to the Escape hash, you can first copy the contents of %XML::SAX::Writer::DEFAULT_ESCAPE. =item -- CommentEscape Comment content often needs to be escaped differently from other content. This option works exactly as the previous one except that by default it only escapes the double dash (--) and that the contents can be copied from %XML::SAX::Writer::COMMENT_ESCAPE. =item -- EncodeFrom The character set encoding in which incoming data will be provided. This defaults to UTF-8, which works for US-ASCII as well. =item -- EncodeTo The character set encoding in which output should be encoded.  Again, this defaults to UTF-8. =item -- QuoteCharacter Set the character used to quote attributes. This defaults to single quotes (') for backwards compatiblity. =back =head1 THE CONSUMER INTERFACE XML::SAX::Writer can receive pluggable consumer objects that will be in charge of writing out what is formatted by this module. Setting a Consumer is done by setting the Output option to the object of your choice instead of to an array, scalar, or file handle as is more commonly done (internally those in fact map to Consumer classes and and simply available as options for your convienience). If you don't understand this, don't worry. You don't need it most of the time. That object can be from any class, but must have two methods in its API. It is also strongly recommended that it inherits from XML::SAX::Writer::ConsumerInterface so that it will not break if that interface evolves over time. There are examples at the end of XML::SAX::Writer's code. The two methods that it needs to implement are: =over 4 =item * output STRING (Required) This is called whenever the Writer wants to output a string formatted in XML. Encoding conversion, character escaping, and formatting have already taken place. It's up to the consumer to do whatever it wants with the string. =item * finalize() (Optional) This is called once the document has been output in its entirety, during the end_document event. end_document will in fact return whatever finalize() returns, and that in turn should be returned by parse() for whatever parser was invoked. It might be useful if you need to provide feedback of some sort. =back Here's an example of a custom consumer. Note the extra C<$> signs in front of $self; the base class is optimized for the overwhelmingly common case where only one data member is required and $self is a reference to that data member. package MyConsumer; @ISA = qw( XML::SAX::Writer::ConsumerInterface ); use strict; sub new { my $self = shift->SUPER::new( my $output ); $$self = ''; # Note the extra '$' return $self; } sub output { my $self = shift; $$self .= uc shift; } sub get_output { my $self = shift; return $$self; } And here's one way to use it: my $c = MyConsumer->new; my $w = XML::SAX::Writer->new( Output => $c ); ## ... send events to $w ... print $c->get_output; If you need to store more that one data member, pass in an array or hash reference: my $self = shift->SUPER::new( {} ); and access it like: sub output { my $self = shift; $$self->{Output} .= uc shift; } =head1 THE ENCODER INTERFACE Encoders can be plugged in to allow one to use one's favourite encoder object. Presently there are two encoders: Iconv and NullEncoder, and one based on C ought to be out soon. They need to implement two methods, and may inherit from XML::SAX::Writer::NullConverter if they wish to =over 4 =item new FROM_ENCODING, TO_ENCODING Creates a new Encoder. The arguments are the chosen encodings. =item convert STRING Converts that string and returns it. =back =head1 CUSTOM OUTPUT This module is generally used to write XML -- which it does most of the time -- but just like the rest of SAX it can be used as a generic framework to output data, the opposite of a non-XML SAX parser. Of course there's only so much that one can abstract, so depending on your format this may or may not be useful. If it is, you'll need to know the followin API (and probably to have a look inside C, the default Writer). =over =item init Called before the writing starts, it's a chance for the subclass to do some initialisation if it needs it. =item setConverter This is used to set the proper converter for character encodings. The default implementation should suffice but you can override it. It must set C<$self->{Encoder}> to an Encoder object. Subclasses *should* call it. =item setConsumer Same as above, except that it is for the Consumer object, and that it must set C<$self->{Consumer}>. =item setEscaperRegex Will initialise the escaping regex C<$self->{EscaperRegex}> based on what is needed. =item escape STRING Takes a string and escapes it properly. =item setCommentEscaperRegex and escapeComment STRING These work exactly the same as the two above, except that they are meant to operate on comment contents, which often have different escaping rules than those that apply to regular content. =back =head1 TODO - proper UTF-16 handling - the formatting options need to be developed. - test, test, test (and then some tests) - doc, doc, doc (actually this part is in better shape) - remove the xml_decl and replace it with intelligent logic, as discussed on perl-xml - make a the Consumer selecting code available in the API, to avoid duplicating - add an Apache output Consumer, triggered by passing $r as Output =head1 CREDITS Michael Koehne (XML::Handler::YAWriter) for much inspiration and Barrie Slaymaker for the Consumer pattern idea, the coderef output option and miscellaneous bugfixes and performance tweaks. Of course the usual suspects (Kip Hampton and Matt Sergeant) helped in the usual ways. =head1 AUTHOR Robin Berjon, robin@knowscape.com =head1 COPYRIGHT Copyright (c) 2001-2006 Robin Berjon and Perl XML project. Some rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO XML::SAX::* =cut XML-SAX-Writer-0.53/lib/XML/SAX/Writer/XML.pm000755 000765 000024 00000043412 11111112063 021073 0ustar00perigrinstaff000000 000000 ### # XML::SAX::Writer - SAX2 XML Writer # Robin Berjon ### package XML::SAX::Writer::XML; use strict; use XML::NamespaceSupport qw(); @XML::SAX::Writer::XML::ISA = qw(XML::SAX::Writer); #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, The SAX Handler `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# #-------------------------------------------------------------------# # start_document #-------------------------------------------------------------------# sub start_document { my $self = shift; $self->setConverter; $self->setEscaperRegex; $self->setCommentEscaperRegex; $self->{NSDecl} = []; $self->{NSHelper} = XML::NamespaceSupport->new({ xmlns => 1, fatal_errors => 0 }); $self->{NSHelper}->pushContext; $self->setConsumer; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_document #-------------------------------------------------------------------# sub end_document { my $self = shift; # we may need to do a little more here $self->{NSHelper}->popContext; return $self->{Consumer}->finalize if $self->{Consumer}->can( 'finalize' ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # start_element #-------------------------------------------------------------------# sub start_element { my $self = shift; my $data = shift; $self->_output_element; my $attr = $data->{Attributes}; # fix the namespaces and prefixes of what we're receiving, in case # something is wrong if ($data->{NamespaceURI}) { my $uri = $self->{NSHelper}->getURI($data->{Prefix}) || ''; if ($uri ne $data->{NamespaceURI}) { # ns has precedence $data->{Prefix} = $self->{NSHelper}->getPrefix($data->{NamespaceURI}); # random, but correct $data->{Name} = $data->{Prefix} ? "$data->{Prefix}:$data->{LocalName}" : "$data->{LocalName}"; } } elsif ($data->{Prefix}) { # we can't have a prefix and no NS $data->{Name} = $data->{LocalName}; $data->{Prefix} = ''; } # create a hash containing the attributes so that we can ensure there is # no duplication. Also, we check that ns are properly declared, that the # Name is good, etc... my %attr_hash; for my $at (values %$attr) { next unless length $at->{Name}; # people have trouble with autovivification if ($at->{NamespaceURI}) { my $uri = $self->{NSHelper}->getURI($at->{Prefix}); warn "Well formed error: prefix '$at->{Prefix}' is not bound to any URI" unless defined $uri; if (defined $uri and $uri ne $at->{NamespaceURI}) { # ns has precedence $at->{Prefix} = $self->{NSHelper}->getPrefix($at->{NamespaceURI}); # random, but correct $at->{Name} = $at->{Prefix} ? "$at->{Prefix}:$at->{LocalName}" : "$at->{LocalName}"; } } elsif ($at->{Prefix}) { # we can't have a prefix and no NS $at->{Name} = $at->{LocalName}; $at->{Prefix} = ''; } $attr_hash{$at->{Name}} = $at->{Value}; } for my $nd (@{$self->{NSDecl}}) { if ($nd->{Prefix}) { $attr_hash{'xmlns:' . $nd->{Prefix}} = $nd->{NamespaceURI}; } else { $attr_hash{'xmlns'} = $nd->{NamespaceURI}; } } $self->{NSDecl} = []; # build a string from what we have, and buffer it my $el = '<' . $data->{Name}; for my $k (keys %attr_hash) { $el .= ' ' . $k . qq[=$self->{QuoteCharacter}] . $self->escape($attr_hash{$k}) . qq[$self->{QuoteCharacter}]; } $self->{BufferElement} = $el; $self->{NSHelper}->pushContext; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_element #-------------------------------------------------------------------# sub end_element { my $self = shift; my $data = shift; my $el; if ($self->{BufferElement}) { $el = $self->{BufferElement} . ' />'; } else { $el = '{Name} . '>'; } $el = $self->safeConvert($el); $self->{Consumer}->output($el); $self->{NSHelper}->popContext; $self->{BufferElement} = ''; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # characters #-------------------------------------------------------------------# sub characters { my $self = shift; my $data = shift; $self->_output_element; my $char = $data->{Data}; if ($self->{InCDATA}) { # we must scan for ]]> in the CDATA and escape it if it # is present by close--opening # we need to have buffer text in front of this... $char = join ']]>]]<', $char; } else { $char = $self->escape($char); } $char = $self->safeConvert($char); $self->{Consumer}->output($char); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # start_prefix_mapping #-------------------------------------------------------------------# sub start_prefix_mapping { my $self = shift; my $data = shift; push @{$self->{NSDecl}}, $data; $self->{NSHelper}->declarePrefix($data->{Prefix}, $data->{NamespaceURI}); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_prefix_mapping #-------------------------------------------------------------------# sub end_prefix_mapping {} #-------------------------------------------------------------------# #-------------------------------------------------------------------# # processing_instruction #-------------------------------------------------------------------# sub processing_instruction { my $self = shift; my $data = shift; $self->_output_element; $self->_output_dtd; my $pi = "{Target} $data->{Data}?>"; $pi = $self->safeConvert($pi); $self->{Consumer}->output($pi); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # ignorable_whitespace #-------------------------------------------------------------------# sub ignorable_whitespace { my $self = shift; my $data = shift; $self->_output_element; my $char = $data->{Data}; $char = $self->escape($char); $char = $self->safeConvert($char); $self->{Consumer}->output($char); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # skipped_entity #-------------------------------------------------------------------# sub skipped_entity { my $self = shift; my $data = shift; $self->_output_element; $self->_output_dtd; my $ent; if ($data->{Name} =~ m/^%/) { $ent = $data->{Name} . ';'; } elsif ($data->{Name} eq '[dtd]') { # ignoring } else { $ent = '&' . $data->{Name} . ';'; } $ent = $self->safeConvert($ent); $self->{Consumer}->output($ent); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # notation_decl #-------------------------------------------------------------------# sub notation_decl { my $self = shift; my $data = shift; $self->_output_dtd; # I think that param entities are normalized before this my $not = " {Name}; if ($data->{PublicId} and $data->{SystemId}) { $not .= ' PUBLIC \'' . $self->escape($data->{PublicId}) . '\' \'' . $self->escape($data->{SystemId}) . '\''; } elsif ($data->{PublicId}) { $not .= ' PUBLIC \'' . $self->escape($data->{PublicId}) . '\''; } else { $not .= ' SYSTEM \'' . $self->escape($data->{SystemId}) . '\''; } $not .= " >\n"; $not = $self->safeConvert($not); $self->{Consumer}->output($not); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # unparsed_entity_decl #-------------------------------------------------------------------# sub unparsed_entity_decl { my $self = shift; my $data = shift; $self->_output_dtd; # I think that param entities are normalized before this my $ent = " {Name}; if ($data->{PublicId}) { $ent .= ' PUBLIC \'' . $self->escape($data->{PublicId}) . '\' \'' . $self->escape($data->{SystemId}) . '\''; } else { $ent .= ' SYSTEM \'' . $self->escape($data->{SystemId}) . '\''; } $ent .= " NDATA $data->{Notation} >\n"; $ent = $self->safeConvert($ent); $self->{Consumer}->output($ent); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # element_decl #-------------------------------------------------------------------# sub element_decl { my $self = shift; my $data = shift; $self->_output_dtd; # I think that param entities are normalized before this my $eld = " {Name} . ' ' . $data->{Model} . " >\n"; $eld = $self->safeConvert($eld); $self->{Consumer}->output($eld); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # attribute_decl #-------------------------------------------------------------------# sub attribute_decl { my $self = shift; my $data = shift; $self->_output_dtd; # to be backward compatible with Perl SAX 2.0 $data->{Mode} = $data->{ValueDefault} if not(exists $data->{Mode}) and exists $data->{ValueDefault}; # I think that param entities are normalized before this my $atd = " {eName} . ' ' . $data->{aName} . ' '; $atd .= $data->{Type} . ' ' . $data->{Mode} . ' '; $atd .= $data->{Value} . ' ' if $data->{Value}; $atd .= " >\n"; $atd = $self->safeConvert($atd); $self->{Consumer}->output($atd); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # internal_entity_decl #-------------------------------------------------------------------# sub internal_entity_decl { my $self = shift; my $data = shift; $self->_output_dtd; # I think that param entities are normalized before this my $ent = " {Name} . ' \'' . $self->escape($data->{Value}) . "' >\n"; $ent = $self->safeConvert($ent); $self->{Consumer}->output($ent); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # external_entity_decl #-------------------------------------------------------------------# sub external_entity_decl { my $self = shift; my $data = shift; $self->_output_dtd; # I think that param entities are normalized before this my $ent = " {Name}; if ($data->{PublicId}) { $ent .= ' PUBLIC \'' . $self->escape($data->{PublicId}) . '\' \'' . $self->escape($data->{SystemId}) . '\''; } else { $ent .= ' SYSTEM \'' . $self->escape($data->{SystemId}) . '\''; } $ent .= " >\n"; $ent = $self->safeConvert($ent); $self->{Consumer}->output($ent); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # comment #-------------------------------------------------------------------# sub comment { my $self = shift; my $data = shift; $self->_output_element; $self->_output_dtd; my $cmt = ''; $cmt = $self->safeConvert($cmt); $self->{Consumer}->output($cmt); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # start_dtd #-------------------------------------------------------------------# sub start_dtd { my $self = shift; my $data = shift; my $dtd = '{Name}; if ($data->{PublicId}) { $dtd .= ' PUBLIC \'' . $self->escape($data->{PublicId}) . '\' \'' . $self->escape($data->{SystemId}) . '\''; } elsif ($data->{SystemId}) { $dtd .= ' SYSTEM \'' . $self->escape($data->{SystemId}) . '\''; } $self->{BufferDTD} = $dtd; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_dtd #-------------------------------------------------------------------# sub end_dtd { my $self = shift; my $data = shift; my $dtd; if ($self->{BufferDTD}) { $dtd = $self->{BufferDTD} . ' >'; } else { $dtd = ' ]>'; } $dtd = $self->safeConvert($dtd); $self->{Consumer}->output($dtd); $self->{BufferDTD} = ''; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # start_cdata #-------------------------------------------------------------------# sub start_cdata { my $self = shift; $self->_output_element; $self->{InCDATA} = 1; my $cds = $self->{Encoder}->convert('{Consumer}->output($cds); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_cdata #-------------------------------------------------------------------# sub end_cdata { my $self = shift; $self->{InCDATA} = 0; my $cds = $self->{Encoder}->convert(']]>'); $self->{Consumer}->output($cds); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # start_entity #-------------------------------------------------------------------# sub start_entity { my $self = shift; my $data = shift; $self->_output_element; $self->_output_dtd; my $ent; if ($data->{Name} eq '[dtd]') { # we ignore the fact that we're dealing with an external # DTD entity here, and prolly shouldn't write the DTD # events unless explicitly told to # this will prolly change } elsif ($data->{Name} =~ m/^%/) { $ent = $data->{Name} . ';'; } else { $ent = '&' . $data->{Name} . ';'; } $ent = $self->safeConvert($ent); $self->{Consumer}->output($ent); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # end_entity #-------------------------------------------------------------------# sub end_entity { # depending on what is done above, we might need to do sth here } #-------------------------------------------------------------------# ### SAX1 stuff ###################################################### #-------------------------------------------------------------------# # xml_decl #-------------------------------------------------------------------# sub xml_decl { my $self = shift; my $data = shift; # version info is compulsory, contrary to what some seem to think # also, there's order in the pseudo-attr my $xd = ''; if ($data->{Version}) { $xd .= "{Version}'"; if ($data->{Encoding}) { $xd .= " encoding='$data->{Encoding}'"; } if ($data->{Standalone}) { $xd .= " standalone='$data->{Standalone}'"; } $xd .= '?>'; } #$xd = $self->{Encoder}->convert($xd); # this may blow up $self->{Consumer}->output($xd); } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Helpers `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# #-------------------------------------------------------------------# # _output_element #-------------------------------------------------------------------# sub _output_element { my $self = shift; if ($self->{BufferElement}) { my $el = $self->{BufferElement} . '>'; $el = $self->safeConvert($el); $self->{Consumer}->output($el); $self->{BufferElement} = ''; } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _output_dtd #-------------------------------------------------------------------# sub _output_dtd { my $self = shift; if ($self->{BufferDTD}) { my $dtd = $self->{BufferDTD} . " [\n"; $dtd = $self->safeConvert($dtd); $self->{Consumer}->output($dtd); $self->{BufferDTD} = ''; } } #-------------------------------------------------------------------# 1; #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# =pod =head1 NAME XML::SAX::Writer::XML - SAX2 XML Writer =head1 SYNOPSIS ... =head1 DESCRIPTION ... =head1 AUTHOR Robin Berjon, robin@knowscape.com =head1 COPYRIGHT Copyright (c) 2001-2006 Robin Berjon nad Perl XML project. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO XML::SAX::* =cut XML-SAX-Writer-0.53/inc/Module/000755 000765 000024 00000000000 11416644002 016762 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/inc/Module/Install/000755 000765 000024 00000000000 11416644002 020370 5ustar00perigrinstaff000000 000000 XML-SAX-Writer-0.53/inc/Module/Install.pm000644 000765 000024 00000030135 11416643343 020737 0ustar00perigrinstaff000000 000000 #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.00'; # 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 - 2010 Adam Kennedy. XML-SAX-Writer-0.53/inc/Module/Install/AutoManifest.pm000644 000765 000024 00000001257 11416643343 023341 0ustar00perigrinstaff000000 000000 #line 1 use strict; use warnings; package Module::Install::AutoManifest; use Module::Install::Base; BEGIN { our $VERSION = '0.003'; our $ISCORE = 1; our @ISA = qw(Module::Install::Base); } sub auto_manifest { my ($self) = @_; return unless $Module::Install::AUTHOR; die "auto_manifest requested, but no MANIFEST.SKIP exists\n" unless -e "MANIFEST.SKIP"; if (-e "MANIFEST") { unlink('MANIFEST') or die "Can't remove MANIFEST: $!"; } $self->postamble(<<"END"); create_distdir: manifest_clean manifest distclean :: manifest_clean manifest_clean: \t\$(RM_F) MANIFEST END } 1; __END__ #line 48 #line 131 1; # End of Module::Install::AutoManifest XML-SAX-Writer-0.53/inc/Module/Install/Base.pm000644 000765 000024 00000002147 11416643343 021613 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # 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 XML-SAX-Writer-0.53/inc/Module/Install/Can.pm000644 000765 000024 00000003333 11416643343 021440 0ustar00perigrinstaff000000 000000 #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.00'; @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 XML-SAX-Writer-0.53/inc/Module/Install/Fetch.pm000644 000765 000024 00000004627 11416643343 021777 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; XML-SAX-Writer-0.53/inc/Module/Install/Makefile.pm000644 000765 000024 00000027032 11416643343 022456 0ustar00perigrinstaff000000 000000 #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.00'; @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 XML-SAX-Writer-0.53/inc/Module/Install/Metadata.pm000644 000765 000024 00000043020 11416643343 022454 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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' => '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<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://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; XML-SAX-Writer-0.53/inc/Module/Install/Repository.pm000644 000765 000024 00000004256 11416643343 023123 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 XML-SAX-Writer-0.53/inc/Module/Install/Win32.pm000644 000765 000024 00000003403 11416643343 021637 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; XML-SAX-Writer-0.53/inc/Module/Install/WriteAll.pm000644 000765 000024 00000002376 11416643343 022470 0ustar00perigrinstaff000000 000000 #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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;