# HG changeset patch # User Dario Sestito # Date 1267810611 0 # Node ID 5239d4d0bed15084b4b899f57a76ec664f8157fb # Parent 9ed73a51c728a30418cd72e62689f3f86fe3055d Take the UH parser from the utilities repo diff -r 9ed73a51c728 -r 5239d4d0bed1 common/build.postbuild.xml --- a/common/build.postbuild.xml Fri Mar 05 16:16:43 2010 +0000 +++ b/common/build.postbuild.xml Fri Mar 05 17:36:51 2010 +0000 @@ -390,7 +390,7 @@ - + @@ -399,7 +399,7 @@ - + diff -r 9ed73a51c728 -r 5239d4d0bed1 common/build.xml --- a/common/build.xml Fri Mar 05 16:16:43 2010 +0000 +++ b/common/build.xml Fri Mar 05 17:36:51 2010 +0000 @@ -219,7 +219,7 @@ - + @@ -299,6 +299,18 @@ + + + + + + + + + + + + diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorCommon.pm --- a/common/tools/raptor/RaptorCommon.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,41 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Common constants for the raptor parser suite - -package RaptorCommon; - -our $SEVERITY_CRITICAL = 'critical'; -our $SEVERITY_MAJOR = 'major'; -our $SEVERITY_MINOR = 'minor'; - -sub init -{ - my $filename = "$::raptorbitsdir/summary.csv"; - if (!-f$filename) - { - print "Writing summary file $filename\n"; - open(SUMMARY, ">$filename"); - close(SUMMARY); - } -} - -sub dump_fault -{ - my ($category, $subcategory, $severity, $location, $component, $mmp, $phase, $recipe, $file, $line) = @_; - - open(SUMMARY, ">>$::raptorbitsdir/summary.csv"); - print SUMMARY "$category,$subcategory,$severity,$location,$component,$mmp,$phase,$recipe,$file,$line\n"; - close(SUMMARY); -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorError.pm --- a/common/tools/raptor/RaptorError.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,170 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract, analyzes and dumps raptor errors i.e. content of tags from a raptor log file - -package RaptorError; - -use strict; -use RaptorCommon; - -our $reset_status = {}; -my $buildlog_status = {}; -my $buildlog_error_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {error=>$buildlog_error_status}; -$buildlog_status->{on_start} = 'RaptorError::on_start_buildlog'; - -$buildlog_error_status->{name} = 'buildlog_error_status'; -$buildlog_error_status->{next_status} = {}; -$buildlog_error_status->{on_start} = 'RaptorError::on_start_buildlog_error'; -$buildlog_error_status->{on_end} = 'RaptorError::on_end_buildlog_error'; -$buildlog_error_status->{on_chars} = 'RaptorError::on_chars_buildlog_error'; - -my $filename = ''; -my $failure_item = 0; - -my $characters = ''; - -my $CATEGORY_RAPTORERROR = 'raptor_error'; -my $CATEGORY_RAPTORERROR_CANNOTPROCESSSCHEMAVERSION = 'cannot_process_schema_version'; -my $CATEGORY_RAPTORERROR_NOBLDINFFOUND = 'no_bld_inf_found'; -my $CATEGORY_RAPTORERROR_CANTFINDMMPFILE = 'cant_find_mmp_file'; -my $CATEGORY_RAPTORERROR_MAKEEXITEDWITHERRORS = 'make_exited_with_errors'; -my $CATEGORY_RAPTORERROR_TOOLDIDNOTRETURNVERSION = 'tool_didnot_return_version'; -my $CATEGORY_RAPTORERROR_UNKNOWNBUILDCONFIG = 'unknown_build_config'; -my $CATEGORY_RAPTORERROR_NOBUILDCONFIGSGIVEN = 'no_build_configs_given'; - -sub process -{ - my ($text, $logfile, $component, $mmp, $phase, $recipe, $file, $line) = @_; - - my $category = $CATEGORY_RAPTORERROR; - my $severity = ''; - my $subcategory = ''; - - if ($text =~ m,Cannot process schema version .* of file,) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - $subcategory = $CATEGORY_RAPTORERROR_CANNOTPROCESSSCHEMAVERSION; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,No bld\.inf found at,) - { - $severity = $RaptorCommon::SEVERITY_MAJOR; - $subcategory = $CATEGORY_RAPTORERROR_NOBLDINFFOUND; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,Can't find mmp file,) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - $subcategory = $CATEGORY_RAPTORERROR_CANTFINDMMPFILE; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,The make-engine exited with errors,) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - $subcategory = $CATEGORY_RAPTORERROR_MAKEEXITEDWITHERRORS; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,tool .* from config .* did not return version .* as required,) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - $subcategory = $CATEGORY_RAPTORERROR_TOOLDIDNOTRETURNVERSION; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,Unknown build configuration '.*',) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - $subcategory = $CATEGORY_RAPTORERROR_UNKNOWNBUILDCONFIG; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,No build configurations given,) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - $subcategory = $CATEGORY_RAPTORERROR_NOBUILDCONFIGSGIVEN; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - else # log everything by default - { - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } -} - -sub on_start_buildlog -{ - RaptorCommon::init(); - - $filename = "$::raptorbitsdir/raptor_error.txt"; - if (!-f$filename) - { - print "Writing errors file $filename\n"; - open(FILE, ">$filename"); - close(FILE); - } -} - -sub on_start_buildlog_error -{ -} - -sub on_chars_buildlog_error -{ - my ($ch) = @_; - - #print "on_chars_buildlog_error\n"; - - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; -} - -sub on_end_buildlog_error -{ - #print "on_end_buildlog_error\n"; - - $characters =~ s,^[\r\n]*,,; - $characters =~ s,[\r\n]*$,,; - - if ($characters =~ m,[^\s^\r^\n],) - { - if ($failure_item == 0 and -f "$filename") - { - open(FILE, "$filename"); - { - local $/ = undef; - my $filecontent = ; - $failure_item = $1 if ($filecontent =~ m/.*---failure_item_(\d+)/s); - } - close(FILE); - } - - $failure_item++; - - open(FILE, ">>$filename"); - print FILE "---failure_item_$failure_item\---\n"; - print FILE "$characters\n\n"; - close(FILE); - - process($characters, $::current_log_file, '', '', '', '', "raptor_error.txt", $failure_item); - } - - $characters = ''; -} - - -1; \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorInfo.pm --- a/common/tools/raptor/RaptorInfo.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,89 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract, analyzes and dumps raptor info text i.e. content of tags from a raptor log file - -package RaptorInfo; - -use strict; -use RaptorCommon; - -our $reset_status = {}; -my $buildlog_status = {}; -my $buildlog_info_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {info=>$buildlog_info_status}; - -$buildlog_info_status->{name} = 'buildlog_info_status'; -$buildlog_info_status->{next_status} = {}; -$buildlog_info_status->{on_start} = 'RaptorInfo::on_start_buildlog_info'; -$buildlog_info_status->{on_end} = 'RaptorInfo::on_end_buildlog_info'; -$buildlog_info_status->{on_chars} = 'RaptorInfo::on_chars_buildlog_info'; - -my $characters = ''; - -my $category = $RaptorCommon::CATEGORY_RAPTORINFO; - -sub process -{ - my ($text) = @_; - - my $severity = ''; - - if ($text =~ m,unmatchable,) - { - $severity = $RaptorCommon::SEVERITY_CRITICAL; - - #dump_error($category, $severity, $text); - print "$category, $severity, $text\n"; - } -} - -sub on_start_buildlog_info -{ - my $filename = "$::raptorbitsdir/info.txt"; - print "Writing info file $filename\n" if (!-f$filename); - open(FILE, ">>$filename"); -} - -sub on_chars_buildlog_info -{ - my ($ch) = @_; - - #print "on_chars_buildlog_info\n"; - - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; -} - -sub on_end_buildlog_info -{ - #print "on_end_buildlog_info\n"; - - process($characters); - - print FILE $characters if ($characters =~ m,[^\s^\r^\n],); - print FILE "\n" if ($characters !~ m,[\r\n]$, ); - - $characters = ''; - - close(FILE); -} - - -1; \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorRecipe.pm --- a/common/tools/raptor/RaptorRecipe.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,279 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract, analyzes and dumps raptor recipes i.e. content of tags from a raptor log file - -package RaptorRecipe; - -use strict; -use RaptorCommon; - -our $reset_status = {}; -my $buildlog_status = {}; -my $buildlog_recipe_status = {}; -my $buildlog_recipe_status_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {recipe=>$buildlog_recipe_status}; -$buildlog_status->{on_start} = 'RaptorRecipe::on_start_buildlog'; -$buildlog_status->{on_end} = 'RaptorRecipe::on_end_buildlog'; - -$buildlog_recipe_status->{name} = 'buildlog_recipe_status'; -$buildlog_recipe_status->{next_status} = {status=>$buildlog_recipe_status_status}; -$buildlog_recipe_status->{on_start} = 'RaptorRecipe::on_start_buildlog_recipe'; -$buildlog_recipe_status->{on_end} = 'RaptorRecipe::on_end_buildlog_recipe'; -$buildlog_recipe_status->{on_chars} = 'RaptorRecipe::on_chars_buildlog_recipe'; - -$buildlog_recipe_status_status->{name} = 'buildlog_recipe_status_status'; -$buildlog_recipe_status_status->{next_status} = {}; -$buildlog_recipe_status_status->{on_start} = 'RaptorRecipe::on_start_buildlog_recipe_status'; - - -my $filename = ''; -my $failure_item = 0; - -my $recipe_info = {}; - -my $characters = ''; - -my $CATEGORY_RECIPEFAILURE = 'recipe_failure'; -my $CATEGORY_RECIPEFAILURE_ARMCC_CANNOTOPENSOURCEINPUTFILE = 'armcc_cannot_open_source_input_file'; -my $CATEGORY_RECIPEFAILURE_ARMLINK_COULDNOTOPENFILE = 'armlink_could_not_open_file'; -my $CATEGORY_RECIPEFAILURE_ELF2E32_COULDNOTOPENFILE = 'elf2e32_could_not_open_file'; -my $CATEGORY_RECIPEFAILURE_ARMAR_FILEDOESNOTEXIST = 'armar_file_does_not_exist'; -my $CATEGORY_RECIPEFAILURE_ARMCC_CONTROLLINGEXPRESSIONISCONSTANT = 'armcc_controlling_expression_is_constant'; -my $CATEGORY_RECIPEFAILURE_ARMCC_INTERNALFAULT = 'armcc_internal_fault'; -my $CATEGORY_RECIPEFAILURE_ARMCC_MODIFIERNOTALLOWED = 'armcc_modifier_not_allowed'; -my $CATEGORY_RECIPEFAILURE_ARMCC_GENERICWARNINGSERRORS = 'armcc_generic_warnings_errors'; -my $CATEGORY_RECIPEFAILURE_ELF2E32_SYMBOLMISSINGFROMELFFILE = 'elf2e32_symbol_missing_from_elf_file'; -my $CATEGORY_RECIPEFAILURE_MWCCSYM2_FILECANNOTBEOPENED = 'mwccsym2_file_cannot_be_opened'; - -my $mmp_with_issues = {}; - - -sub process -{ - my ($text, $config, $component, $mmp, $phase, $recipe, $file, $line) = @_; - - my $category = $CATEGORY_RECIPEFAILURE; - my $severity = ''; - my $subcategory = ''; - - # if mmp is defined assign severity=MAJOR for the first failure - # then severity=MINOR to all other (for each logfile) - if ($mmp and defined $mmp_with_issues->{$::current_log_file}->{$mmp}) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - } - elsif ($mmp) - { - $mmp_with_issues->{$::current_log_file} = {} if (!defined $mmp_with_issues->{$::current_log_file}); - $mmp_with_issues->{$::current_log_file}->{$mmp} = 1; - $severity = $RaptorCommon::SEVERITY_MAJOR; - } - else - { - $severity = $RaptorCommon::SEVERITY_MAJOR; - } - - - if ($text =~ m,Error: #5: cannot open source input file .*: No such file or directory,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMCC_CANNOTOPENSOURCEINPUTFILE; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,Fatal error: L6002U: Could not open file .*: No such file or directory,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMLINK_COULDNOTOPENFILE; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,elf2e32 : Error: E1001: Could not open file : .*.,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ELF2E32_COULDNOTOPENFILE; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,elf2e32 : Error: E1036: Symbol .* Missing from ELF File,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ELF2E32_SYMBOLMISSINGFROMELFFILE; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,Error: L6833E: File '.*' does not exist,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMAR_FILEDOESNOTEXIST; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,: Warning: #236-D: controlling expression is constant,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMCC_CONTROLLINGEXPRESSIONISCONSTANT; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,/armcc.exe , and $text =~ m,Internal fault: ,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMCC_INTERNALFAULT; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,/armcc.exe , and $text =~ m,Error: #655-D: the modifier ".*" is not allowed on this declaration,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMCC_MODIFIERNOTALLOWED; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - # the following captures generic armcc error/warnings, not captured by regexps above - elsif ($text =~ m,/armcc.exe , and $text =~ m,: \d+ warnings\, \d+ errors$,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_ARMCC_GENERICWARNINGSERRORS; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,mwccsym2.exe , and $text =~ m,: the file '.*' cannot be opened,) - { - my $subcategory = $CATEGORY_RECIPEFAILURE_MWCCSYM2_FILECANNOTBEOPENED; - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } - else # log everything by default - { - RaptorCommon::dump_fault($category, $subcategory, $severity, $config, $component, $mmp, $phase, $recipe, $file, $line); - } -} - -sub on_start_buildlog -{ - #print FILE "line,layer,component,name,armlicence,platform,phase,code,bldinf,mmp,target,source,\n"; - - RaptorCommon::init(); -} - -sub on_start_buildlog_recipe -{ - my ($el) = @_; - - #print "on_start_buildlog_recipe\n"; - - $recipe_info = {}; - - my $attributes = $el->{Attributes}; - for (keys %{$attributes}) - { - $recipe_info->{$attributes->{$_}->{'LocalName'}} = $attributes->{$_}->{'Value'}; - #print "$_ -> $attributes->{$_}->{'Value'}\n"; - } -} - -sub on_chars_buildlog_recipe -{ - my ($ch) = @_; - - #print "on_chars_buildlog_recipe\n"; - - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; -} - -sub on_start_buildlog_recipe_status -{ - my ($el) = @_; - - my $attributes = $el->{Attributes}; - for (keys %{$attributes}) - { - if ($attributes->{$_}->{'LocalName'} eq 'code') - { - $recipe_info->{$attributes->{$_}->{'LocalName'}} = $attributes->{$_}->{'Value'}; - } - elsif ($attributes->{$_}->{'LocalName'} eq 'exit') - { - $recipe_info->{$attributes->{$_}->{'LocalName'}} = $attributes->{$_}->{'Value'}; - } - elsif ($attributes->{$_}->{'LocalName'} eq 'attempt') - { - $recipe_info->{$attributes->{$_}->{'LocalName'}} = $attributes->{$_}->{'Value'}; - } - } -} - -sub on_end_buildlog_recipe -{ - $::allbldinfs->{$recipe_info->{bldinf}} = 1; - - if ($recipe_info->{exit} =~ /failed/) - { - # normalize bldinf path - $recipe_info->{bldinf} = lc($recipe_info->{bldinf}); - $recipe_info->{bldinf} =~ s,^[A-Za-z]:,,; - $recipe_info->{bldinf} =~ s,[\\],/,g; - - my $package = ''; - if ($recipe_info->{bldinf} =~ m,/((os|mw|app|tools|ostools|adaptation)/[^/]*),) - { - $package = $1; - $package =~ s,/,_,; - } - else - { - print "WARNING: can't understand bldinf attribute of recipe: $recipe_info->{bldinf}. Won't dump to failed recipes file.\n"; - } - - # also normalize mmp path if this exists - if ($recipe_info->{mmp}) - { - $recipe_info->{mmp} = lc($recipe_info->{mmp}); - $recipe_info->{mmp} =~ s,^[A-Za-z]:,,; - $recipe_info->{mmp} =~ s,[\\],/,g; - } - - $characters =~ s,^[\r\n]*,,; - $characters =~ s,[\r\n]*$,,; - - if ($package) - { - $filename = "$::raptorbitsdir/$package.txt"; - if (!-f$filename) - { - print "Writing recipe file $filename\n"; - open(FILE, ">$filename"); - close(FILE); - } - - if ($failure_item == 0 and -f "$filename") - { - open(FILE, "$filename"); - { - local $/ = undef; - my $filecontent = ; - $failure_item = $1 if ($filecontent =~ m/.*---failure_item_(\d+)/s); - } - close(FILE); - } - - $failure_item++; - - open(FILE, ">>$filename"); - print FILE "---failure_item_$failure_item\---\n"; - print FILE "$characters\n\n"; - close(FILE); - } - - process($characters, $recipe_info->{config}, $recipe_info->{bldinf}, $recipe_info->{mmp}, $recipe_info->{phase}, $recipe_info->{name}, "$package.txt", $failure_item); - } - - $characters = ''; -} - -sub on_end_buildlog -{ -} - - -1; \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorSAXHandler.pm --- a/common/tools/raptor/RaptorSAXHandler.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,108 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# SAX Handler for the Raptor log - -package RaptorSAXHandler; -use base qw(XML::SAX::Base); - -sub new -{ - my ($type) = @_; - - return bless {}, $type; -} - -sub add_observer -{ - my ($self, $name, $initialstatus) = @_; - - $self->{observers} = {} if (!defined $self->{observers}); - - $self->{observers}->{$name} = $initialstatus; -} - -sub start_document -{ - my ($self, $doc) = @_; - # process document start event - - #print "start_document\n"; -} - -sub start_element -{ - my ($self, $el) = @_; - # process element start event - - my $tagname = $el->{LocalName}; - - #print "start_element($tagname)\n"; - - for my $observer (keys %{$self->{observers}}) - { - #print "processing observer $observer: $self->{observers}->{$observer} $self->{observers}->{$observer}->{name}\n"; - #for (keys %{$self->{observers}->{$observer}->{next_status}}) {print "$_\n";} - - if (defined $self->{observers}->{$observer}->{next_status}->{$tagname}) - { - #print "processing observer $observer\n"; - my $oldstatus = $self->{observers}->{$observer}; - $self->{observers}->{$observer} = $self->{observers}->{$observer}->{next_status}->{$tagname}; - #print "$observer: status is now $self->{observers}->{$observer}->{name}\n"; - $self->{observers}->{$observer}->{next_status}->{$tagname} = $oldstatus; - &{$self->{observers}->{$observer}->{on_start}}($el) if (defined $self->{observers}->{$observer}->{on_start}); - } - elsif (defined $self->{observers}->{$observer}->{next_status}->{'?default?'}) - { - #print "processing observer $observer\n"; - #print "changing to default status\n"; - my $oldstatus = $self->{observers}->{$observer}; - $self->{observers}->{$observer} = $self->{observers}->{$observer}->{next_status}->{'?default?'}; - #print "status is now ?default?\n"; - $self->{observers}->{$observer}->{next_status}->{$tagname} = $oldstatus; - &{$self->{observers}->{$observer}->{on_start}}($el) if (defined $self->{observers}->{$observer}->{on_start}); - } - } -} - -sub end_element -{ - my ($self, $el) = @_; - # process element start event - - my $tagname = $el->{LocalName}; - - #print "end_element($tagname)\n"; - - for my $observer (keys %{$self->{observers}}) - { - if (defined $self->{observers}->{$observer}->{next_status}->{$tagname}) - { - &{$self->{observers}->{$observer}->{on_end}}($el) if (defined $self->{observers}->{$observer}->{on_end}); - $self->{observers}->{$observer} = $self->{observers}->{$observer}->{next_status}->{$tagname}; - #print "status is now $self->{observers}->{$observer}->{name}\n"; - } - } -} - -sub characters -{ - my ($self, $ch) = @_; - - for my $observer (keys %{$self->{observers}}) - { - &{$self->{observers}->{$observer}->{on_chars}}($ch) if (defined $self->{observers}->{$observer}->{on_chars}); - } -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorUnreciped.pm --- a/common/tools/raptor/RaptorUnreciped.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract, analyzes and dumps text in context which doesn't belong to any tags - -package RaptorUnreciped; - -use strict; -use RaptorCommon; - -our $reset_status = {}; -my $buildlog_status = {}; -my $buildlog_subtag_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {'?default?'=>$buildlog_subtag_status}; -$buildlog_status->{on_start} = 'RaptorUnreciped::on_start_buildlog'; -$buildlog_status->{on_end} = 'RaptorUnreciped::on_end_buildlog'; -$buildlog_status->{on_chars} = 'RaptorUnreciped::on_chars_buildlog'; - -$buildlog_subtag_status->{name} = 'buildlog_subtag_status'; -$buildlog_subtag_status->{next_status} = {}; -$buildlog_subtag_status->{on_start} = 'RaptorUnreciped::on_start_buildlog_subtag'; -$buildlog_subtag_status->{on_end} = 'RaptorUnreciped::on_end_buildlog_subtag'; - -my $filename = ''; -my $failure_item = 0; - -my $characters = ''; -my $store_chars = 1; - -my $CATEGORY_RAPTORUNRECIPED = 'raptor_unreciped'; -my $CATEGORY_RAPTORUNRECIPED_NORULETOMAKETARGET = 'no_rule_to_make_target'; -my $CATEGORY_RAPTORUNRECIPED_TARGETNOTREMADEFORERRORS = 'target_not_remade_for_errors'; -my $CATEGORY_RAPTORUNRECIPED_IGNORINGOLDCOMMANDSFORTARGET = 'ignoring_old_commands_for_target'; -my $CATEGORY_RAPTORUNRECIPED_OVERRIDINGCOMMANDSFORTARGET = 'overriding_commands_for_target'; - -sub process -{ - my ($text, $logfile, $component, $mmp, $phase, $recipe, $file, $line) = @_; - - my $category = $CATEGORY_RAPTORUNRECIPED; - my $severity = ''; - my $subcategory = ''; - - if ($text =~ m,make\.exe: \*\*\* No rule to make target,) - { - $severity = $RaptorCommon::SEVERITY_MAJOR; - my $subcategory = $CATEGORY_RAPTORUNRECIPED_NORULETOMAKETARGET; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,make\.exe: Target .* not remade because of errors,) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - my $subcategory = $CATEGORY_RAPTORUNRECIPED_TARGETNOTREMADEFORERRORS; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,: warning: ignoring old commands for target,) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - my $subcategory = $CATEGORY_RAPTORUNRECIPED_IGNORINGOLDCOMMANDSFORTARGET; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,: warning: overriding commands for target,) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - my $subcategory = $CATEGORY_RAPTORUNRECIPED_OVERRIDINGCOMMANDSFORTARGET; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - elsif ($text =~ m,make\.exe: Nothing to be done for .*,) - { - # don't dump - } - elsif ($text =~ m,^(true|false)$,) - { - # don't dump - } - else # log everything by default - { - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } -} - -sub on_start_buildlog -{ - RaptorCommon::init(); - - $filename = "$::raptorbitsdir/raptor_unreciped.txt"; - if (!-f$filename) - { - print "Writing unreciped file $filename\n"; - open(FILE, ">$filename"); - close(FILE); - } -} - -sub on_chars_buildlog -{ - my ($ch) = @_; - - #print "on_chars_buildlog\n"; - - if ($store_chars) - { - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; - } -} - -sub on_end_buildlog_subtag -{ - $store_chars = 1; -} - -sub process_characters -{ - #print "process_characters\n"; - - $characters =~ s,^[\r\n]*,,; - $characters =~ s,[\r\n]*$,,; - - #print "characters is -->$characters<--\n"; - - my @lines = split(/[\r\n]/, $characters); - for my $line (@lines) - { - if ($line =~ m,[^\s^\r^\n],) - { - #print "dumping chars\n"; - - if ($failure_item == 0 and -f "$filename") - { - open(FILE, "$filename"); - { - local $/ = undef; - my $filecontent = ; - $failure_item = $1 if ($filecontent =~ m/.*---failure_item_(\d+)/s); - } - close(FILE); - } - - $failure_item++; - - open(FILE, ">>$filename"); - print FILE "---failure_item_$failure_item\---\n"; - print FILE "$line\n\n"; - close(FILE); - - process($line, $::current_log_file, '', '', '', '', "raptor_unreciped.txt", $failure_item); - } - } - - $characters = ''; - $store_chars = 0; -} - -sub on_start_buildlog_subtag -{ - #print "on_start_buildlog_subtag\n"; - - process_characters(); -} - -sub on_end_buildlog -{ - process_characters(); -} - - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/RaptorWarning.pm --- a/common/tools/raptor/RaptorWarning.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract, analyzes and dumps raptor warnings i.e. content of tags from a raptor log file - -package RaptorWarning; - -use strict; -use RaptorCommon; - -our $reset_status = {}; -my $buildlog_status = {}; -my $buildlog_warning_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {warning=>$buildlog_warning_status}; -$buildlog_status->{on_start} = 'RaptorWarning::on_start_buildlog'; - -$buildlog_warning_status->{name} = 'buildlog_warning_status'; -$buildlog_warning_status->{next_status} = {}; -$buildlog_warning_status->{on_start} = 'RaptorWarning::on_start_buildlog_warning'; -$buildlog_warning_status->{on_end} = 'RaptorWarning::on_end_buildlog_warning'; -$buildlog_warning_status->{on_chars} = 'RaptorWarning::on_chars_buildlog_warning'; - -my $filename = ''; -my $failure_item = 0; - -my $characters = ''; - -my $CATEGORY_RAPTORWARNING = 'raptor_warning'; -my $CATEGORY_RAPTORWARNING_MISSINGFLAGABIV2 = 'missing_enable_abiv2_mode'; - -sub process -{ - my ($text, $logfile, $component, $mmp, $phase, $recipe, $file, $line) = @_; - - my $category = $CATEGORY_RAPTORWARNING; - my $severity = ''; - my $subcategory = ''; - - if ($text =~ m,missing flag ENABLE_ABIV2_MODE,) - { - $severity = $RaptorCommon::SEVERITY_MINOR; - my $subcategory = $CATEGORY_RAPTORWARNING_MISSINGFLAGABIV2; - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } - else # log everything by default - { - RaptorCommon::dump_fault($category, $subcategory, $severity, $logfile, $component, $mmp, $phase, $recipe, $file, $line); - } -} - -sub on_start_buildlog -{ - RaptorCommon::init(); - - $filename = "$::raptorbitsdir/raptor_warning.txt"; - if (!-f$filename) - { - print "Writing warnings file $filename\n"; - open(FILE, ">$filename"); - close(FILE); - } -} -sub on_start_buildlog_warning -{ - open(FILE, ">>$filename"); -} - -sub on_chars_buildlog_warning -{ - my ($ch) = @_; - - #print "on_chars_buildlog_warning\n"; - - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; -} - -sub on_end_buildlog_warning -{ - #print "on_end_buildlog_warning\n"; - - $characters =~ s,^[\r\n]*,,; - $characters =~ s,[\r\n]*$,,; - - if ($characters =~ m,[^\s^\r^\n],) - { - if ($failure_item == 0 and -f "$filename") - { - open(FILE, "$filename"); - { - local $/ = undef; - my $filecontent = ; - $failure_item = $1 if ($filecontent =~ m/.*---failure_item_(\d+)/s); - } - close(FILE); - } - - $failure_item++; - - open(FILE, ">>$filename"); - print FILE "---failure_item_$failure_item\---\n"; - print FILE "$characters\n\n"; - close(FILE); - - process($characters, $::current_log_file, '', '', '', '', "raptor_warning.txt", $failure_item); - } - - $characters = ''; -} - - -1; \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/NamespaceSupport.pm --- a/common/tools/raptor/XML/NamespaceSupport.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,565 +0,0 @@ - -### -# XML::NamespaceSupport - a simple generic namespace processor -# Robin Berjon -### - -package XML::NamespaceSupport; -use strict; -use constant FATALS => 0; # root object -use constant NSMAP => 1; -use constant UNKNOWN_PREF => 2; -use constant AUTO_PREFIX => 3; -use constant DEFAULT => 0; # maps -use constant PREFIX_MAP => 1; -use constant DECLARATIONS => 2; - -use vars qw($VERSION $NS_XMLNS $NS_XML); -$VERSION = '1.07'; -$NS_XMLNS = 'http://www.w3.org/2000/xmlns/'; -$NS_XML = 'http://www.w3.org/XML/1998/namespace'; - - -# add the ns stuff that baud wants based on Java's xml-writer - - -#-------------------------------------------------------------------# -# constructor -#-------------------------------------------------------------------# -sub new { - my $class = ref($_[0]) ? ref(shift) : shift; - my $options = shift; - my $self = [ - 1, # FATALS - [[ # NSMAP - undef, # DEFAULT - { xml => $NS_XML }, # PREFIX_MAP - undef, # DECLARATIONS - ]], - 'aaa', # UNKNOWN_PREF - 0, # AUTO_PREFIX - ]; - $self->[NSMAP]->[0]->[PREFIX_MAP]->{xmlns} = $NS_XMLNS if $options->{xmlns}; - $self->[FATALS] = $options->{fatal_errors} if defined $options->{fatal_errors}; - $self->[AUTO_PREFIX] = $options->{auto_prefix} if defined $options->{auto_prefix}; - return bless $self, $class; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# reset() - return to the original state (for reuse) -#-------------------------------------------------------------------# -sub reset { - my $self = shift; - $#{$self->[NSMAP]} = 0; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# push_context() - add a new empty context to the stack -#-------------------------------------------------------------------# -sub push_context { - my $self = shift; - push @{$self->[NSMAP]}, [ - $self->[NSMAP]->[-1]->[DEFAULT], - { %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} }, - [], - ]; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# pop_context() - remove the topmost context fromt the stack -#-------------------------------------------------------------------# -sub pop_context { - my $self = shift; - die 'Trying to pop context without push context' unless @{$self->[NSMAP]} > 1; - pop @{$self->[NSMAP]}; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# declare_prefix() - declare a prefix in the current scope -#-------------------------------------------------------------------# -sub declare_prefix { - my $self = shift; - my $prefix = shift; - my $value = shift; - - warn <<' EOWARN' unless defined $prefix or $self->[AUTO_PREFIX]; - Prefix was undefined. - If you wish to set the default namespace, use the empty string ''. - If you wish to autogenerate prefixes, set the auto_prefix option - to a true value. - EOWARN - - return 0 if index(lc($prefix), 'xml') == 0; - - if (defined $prefix and $prefix eq '') { - $self->[NSMAP]->[-1]->[DEFAULT] = $value; - } - else { - die "Cannot undeclare prefix $prefix" if $value eq ''; - if (not defined $prefix and $self->[AUTO_PREFIX]) { - while (1) { - $prefix = $self->[UNKNOWN_PREF]++; - last if not exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; - } - } - elsif (not defined $prefix and not $self->[AUTO_PREFIX]) { - return 0; - } - $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} = $value; - } - push @{$self->[NSMAP]->[-1]->[DECLARATIONS]}, $prefix; - return 1; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# declare_prefixes() - declare several prefixes in the current scope -#-------------------------------------------------------------------# -sub declare_prefixes { - my $self = shift; - my %prefixes = @_; - while (my ($k,$v) = each %prefixes) { - $self->declare_prefix($k,$v); - } -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# undeclare_prefix -#-------------------------------------------------------------------# -sub undeclare_prefix { - my $self = shift; - my $prefix = shift; - return unless not defined $prefix or $prefix eq ''; - return unless exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; - - my ( $tfix ) = grep { $_ eq $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]}; - if ( not defined $tfix ) { - die "prefix $prefix not declared in this context\n"; - } - - @{$self->[NSMAP]->[-1]->[DECLARATIONS]} = grep { $_ ne $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]}; - delete $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_prefix() - get a (random) prefix for a given URI -#-------------------------------------------------------------------# -sub get_prefix { - my $self = shift; - my $uri = shift; - - # we have to iterate over the whole hash here because if we don't - # the iterator isn't reset and the next pass will fail - my $pref; - while (my ($k, $v) = each %{$self->[NSMAP]->[-1]->[PREFIX_MAP]}) { - $pref = $k if $v eq $uri; - } - return $pref; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_prefixes() - get all the prefixes for a given URI -#-------------------------------------------------------------------# -sub get_prefixes { - my $self = shift; - my $uri = shift; - - return keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} unless defined $uri; - return grep { $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$_} eq $uri } keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]}; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_declared_prefixes() - get all prefixes declared in the last context -#-------------------------------------------------------------------# -sub get_declared_prefixes { - return @{$_[0]->[NSMAP]->[-1]->[DECLARATIONS]}; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_uri() - get an URI given a prefix -#-------------------------------------------------------------------# -sub get_uri { - my $self = shift; - my $prefix = shift; - - warn "Prefix must not be undef in get_uri(). The emtpy prefix must be ''" unless defined $prefix; - - return $self->[NSMAP]->[-1]->[DEFAULT] if $prefix eq ''; - return $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} if exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; - return undef; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# process_name() - provide details on a name -#-------------------------------------------------------------------# -sub process_name { - my $self = shift; - my $qname = shift; - my $aflag = shift; - - if ($self->[FATALS]) { - return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname ); - } - else { - eval { return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname ); } - } -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# process_element_name() - provide details on a element's name -#-------------------------------------------------------------------# -sub process_element_name { - my $self = shift; - my $qname = shift; - - if ($self->[FATALS]) { - return $self->_get_ns_details($qname, 0); - } - else { - eval { return $self->_get_ns_details($qname, 0); } - } -} -#-------------------------------------------------------------------# - - -#-------------------------------------------------------------------# -# process_attribute_name() - provide details on a attribute's name -#-------------------------------------------------------------------# -sub process_attribute_name { - my $self = shift; - my $qname = shift; - - if ($self->[FATALS]) { - return $self->_get_ns_details($qname, 1); - } - else { - eval { return $self->_get_ns_details($qname, 1); } - } -} -#-------------------------------------------------------------------# - - -#-------------------------------------------------------------------# -# ($ns, $prefix, $lname) = $self->_get_ns_details($qname, $f_attr) -# returns ns, prefix, and lname for a given attribute name -# >> the $f_attr flag, if set to one, will work for an attribute -#-------------------------------------------------------------------# -sub _get_ns_details { - my $self = shift; - my $qname = shift; - my $aflag = shift; - - my ($ns, $prefix, $lname); - (my ($tmp_prefix, $tmp_lname) = split /:/, $qname, 3) - < 3 or die "Invalid QName: $qname"; - - # no prefix - my $cur_map = $self->[NSMAP]->[-1]; - if (not defined($tmp_lname)) { - $prefix = undef; - $lname = $qname; - # attr don't have a default namespace - $ns = ($aflag) ? undef : $cur_map->[DEFAULT]; - } - - # prefix - else { - if (exists $cur_map->[PREFIX_MAP]->{$tmp_prefix}) { - $prefix = $tmp_prefix; - $lname = $tmp_lname; - $ns = $cur_map->[PREFIX_MAP]->{$prefix} - } - else { # no ns -> lname == name, all rest undef - die "Undeclared prefix: $tmp_prefix"; - } - } - - return ($ns, $prefix, $lname); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# parse_jclark_notation() - parse the Clarkian notation -#-------------------------------------------------------------------# -sub parse_jclark_notation { - shift; - my $jc = shift; - $jc =~ m/^\{(.*)\}([^}]+)$/; - return $1, $2; -} -#-------------------------------------------------------------------# - - -#-------------------------------------------------------------------# -# Java names mapping -#-------------------------------------------------------------------# -*XML::NamespaceSupport::pushContext = \&push_context; -*XML::NamespaceSupport::popContext = \&pop_context; -*XML::NamespaceSupport::declarePrefix = \&declare_prefix; -*XML::NamespaceSupport::declarePrefixes = \&declare_prefixes; -*XML::NamespaceSupport::getPrefix = \&get_prefix; -*XML::NamespaceSupport::getPrefixes = \&get_prefixes; -*XML::NamespaceSupport::getDeclaredPrefixes = \&get_declared_prefixes; -*XML::NamespaceSupport::getURI = \&get_uri; -*XML::NamespaceSupport::processName = \&process_name; -*XML::NamespaceSupport::processElementName = \&process_element_name; -*XML::NamespaceSupport::processAttributeName = \&process_attribute_name; -*XML::NamespaceSupport::parseJClarkNotation = \&parse_jclark_notation; -*XML::NamespaceSupport::undeclarePrefix = \&undeclare_prefix; -#-------------------------------------------------------------------# - - -1; -#,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# -#`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# -#```````````````````````````````````````````````````````````````````# - -=pod - -=head1 NAME - -XML::NamespaceSupport - a simple generic namespace support class - -=head1 SYNOPSIS - - use XML::NamespaceSupport; - my $nsup = XML::NamespaceSupport->new; - - # add a new empty context - $nsup->push_context; - # declare a few prefixes - $nsup->declare_prefix($prefix1, $uri1); - $nsup->declare_prefix($prefix2, $uri2); - # the same shorter - $nsup->declare_prefixes($prefix1 => $uri1, $prefix2 => $uri2); - - # get a single prefix for a URI (randomly) - $prefix = $nsup->get_prefix($uri); - # get all prefixes for a URI (probably better) - @prefixes = $nsup->get_prefixes($uri); - # get all prefixes in scope - @prefixes = $nsup->get_prefixes(); - # get all prefixes that were declared for the current scope - @prefixes = $nsup->get_declared_prefixes; - # get a URI for a given prefix - $uri = $nsup->get_uri($prefix); - - # get info on a qname (java-ish way, it's a bit weird) - ($ns_uri, $local_name, $qname) = $nsup->process_name($qname, $is_attr); - # the same, more perlish - ($ns_uri, $prefix, $local_name) = $nsup->process_element_name($qname); - ($ns_uri, $prefix, $local_name) = $nsup->process_attribute_name($qname); - - # remove the current context - $nsup->pop_context; - - # reset the object for reuse in another document - $nsup->reset; - - # a simple helper to process Clarkian Notation - my ($ns, $lname) = $nsup->parse_jclark_notation('{http://foo}bar'); - # or (given that it doesn't care about the object - my ($ns, $lname) = XML::NamespaceSupport->parse_jclark_notation('{http://foo}bar'); - - -=head1 DESCRIPTION - -This module offers a simple to process namespaced XML names (unames) -from within any application that may need them. It also helps maintain -a prefix to namespace URI map, and provides a number of basic checks. - -The model for this module is SAX2's NamespaceSupport class, readable at -http://www.megginson.com/SAX/Java/javadoc/org/xml/sax/helpers/NamespaceSupport.html. -It adds a few perlisations where we thought it appropriate. - -=head1 METHODS - -=over 4 - -=item * XML::NamespaceSupport->new(\%options) - -A simple constructor. - -The options are C, C, and C - -If C is turned on (it is off by default) the mapping from the -xmlns prefix to the URI defined for it in DOM level 2 is added to the -list of predefined mappings (which normally only contains the xml -prefix mapping). - -If C is turned off (it is on by default) a number of -validity errors will simply be flagged as failures, instead of -die()ing. - -If C is turned on (it is off by default) when one -provides a prefix of C to C it will generate a -random prefix mapped to that namespace. Otherwise an undef prefix will -trigger a warning (you should probably know what you're doing if you -turn this option on). - -=item * $nsup->push_context - -Adds a new empty context to the stack. You can then populate it with -new prefixes defined at this level. - -=item * $nsup->pop_context - -Removes the topmost context in the stack and reverts to the previous -one. It will die() if you try to pop more than you have pushed. - -=item * $nsup->declare_prefix($prefix, $uri) - -Declares a mapping of $prefix to $uri, at the current level. - -Note that with C turned on, if you declare a prefix -mapping in which $prefix is undef(), you will get an automatic prefix -selected for you. If it is off you will get a warning. - -This is useful when you deal with code that hasn't kept prefixes around -and need to reserialize the nodes. It also means that if you want to -set the default namespace (ie with an empty prefix) you must use the -empty string instead of undef. This behaviour is consistent with the -SAX 2.0 specification. - -=item * $nsup->declare_prefixes(%prefixes2uris) - -Declares a mapping of several prefixes to URIs, at the current level. - -=item * $nsup->get_prefix($uri) - -Returns a prefix given an URI. Note that as several prefixes may be -mapped to the same URI, it returns an arbitrary one. It'll return -undef on failure. - -=item * $nsup->get_prefixes($uri) - -Returns an array of prefixes given an URI. It'll return all the -prefixes if the uri is undef. - -=item * $nsup->get_declared_prefixes - -Returns an array of all the prefixes that have been declared within -this context, ie those that were declared on the last element, not -those that were declared above and are simply in scope. - -=item * $nsup->get_uri($prefix) - -Returns a URI for a given prefix. Returns undef on failure. - -=item * $nsup->process_name($qname, $is_attr) - -Given a qualified name and a boolean indicating whether this is an -attribute or another type of name (those are differently affected by -default namespaces), it returns a namespace URI, local name, qualified -name tuple. I know that that is a rather abnormal list to return, but -it is so for compatibility with the Java spec. See below for more -Perlish alternatives. - -If the prefix is not declared, or if the name is not valid, it'll -either die or return undef depending on the current setting of -C. - -=item * $nsup->undeclare_prefix($prefix); - -Removes a namespace prefix from the current context. This function may -be used in SAX's end_prefix_mapping when there is fear that a namespace -declaration might be available outside their scope (which shouldn't -normally happen, but you never know ;). This may be needed in order to -properly support Namespace 1.1. - -=item * $nsup->process_element_name($qname) - -Given a qualified name, it returns a namespace URI, prefix, and local -name tuple. This method applies to element names. - -If the prefix is not declared, or if the name is not valid, it'll -either die or return undef depending on the current setting of -C. - -=item * $nsup->process_attribute_name($qname) - -Given a qualified name, it returns a namespace URI, prefix, and local -name tuple. This method applies to attribute names. - -If the prefix is not declared, or if the name is not valid, it'll -either die or return undef depending on the current setting of -C. - -=item * $nsup->reset - -Resets the object so that it can be reused on another document. - -=back - -All methods of the interface have an alias that is the name used in -the original Java specification. You can use either name -interchangeably. Here is the mapping: - - Java name Perl name - --------------------------------------------------- - pushContext push_context - popContext pop_context - declarePrefix declare_prefix - declarePrefixes declare_prefixes - getPrefix get_prefix - getPrefixes get_prefixes - getDeclaredPrefixes get_declared_prefixes - getURI get_uri - processName process_name - processElementName process_element_name - processAttributeName process_attribute_name - parseJClarkNotation parse_jclark_notation - undeclarePrefix undeclare_prefix - -=head1 VARIABLES - -Two global variables are made available to you. They used to be constants but -simple scalars are easier to use in a number of contexts. They are not -exported but can easily be accessed from any package, or copied into it. - -=over 4 - -=item * C<$NS_XMLNS> - -The namespace for xmlns prefixes, http://www.w3.org/2000/xmlns/. - -=item * C<$NS_XML> - -The namespace for xml prefixes, http://www.w3.org/XML/1998/namespace. - -=back - -=head1 TODO - - - add more tests - - optimise here and there - -=head1 AUTHOR - -Robin Berjon, robin@knowscape.com, with lots of it having been done -by Duncan Cameron, and a number of suggestions from the perl-xml -list. - -=head1 COPYRIGHT - -Copyright (c) 2001 Robin Berjon. 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::Parser::PerlSAX - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX.pm --- a/common/tools/raptor/XML/SAX.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,379 +0,0 @@ -# $Id: SAX.pm,v 1.27 2007/02/07 09:33:50 grant Exp $ - -package XML::SAX; - -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); - -$VERSION = '0.15'; - -use Exporter (); -@ISA = ('Exporter'); - -@EXPORT_OK = qw(Namespaces Validation); - -use File::Basename qw(dirname); -use File::Spec (); -use Symbol qw(gensym); -use XML::SAX::ParserFactory (); # loaded for simplicity - -use constant PARSER_DETAILS => "ParserDetails.ini"; - -use constant Namespaces => "http://xml.org/sax/features/namespaces"; -use constant Validation => "http://xml.org/sax/features/validation"; - -my $known_parsers = undef; - -# load_parsers takes the ParserDetails.ini file out of the same directory -# that XML::SAX is in, and looks at it. Format in POD below - -=begin EXAMPLE - -[XML::SAX::PurePerl] -http://xml.org/sax/features/namespaces = 1 -http://xml.org/sax/features/validation = 0 -# a comment - -# blank lines ignored - -[XML::SAX::AnotherParser] -http://xml.org/sax/features/namespaces = 0 -http://xml.org/sax/features/validation = 1 - -=end EXAMPLE - -=cut - -sub load_parsers { - my $class = shift; - my $dir = shift; - - # reset parsers - $known_parsers = []; - - # get directory from wherever XML::SAX is installed - if (!$dir) { - $dir = $INC{'XML/SAX.pm'}; - $dir = dirname($dir); - } - - my $fh = gensym(); - if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) { - XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n"); - return $class; - } - - $known_parsers = $class->_parse_ini_file($fh); - - return $class; -} - -sub _parse_ini_file { - my $class = shift; - my ($fh) = @_; - - my @config; - - my $lineno = 0; - while (defined(my $line = <$fh>)) { - $lineno++; - my $original = $line; - # strip whitespace - $line =~ s/\s*$//m; - $line =~ s/^\s*//m; - # strip comments - $line =~ s/[#;].*$//m; - # ignore blanks - next if $line =~ /^$/m; - - # heading - if ($line =~ /^\[\s*(.*)\s*\]$/m) { - push @config, { Name => $1 }; - next; - } - - # instruction - elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) { - unless(@config) { - push @config, { Name => '' }; - } - $config[-1]{Features}{$1} = $2; - } - - # not whitespace, comment, or instruction - else { - die "Invalid line in ini: $lineno\n>>> $original\n"; - } - } - - return \@config; -} - -sub parsers { - my $class = shift; - if (!$known_parsers) { - $class->load_parsers(); - } - return $known_parsers; -} - -sub remove_parser { - my $class = shift; - my ($parser_module) = @_; - - if (!$known_parsers) { - $class->load_parsers(); - } - - @$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers; - - return $class; -} - -sub add_parser { - my $class = shift; - my ($parser_module) = @_; - - if (!$known_parsers) { - $class->load_parsers(); - } - - # first load module, then query features, then push onto known_parsers, - - my $parser_file = $parser_module; - $parser_file =~ s/::/\//g; - $parser_file .= ".pm"; - - require $parser_file; - - my @features = $parser_module->supported_features(); - - my $new = { Name => $parser_module }; - foreach my $feature (@features) { - $new->{Features}{$feature} = 1; - } - - # If exists in list already, move to end. - my $done = 0; - my $pos = undef; - for (my $i = 0; $i < @$known_parsers; $i++) { - my $p = $known_parsers->[$i]; - if ($p->{Name} eq $parser_module) { - $pos = $i; - } - } - if (defined $pos) { - splice(@$known_parsers, $pos, 1); - push @$known_parsers, $new; - $done++; - } - - # Otherwise (not in list), add at end of list. - if (!$done) { - push @$known_parsers, $new; - } - - return $class; -} - -sub save_parsers { - my $class = shift; - - # get directory from wherever XML::SAX is installed - my $dir = $INC{'XML/SAX.pm'}; - $dir = dirname($dir); - - my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS); - chmod 0644, $file; - unlink($file); - - my $fh = gensym(); - open($fh, ">$file") || - die "Cannot write to $file: $!"; - - foreach my $p (@$known_parsers) { - print $fh "[$p->{Name}]\n"; - foreach my $key (keys %{$p->{Features}}) { - print $fh "$key = $p->{Features}{$key}\n"; - } - print $fh "\n"; - } - - print $fh "\n"; - - close $fh; - - return $class; -} - -sub do_warn { - my $class = shift; - # Don't output warnings if running under Test::Harness - warn(@_) unless $ENV{HARNESS_ACTIVE}; -} - -1; -__END__ - -=head1 NAME - -XML::SAX - Simple API for XML - -=head1 SYNOPSIS - - use XML::SAX; - - # get a list of known parsers - my $parsers = XML::SAX->parsers(); - - # add/update a parser - XML::SAX->add_parser(q(XML::SAX::PurePerl)); - - # remove parser - XML::SAX->remove_parser(q(XML::SAX::Foodelberry)); - - # save parsers - XML::SAX->save_parsers(); - -=head1 DESCRIPTION - -XML::SAX is a SAX parser access API for Perl. It includes classes -and APIs required for implementing SAX drivers, along with a factory -class for returning any SAX parser installed on the user's system. - -=head1 USING A SAX2 PARSER - -The factory class is XML::SAX::ParserFactory. Please see the -documentation of that module for how to instantiate a SAX parser: -L. However if you don't want to load up -another manual page, here's a short synopsis: - - use XML::SAX::ParserFactory; - use XML::SAX::XYZHandler; - my $handler = XML::SAX::XYZHandler->new(); - my $p = XML::SAX::ParserFactory->parser(Handler => $handler); - $p->parse_uri("foo.xml"); - # or $p->parse_string("") or $p->parse_file($fh); - -This will automatically load a SAX2 parser (defaulting to -XML::SAX::PurePerl if no others are found) and return it to you. - -In order to learn how to use SAX to parse XML, you will need to read -L and for reference, L. - -=head1 WRITING A SAX2 PARSER - -The first thing to remember in writing a SAX2 parser is to subclass -XML::SAX::Base. This will make your life infinitely easier, by providing -a number of methods automagically for you. See L for more -details. - -When writing a SAX2 parser that is compatible with XML::SAX, you need -to inform XML::SAX of the presence of that driver when you install it. -In order to do that, XML::SAX contains methods for saving the fact that -the parser exists on your system to a "INI" file, which is then loaded -to determine which parsers are installed. - -The best way to do this is to follow these rules: - -=over 4 - -=item * Add XML::SAX as a prerequisite in Makefile.PL: - - WriteMakefile( - ... - PREREQ_PM => { 'XML::SAX' => 0 }, - ... - ); - -Alternatively you may wish to check for it in other ways that will -cause more than just a warning. - -=item * Add the following code snippet to your Makefile.PL: - - sub MY::install { - package MY; - my $script = shift->SUPER::install(@_); - if (ExtUtils::MakeMaker::prompt( - "Do you want to modify ParserDetails.ini?", 'Y') - =~ /^y/i) { - $script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m; - $script .= <<"INSTALL"; - - install_sax_driver : - \t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()" - - INSTALL - } - return $script; - } - -Note that you should check the output of this - \$(NAME) will use the name of -your distribution, which may not be exactly what you want. For example XML::LibXML -has a driver called XML::LibXML::SAX::Generator, which is used in place of -\$(NAME) in the above. - -=item * Add an XML::SAX test: - -A test file should be added to your t/ directory containing something like the -following: - - use Test; - BEGIN { plan tests => 3 } - use XML::SAX; - use XML::SAX::PurePerl::DebugHandler; - XML::SAX->add_parser(q(XML::SAX::MyDriver)); - local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver'; - eval { - my $handler = XML::SAX::PurePerl::DebugHandler->new(); - ok($handler); - my $parser = XML::SAX::ParserFactory->parser(Handler => $handler); - ok($parser); - ok($parser->isa('XML::SAX::MyDriver'); - $parser->parse_string(""); - ok($handler->{seen}{start_element}); - }; - -=back - -=head1 EXPORTS - -By default, XML::SAX exports nothing into the caller's namespace. However you -can request the symbols C and C which are the -URIs for those features, allowing an easier way to request those features -via ParserFactory: - - use XML::SAX qw(Namespaces Validation); - my $factory = XML::SAX::ParserFactory->new(); - $factory->require_feature(Namespaces); - $factory->require_feature(Validation); - my $parser = $factory->parser(); - -=head1 AUTHOR - -Current maintainer: Grant McLean, grantm@cpan.org - -Originally written by: - -Matt Sergeant, matt@sergeant.org - -Kip Hampton, khampton@totalcinema.com - -Robin Berjon, robin@knowscape.com - -=head1 LICENSE - -This is free software, you may use it and distribute it under -the same terms as Perl itself. - -=head1 SEE ALSO - -L for writing SAX Filters and Parsers - -L for an XML parser written in 100% -pure perl. - -L for details on exception handling - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/Base.pm --- a/common/tools/raptor/XML/SAX/Base.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3164 +0,0 @@ -package XML::SAX::Base; - -# version 0.10 - Kip Hampton -# version 0.13 - Robin Berjon -# version 0.15 - Kip Hampton -# version 0.17 - Kip Hampton -# version 0.19 - Kip Hampton -# version 0.21 - Kip Hampton -# version 0.22 - Robin Berjon -# version 0.23 - Matt Sergeant -# version 0.24 - Robin Berjon -# version 0.25 - Kip Hampton -# version 1.00 - Kip Hampton -# version 1.01 - Kip Hampton -# version 1.02 - Robin Berjon -# version 1.03 - Matt Sergeant -# version 1.04 - Kip Hampton - -#-----------------------------------------------------# -# STOP!!!!! -# -# This file is generated by the 'Makefile.PL' file -# that ships with the XML::SAX distribution. -# If you need to make changes, patch that file NOT -# this one. -#-----------------------------------------------------# - -use strict; -use vars qw($VERSION); -use XML::SAX::Exception qw(); - -$VERSION = '1.04'; - -sub notation_decl { - my $self = shift; - if (defined $self->{Methods}->{'notation_decl'}) { - $self->{Methods}->{'notation_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('notation_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('notation_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->notation_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->notation_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'notation_decl'} = sub { }; - } - } - -} - -sub resolve_entity { - my $self = shift; - if (defined $self->{Methods}->{'resolve_entity'}) { - $self->{Methods}->{'resolve_entity'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'EntityResolver'} and $method = $callbacks->{'EntityResolver'}->can('resolve_entity') ) { - my $handler = $callbacks->{'EntityResolver'}; - $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('resolve_entity') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'EntityResolver'} - and $callbacks->{'EntityResolver'}->can('AUTOLOAD') - and $callbacks->{'EntityResolver'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'EntityResolver'}->resolve_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'EntityResolver'}; - $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->resolve_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'resolve_entity'} = sub { }; - } - } - -} - -sub start_cdata { - my $self = shift; - if (defined $self->{Methods}->{'start_cdata'}) { - $self->{Methods}->{'start_cdata'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_cdata') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_cdata') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_cdata') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->start_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->start_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_cdata'} = sub { }; - } - } - -} - -sub set_document_locator { - my $self = shift; - if (defined $self->{Methods}->{'set_document_locator'}) { - $self->{Methods}->{'set_document_locator'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('set_document_locator') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('set_document_locator') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('set_document_locator') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->set_document_locator(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->set_document_locator(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->set_document_locator(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'set_document_locator'} = sub { }; - } - } - -} - -sub xml_decl { - my $self = shift; - if (defined $self->{Methods}->{'xml_decl'}) { - $self->{Methods}->{'xml_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('xml_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('xml_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->xml_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->xml_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'xml_decl'} = sub { }; - } - } - -} - -sub processing_instruction { - my $self = shift; - if (defined $self->{Methods}->{'processing_instruction'}) { - $self->{Methods}->{'processing_instruction'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('processing_instruction') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('processing_instruction') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('processing_instruction') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->processing_instruction(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->processing_instruction(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->processing_instruction(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'processing_instruction'} = sub { }; - } - } - -} - -sub start_prefix_mapping { - my $self = shift; - if (defined $self->{Methods}->{'start_prefix_mapping'}) { - $self->{Methods}->{'start_prefix_mapping'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_prefix_mapping') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_prefix_mapping') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->start_prefix_mapping(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_prefix_mapping(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_prefix_mapping'} = sub { }; - } - } - -} - -sub entity_reference { - my $self = shift; - if (defined $self->{Methods}->{'entity_reference'}) { - $self->{Methods}->{'entity_reference'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('entity_reference') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_reference') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->entity_reference(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->entity_reference(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'entity_reference'} = sub { }; - } - } - -} - -sub attlist_decl { - my $self = shift; - if (defined $self->{Methods}->{'attlist_decl'}) { - $self->{Methods}->{'attlist_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('attlist_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attlist_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->attlist_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->attlist_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'attlist_decl'} = sub { }; - } - } - -} - -sub error { - my $self = shift; - if (defined $self->{Methods}->{'error'}) { - $self->{Methods}->{'error'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('error') ) { - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'error'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('error') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'error'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ErrorHandler'} - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ErrorHandler'}->error(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'error'} = sub { $handler->error(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->error(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'error'} = sub { $handler->error(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'error'} = sub { }; - } - } - -} - -sub unparsed_entity_decl { - my $self = shift; - if (defined $self->{Methods}->{'unparsed_entity_decl'}) { - $self->{Methods}->{'unparsed_entity_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('unparsed_entity_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('unparsed_entity_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->unparsed_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->unparsed_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'unparsed_entity_decl'} = sub { }; - } - } - -} - -sub end_entity { - my $self = shift; - if (defined $self->{Methods}->{'end_entity'}) { - $self->{Methods}->{'end_entity'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_entity') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_entity') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->end_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_entity'} = sub { }; - } - } - -} - -sub end_element { - my $self = shift; - if (defined $self->{Methods}->{'end_element'}) { - $self->{Methods}->{'end_element'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_element') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_element') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_element') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->end_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->end_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_element'} = sub { }; - } - } - -} - -sub comment { - my $self = shift; - if (defined $self->{Methods}->{'comment'}) { - $self->{Methods}->{'comment'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('comment') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('comment') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('comment') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->comment(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->comment(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->comment(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'comment'} = sub { }; - } - } - -} - -sub element_decl { - my $self = shift; - if (defined $self->{Methods}->{'element_decl'}) { - $self->{Methods}->{'element_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('element_decl') ) { - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('element_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DeclHandler'} - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DeclHandler'}->element_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->element_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'element_decl'} = sub { }; - } - } - -} - -sub attribute_decl { - my $self = shift; - if (defined $self->{Methods}->{'attribute_decl'}) { - $self->{Methods}->{'attribute_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('attribute_decl') ) { - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attribute_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DeclHandler'} - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DeclHandler'}->attribute_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->attribute_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'attribute_decl'} = sub { }; - } - } - -} - -sub fatal_error { - my $self = shift; - if (defined $self->{Methods}->{'fatal_error'}) { - $self->{Methods}->{'fatal_error'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('fatal_error') ) { - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('fatal_error') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ErrorHandler'} - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ErrorHandler'}->fatal_error(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->fatal_error(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'fatal_error'} = sub { }; - } - } - -} - -sub start_document { - my $self = shift; - if (defined $self->{Methods}->{'start_document'}) { - $self->{Methods}->{'start_document'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_document') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_document') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_document') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->start_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->start_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_document'} = sub { }; - } - } - -} - -sub external_entity_decl { - my $self = shift; - if (defined $self->{Methods}->{'external_entity_decl'}) { - $self->{Methods}->{'external_entity_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('external_entity_decl') ) { - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('external_entity_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DeclHandler'} - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DeclHandler'}->external_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->external_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'external_entity_decl'} = sub { }; - } - } - -} - -sub warning { - my $self = shift; - if (defined $self->{Methods}->{'warning'}) { - $self->{Methods}->{'warning'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('warning') ) { - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'warning'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('warning') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'warning'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ErrorHandler'} - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') - and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ErrorHandler'}->warning(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ErrorHandler'}; - $self->{Methods}->{'warning'} = sub { $handler->warning(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->warning(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'warning'} = sub { $handler->warning(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'warning'} = sub { }; - } - } - -} - -sub doctype_decl { - my $self = shift; - if (defined $self->{Methods}->{'doctype_decl'}) { - $self->{Methods}->{'doctype_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('doctype_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('doctype_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->doctype_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->doctype_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'doctype_decl'} = sub { }; - } - } - -} - -sub entity_decl { - my $self = shift; - if (defined $self->{Methods}->{'entity_decl'}) { - $self->{Methods}->{'entity_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('entity_decl') ) { - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DTDHandler'} - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') - and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DTDHandler'}->entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DTDHandler'}; - $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'entity_decl'} = sub { }; - } - } - -} - -sub end_document { - my $self = shift; - if (defined $self->{Methods}->{'end_document'}) { - $self->{Methods}->{'end_document'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_document') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_document') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_document') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->end_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->end_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_document(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_document'} = sub { }; - } - } - -} - -sub start_element { - my $self = shift; - if (defined $self->{Methods}->{'start_element'}) { - $self->{Methods}->{'start_element'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_element') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_element') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_element') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->start_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->start_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_element(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_element'} = sub { }; - } - } - -} - -sub start_dtd { - my $self = shift; - if (defined $self->{Methods}->{'start_dtd'}) { - $self->{Methods}->{'start_dtd'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_dtd') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_dtd') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->start_dtd(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_dtd(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_dtd'} = sub { }; - } - } - -} - -sub end_prefix_mapping { - my $self = shift; - if (defined $self->{Methods}->{'end_prefix_mapping'}) { - $self->{Methods}->{'end_prefix_mapping'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_prefix_mapping') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_prefix_mapping') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->end_prefix_mapping(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_prefix_mapping(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_prefix_mapping'} = sub { }; - } - } - -} - -sub end_dtd { - my $self = shift; - if (defined $self->{Methods}->{'end_dtd'}) { - $self->{Methods}->{'end_dtd'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_dtd') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_dtd') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->end_dtd(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_dtd(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_dtd'} = sub { }; - } - } - -} - -sub characters { - my $self = shift; - if (defined $self->{Methods}->{'characters'}) { - $self->{Methods}->{'characters'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('characters') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('characters') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('characters') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->characters(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->characters(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->characters(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'characters'} = sub { }; - } - } - -} - -sub end_cdata { - my $self = shift; - if (defined $self->{Methods}->{'end_cdata'}) { - $self->{Methods}->{'end_cdata'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_cdata') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_cdata') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_cdata') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->end_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->end_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->end_cdata(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'end_cdata'} = sub { }; - } - } - -} - -sub skipped_entity { - my $self = shift; - if (defined $self->{Methods}->{'skipped_entity'}) { - $self->{Methods}->{'skipped_entity'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('skipped_entity') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('skipped_entity') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->skipped_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->skipped_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'skipped_entity'} = sub { }; - } - } - -} - -sub ignorable_whitespace { - my $self = shift; - if (defined $self->{Methods}->{'ignorable_whitespace'}) { - $self->{Methods}->{'ignorable_whitespace'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('ignorable_whitespace') ) { - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('ignorable_whitespace') ) { - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('ignorable_whitespace') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'ContentHandler'} - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') - and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'ContentHandler'}->ignorable_whitespace(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'ContentHandler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'DocumentHandler'} - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') - and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DocumentHandler'}->ignorable_whitespace(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DocumentHandler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->ignorable_whitespace(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'ignorable_whitespace'} = sub { }; - } - } - -} - -sub internal_entity_decl { - my $self = shift; - if (defined $self->{Methods}->{'internal_entity_decl'}) { - $self->{Methods}->{'internal_entity_decl'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('internal_entity_decl') ) { - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('internal_entity_decl') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'DeclHandler'} - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') - and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'DeclHandler'}->internal_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'DeclHandler'}; - $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->internal_entity_decl(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'internal_entity_decl'} = sub { }; - } - } - -} - -sub start_entity { - my $self = shift; - if (defined $self->{Methods}->{'start_entity'}) { - $self->{Methods}->{'start_entity'}->(@_); - } - else { - my $method; - my $callbacks; - if (exists $self->{ParseOptions}) { - $callbacks = $self->{ParseOptions}; - } - else { - $callbacks = $self; - } - if (0) { # dummy to make elsif's below compile - } - elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_entity') ) { - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_entity') ) { - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) }; - return $method->($handler, @_); - } - elsif (defined $callbacks->{'LexicalHandler'} - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') - and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'LexicalHandler'}->start_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'LexicalHandler'}; - $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) }; - } - return $res; - } - elsif (defined $callbacks->{'Handler'} - and $callbacks->{'Handler'}->can('AUTOLOAD') - and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') - ) - { - my $res = eval { $callbacks->{'Handler'}->start_entity(@_) }; - if ($@) { - die $@; - } - else { - # I think there's a buggette here... - # if the first call throws an exception, we don't set it up right. - # Not fatal, but we might want to address it. - my $handler = $callbacks->{'Handler'}; - $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) }; - } - return $res; - } - else { - $self->{Methods}->{'start_entity'} = sub { }; - } - } - -} - -#-------------------------------------------------------------------# -# Class->new(%options) -#-------------------------------------------------------------------# -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $options = ($#_ == 0) ? shift : { @_ }; - - unless ( defined( $options->{Handler} ) or - defined( $options->{ContentHandler} ) or - defined( $options->{DTDHandler} ) or - defined( $options->{DocumentHandler} ) or - defined( $options->{LexicalHandler} ) or - defined( $options->{ErrorHandler} ) or - defined( $options->{DeclHandler} ) ) { - - $options->{Handler} = XML::SAX::Base::NoHandler->new; - } - - my $self = bless $options, $class; - # turn NS processing on by default - $self->set_feature('http://xml.org/sax/features/namespaces', 1); - return $self; -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# $p->parse(%options) -#-------------------------------------------------------------------# -sub parse { - my $self = shift; - my $parse_options = $self->get_options(@_); - local $self->{ParseOptions} = $parse_options; - if ($self->{Parent}) { # calling parse on a filter for some reason - return $self->{Parent}->parse($parse_options); - } - else { - my $method; - if (defined $parse_options->{Source}{CharacterStream} and $method = $self->can('_parse_characterstream')) { - warn("parse charstream???\n"); - return $method->($self, $parse_options->{Source}{CharacterStream}); - } - elsif (defined $parse_options->{Source}{ByteStream} and $method = $self->can('_parse_bytestream')) { - return $method->($self, $parse_options->{Source}{ByteStream}); - } - elsif (defined $parse_options->{Source}{String} and $method = $self->can('_parse_string')) { - return $method->($self, $parse_options->{Source}{String}); - } - elsif (defined $parse_options->{Source}{SystemId} and $method = $self->can('_parse_systemid')) { - return $method->($self, $parse_options->{Source}{SystemId}); - } - else { - die "No _parse_* routine defined on this driver (If it is a filter, remember to set the Parent property. If you call the parse() method, make sure to set a Source. You may want to call parse_uri, parse_string or parse_file instead.) [$self]"; - } - } -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# $p->parse_file(%options) -#-------------------------------------------------------------------# -sub parse_file { - my $self = shift; - my $file = shift; - return $self->parse_uri($file, @_) if ref(\$file) eq 'SCALAR'; - my $parse_options = $self->get_options(@_); - $parse_options->{Source}{ByteStream} = $file; - return $self->parse($parse_options); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# $p->parse_uri(%options) -#-------------------------------------------------------------------# -sub parse_uri { - my $self = shift; - my $file = shift; - my $parse_options = $self->get_options(@_); - $parse_options->{Source}{SystemId} = $file; - return $self->parse($parse_options); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# $p->parse_string(%options) -#-------------------------------------------------------------------# -sub parse_string { - my $self = shift; - my $string = shift; - my $parse_options = $self->get_options(@_); - $parse_options->{Source}{String} = $string; - return $self->parse($parse_options); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_options -#-------------------------------------------------------------------# -sub get_options { - my $self = shift; - - if (@_ == 1) { - return { %$self, %{$_[0]} }; - } else { - return { %$self, @_ }; - } -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_features -#-------------------------------------------------------------------# -sub get_features { - return ( - 'http://xml.org/sax/features/external-general-entities' => undef, - 'http://xml.org/sax/features/external-parameter-entities' => undef, - 'http://xml.org/sax/features/is-standalone' => undef, - 'http://xml.org/sax/features/lexical-handler' => undef, - 'http://xml.org/sax/features/parameter-entities' => undef, - 'http://xml.org/sax/features/namespaces' => 1, - 'http://xml.org/sax/features/namespace-prefixes' => 0, - 'http://xml.org/sax/features/string-interning' => undef, - 'http://xml.org/sax/features/use-attributes2' => undef, - 'http://xml.org/sax/features/use-locator2' => undef, - 'http://xml.org/sax/features/validation' => undef, - - 'http://xml.org/sax/properties/dom-node' => undef, - 'http://xml.org/sax/properties/xml-string' => undef, - ); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_feature -#-------------------------------------------------------------------# -sub get_feature { - my $self = shift; - my $feat = shift; - - # check %FEATURES to see if it's there, and return it if so - # throw XML::SAX::Exception::NotRecognized if it's not there - # throw XML::SAX::Exception::NotSupported if it's there but we - # don't support it - - my %features = $self->get_features(); - if (exists $features{$feat}) { - my %supported = map { $_ => 1 } $self->supported_features(); - if ($supported{$feat}) { - return $self->{__PACKAGE__ . "::Features"}{$feat}; - } - throw XML::SAX::Exception::NotSupported( - Message => "The feature '$feat' is not supported by " . ref($self), - Exception => undef, - ); - } - throw XML::SAX::Exception::NotRecognized( - Message => "The feature '$feat' is not recognized by " . ref($self), - Exception => undef, - ); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# set_feature -#-------------------------------------------------------------------# -sub set_feature { - my $self = shift; - my $feat = shift; - my $value = shift; - # check %FEATURES to see if it's there, and set it if so - # throw XML::SAX::Exception::NotRecognized if it's not there - # throw XML::SAX::Exception::NotSupported if it's there but we - # don't support it - - my %features = $self->get_features(); - if (exists $features{$feat}) { - my %supported = map { $_ => 1 } $self->supported_features(); - if ($supported{$feat}) { - return $self->{__PACKAGE__ . "::Features"}{$feat} = $value; - } - throw XML::SAX::Exception::NotSupported( - Message => "The feature '$feat' is not supported by " . ref($self), - Exception => undef, - ); - } - throw XML::SAX::Exception::NotRecognized( - Message => "The feature '$feat' is not recognized by " . ref($self), - Exception => undef, - ); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# get_handler and friends -#-------------------------------------------------------------------# -sub get_handler { - my $self = shift; - my $handler_type = shift; - $handler_type ||= 'Handler'; - return defined( $self->{$handler_type} ) ? $self->{$handler_type} : undef; -} - -sub get_document_handler { - my $self = shift; - return $self->get_handler('DocumentHandler', @_); -} - -sub get_content_handler { - my $self = shift; - return $self->get_handler('ContentHandler', @_); -} - -sub get_dtd_handler { - my $self = shift; - return $self->get_handler('DTDHandler', @_); -} - -sub get_lexical_handler { - my $self = shift; - return $self->get_handler('LexicalHandler', @_); -} - -sub get_decl_handler { - my $self = shift; - return $self->get_handler('DeclHandler', @_); -} - -sub get_error_handler { - my $self = shift; - return $self->get_handler('ErrorHandler', @_); -} - -sub get_entity_resolver { - my $self = shift; - return $self->get_handler('EntityResolver', @_); -} -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# set_handler and friends -#-------------------------------------------------------------------# -sub set_handler { - my $self = shift; - my ($new_handler, $handler_type) = reverse @_; - $handler_type ||= 'Handler'; - $self->{Methods} = {} if $self->{Methods}; - $self->{$handler_type} = $new_handler; - $self->{ParseOptions}->{$handler_type} = $new_handler; - return 1; -} - -sub set_document_handler { - my $self = shift; - return $self->set_handler('DocumentHandler', @_); -} - -sub set_content_handler { - my $self = shift; - return $self->set_handler('ContentHandler', @_); -} -sub set_dtd_handler { - my $self = shift; - return $self->set_handler('DTDHandler', @_); -} -sub set_lexical_handler { - my $self = shift; - return $self->set_handler('LexicalHandler', @_); -} -sub set_decl_handler { - my $self = shift; - return $self->set_handler('DeclHandler', @_); -} -sub set_error_handler { - my $self = shift; - return $self->set_handler('ErrorHandler', @_); -} -sub set_entity_resolver { - my $self = shift; - return $self->set_handler('EntityResolver', @_); -} - -#-------------------------------------------------------------------# - -#-------------------------------------------------------------------# -# supported_features -#-------------------------------------------------------------------# -sub supported_features { - my $self = shift; - # Only namespaces are required by all parsers - return ( - 'http://xml.org/sax/features/namespaces', - ); -} -#-------------------------------------------------------------------# - -sub no_op { - # this space intentionally blank -} - - -package XML::SAX::Base::NoHandler; - -# we need a fake handler that doesn't implement anything, this -# simplifies the code a lot (though given the recent changes, -# it may be better to do without) -sub new { - #warn "no handler called\n"; - return bless {}; -} - -1; - -__END__ - -=head1 NAME - -XML::SAX::Base - Base class SAX Drivers and Filters - -=head1 SYNOPSIS - - package MyFilter; - use XML::SAX::Base; - @ISA = ('XML::SAX::Base'); - -=head1 DESCRIPTION - -This module has a very simple task - to be a base class for PerlSAX -drivers and filters. It's default behaviour is to pass the input directly -to the output unchanged. It can be useful to use this module as a base class -so you don't have to, for example, implement the characters() callback. - -The main advantages that it provides are easy dispatching of events the right -way (ie it takes care for you of checking that the handler has implemented -that method, or has defined an AUTOLOAD), and the guarantee that filters -will pass along events that they aren't implementing to handlers downstream -that might nevertheless be interested in them. - -=head1 WRITING SAX DRIVERS AND FILTERS - -Writing SAX Filters is tremendously easy: all you need to do is -inherit from this module, and define the events you want to handle. A -more detailed explanation can be found at -http://www.xml.com/pub/a/2001/10/10/sax-filters.html. - -Writing Drivers is equally simple. The one thing you need to pay -attention to is B to call events yourself (this applies to Filters -as well). For instance: - - package MyFilter; - use base qw(XML::SAX::Base); - - sub start_element { - my $self = shift; - my $data = shift; - # do something - $self->{Handler}->start_element($data); # BAD - } - -The above example works well as precisely that: an example. But it has -several faults: 1) it doesn't test to see whether the handler defines -start_element. Perhaps it doesn't want to see that event, in which -case you shouldn't throw it (otherwise it'll die). 2) it doesn't check -ContentHandler and then Handler (ie it doesn't look to see that the -user hasn't requested events on a specific handler, and if not on the -default one), 3) if it did check all that, not only would the code be -cumbersome (see this module's source to get an idea) but it would also -probably have to check for a DocumentHandler (in case this were SAX1) -and for AUTOLOADs potentially defined in all these packages. As you can -tell, that would be fairly painful. Instead of going through that, -simply remember to use code similar to the following instead: - - package MyFilter; - use base qw(XML::SAX::Base); - - sub start_element { - my $self = shift; - my $data = shift; - # do something to filter - $self->SUPER::start_element($data); # GOOD (and easy) ! - } - -This way, once you've done your job you hand the ball back to -XML::SAX::Base and it takes care of all those problems for you! - -Note that the above example doesn't apply to filters only, drivers -will benefit from the exact same feature. - -=head1 METHODS - -A number of methods are defined within this class for the purpose of -inheritance. Some probably don't need to be overridden (eg parse_file) -but some clearly should be (eg parse). Options for these methods are -described in the PerlSAX2 specification available from -http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/~checkout~/perl-xml/libxml-perl/doc/sax-2.0.html?rev=HEAD&content-type=text/html. - -=over 4 - -=item * parse - -The parse method is the main entry point to parsing documents. Internally -the parse method will detect what type of "thing" you are parsing, and -call the appropriate method in your implementation class. Here is the -mapping table of what is in the Source options (see the Perl SAX 2.0 -specification for the meaning of these values): - - Source Contains parse() calls - =============== ============= - CharacterStream (*) _parse_characterstream($stream, $options) - ByteStream _parse_bytestream($stream, $options) - String _parse_string($string, $options) - SystemId _parse_systemid($string, $options) - -However note that these methods may not be sensible if your driver class -is not for parsing XML. An example might be a DBI driver that generates -XML/SAX from a database table. If that is the case, you likely want to -write your own parse() method. - -Also note that the Source may contain both a PublicId entry, and an -Encoding entry. To get at these, examine $options->{Source} as passed -to your method. - -(*) A CharacterStream is a filehandle that does not need any encoding -translation done on it. This is implemented as a regular filehandle -and only works under Perl 5.7.2 or higher using PerlIO. To get a single -character, or number of characters from it, use the perl core read() -function. To get a single byte from it (or number of bytes), you can -use sysread(). The encoding of the stream should be in the Encoding -entry for the Source. - -=item * parse_file, parse_uri, parse_string - -These are all convenience variations on parse(), and in fact simply -set up the options before calling it. You probably don't need to -override these. - -=item * get_options - -This is a convenience method to get options in SAX2 style, or more -generically either as hashes or as hashrefs (it returns a hashref). -You will probably want to use this method in your own implementations -of parse() and of new(). - -=item * get_feature, set_feature - -These simply get and set features, and throw the -appropriate exceptions defined in the specification if need be. - -If your subclass defines features not defined in this one, -then you should override these methods in such a way that they check for -your features first, and then call the base class's methods -for features not defined by your class. An example would be: - - sub get_feature { - my $self = shift; - my $feat = shift; - if (exists $MY_FEATURES{$feat}) { - # handle the feature in various ways - } - else { - return $self->SUPER::get_feature($feat); - } - } - -Currently this part is unimplemented. - - -=item * set_handler - -This method takes a handler type (Handler, ContentHandler, etc.) and a -handler object as arguments, and changes the current handler for that -handler type, while taking care of resetting the internal state that -needs to be reset. This allows one to change a handler during parse -without running into problems (changing it on the parser object -directly will most likely cause trouble). - -=item * set_document_handler, set_content_handler, set_dtd_handler, set_lexical_handler, set_decl_handler, set_error_handler, set_entity_resolver - -These are just simple wrappers around the former method, and take a -handler object as their argument. Internally they simply call -set_handler with the correct arguments. - -=item * get_handler - -The inverse of set_handler, this method takes a an optional string containing a handler type (DTDHandler, -ContentHandler, etc. 'Handler' is used if no type is passed). It returns a reference to the object that implements -that that class, or undef if that handler type is not set for the current driver/filter. - -=item * get_document_handler, get_content_handler, get_dtd_handler, get_lexical_handler, get_decl_handler, -get_error_handler, get_entity_resolver - -These are just simple wrappers around the get_handler() method, and take no arguments. Internally -they simply call get_handler with the correct handler type name. - -=back - -It would be rather useless to describe all the methods that this -module implements here. They are all the methods supported in SAX1 and -SAX2. In case your memory is a little short, here is a list. The -apparent duplicates are there so that both versions of SAX can be -supported. - -=over 4 - -=item * start_document - -=item * end_document - -=item * start_element - -=item * start_document - -=item * end_document - -=item * start_element - -=item * end_element - -=item * characters - -=item * processing_instruction - -=item * ignorable_whitespace - -=item * set_document_locator - -=item * start_prefix_mapping - -=item * end_prefix_mapping - -=item * skipped_entity - -=item * start_cdata - -=item * end_cdata - -=item * comment - -=item * entity_reference - -=item * notation_decl - -=item * unparsed_entity_decl - -=item * element_decl - -=item * attlist_decl - -=item * doctype_decl - -=item * xml_decl - -=item * entity_decl - -=item * attribute_decl - -=item * internal_entity_decl - -=item * external_entity_decl - -=item * resolve_entity - -=item * start_dtd - -=item * end_dtd - -=item * start_entity - -=item * end_entity - -=item * warning - -=item * error - -=item * fatal_error - -=back - -=head1 TODO - - - more tests - - conform to the "SAX Filters" and "Java and DOM compatibility" - sections of the SAX2 document. - -=head1 AUTHOR - -Kip Hampton (khampton@totalcinema.com) did most of the work, after porting -it from XML::Filter::Base. - -Robin Berjon (robin@knowscape.com) pitched in with patches to make it -usable as a base for drivers as well as filters, along with other patches. - -Matt Sergeant (matt@sergeant.org) wrote the original XML::Filter::Base, -and patched a few things here and there, and imported it into -the XML::SAX distribution. - -=head1 SEE ALSO - -L - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/DocumentLocator.pm --- a/common/tools/raptor/XML/SAX/DocumentLocator.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -# $Id: DocumentLocator.pm,v 1.3 2005/10/14 20:31:20 matt Exp $ - -package XML::SAX::DocumentLocator; -use strict; - -sub new { - my $class = shift; - my %object; - tie %object, $class, @_; - - return bless \%object, $class; -} - -sub TIEHASH { - my $class = shift; - my ($pubmeth, $sysmeth, $linemeth, $colmeth, $encmeth, $xmlvmeth) = @_; - return bless { - pubmeth => $pubmeth, - sysmeth => $sysmeth, - linemeth => $linemeth, - colmeth => $colmeth, - encmeth => $encmeth, - xmlvmeth => $xmlvmeth, - }, $class; -} - -sub FETCH { - my ($self, $key) = @_; - my $method; - if ($key eq 'PublicId') { - $method = $self->{pubmeth}; - } - elsif ($key eq 'SystemId') { - $method = $self->{sysmeth}; - } - elsif ($key eq 'LineNumber') { - $method = $self->{linemeth}; - } - elsif ($key eq 'ColumnNumber') { - $method = $self->{colmeth}; - } - elsif ($key eq 'Encoding') { - $method = $self->{encmeth}; - } - elsif ($key eq 'XMLVersion') { - $method = $self->{xmlvmeth}; - } - if ($method) { - my $value = $method->($key); - return $value; - } - return undef; -} - -sub EXISTS { - my ($self, $key) = @_; - if ($key =~ /^(PublicId|SystemId|LineNumber|ColumnNumber|Encoding|XMLVersion)$/) { - return 1; - } - return 0; -} - -sub STORE { - my ($self, $key, $value) = @_; -} - -sub DELETE { - my ($self, $key) = @_; -} - -sub CLEAR { - my ($self) = @_; -} - -sub FIRSTKEY { - my ($self) = @_; - # assignment resets. - $self->{keys} = { - PublicId => 1, - SystemId => 1, - LineNumber => 1, - ColumnNumber => 1, - Encoding => 1, - XMLVersion => 1, - }; - return each %{$self->{keys}}; -} - -sub NEXTKEY { - my ($self, $lastkey) = @_; - return each %{$self->{keys}}; -} - -1; -__END__ - -=head1 NAME - -XML::SAX::DocumentLocator - Helper class for document locators - -=head1 SYNOPSIS - - my $locator = XML::SAX::DocumentLocator->new( - sub { $object->get_public_id }, - sub { $object->get_system_id }, - sub { $reader->current_line }, - sub { $reader->current_column }, - sub { $reader->get_encoding }, - sub { $reader->get_xml_version }, - ); - -=head1 DESCRIPTION - -This module gives you a tied hash reference that calls the -specified closures when asked for PublicId, SystemId, -LineNumber and ColumnNumber. - -It is useful for writing SAX Parsers so that you don't have -to constantly update the line numbers in a hash reference on -the object you pass to set_document_locator(). See the source -code for XML::SAX::PurePerl for a usage example. - -=head1 API - -There is only 1 method: C. Simply pass it a list of -closures that when called will return the PublicId, the -SystemId, the LineNumber, the ColumnNumber, the Encoding -and the XMLVersion respectively. - -The closures are passed a single parameter, the key being -requested. But you're free to ignore that. - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/Exception.pm --- a/common/tools/raptor/XML/SAX/Exception.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,126 +0,0 @@ -package XML::SAX::Exception; - -use strict; - -use overload '""' => "stringify", - 'fallback' => 1; - -use vars qw/$StackTrace $VERSION/; -$VERSION = '1.01'; -use Carp; - -$StackTrace = $ENV{XML_DEBUG} || 0; - -# Other exception classes: - -@XML::SAX::Exception::NotRecognized::ISA = ('XML::SAX::Exception'); -@XML::SAX::Exception::NotSupported::ISA = ('XML::SAX::Exception'); -@XML::SAX::Exception::Parse::ISA = ('XML::SAX::Exception'); - - -sub throw { - my $class = shift; - if (ref($class)) { - die $class; - } - die $class->new(@_); -} - -sub new { - my $class = shift; - my %opts = @_; - confess "Invalid options: " . join(', ', keys %opts) unless exists $opts{Message}; - - bless { ($StackTrace ? (StackTrace => stacktrace()) : ()), %opts }, - $class; -} - -sub stringify { - my $self = shift; - local $^W; - my $error; - if (exists $self->{LineNumber}) { - $error = $self->{Message} . " [Ln: " . $self->{LineNumber} . - ", Col: " . $self->{ColumnNumber} . "]"; - } - else { - $error = $self->{Message}; - } - if ($StackTrace) { - $error .= stackstring($self->{StackTrace}); - } - $error .= "\n"; - return $error; -} - -sub stacktrace { - my $i = 2; - my @fulltrace; - while (my @trace = caller($i++)) { - my %hash; - @hash{qw(Package Filename Line)} = @trace[0..2]; - push @fulltrace, \%hash; - } - return \@fulltrace; -} - -sub stackstring { - my $stacktrace = shift; - my $string = "\nFrom:\n"; - foreach my $current (@$stacktrace) { - $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n"; - } - return $string; -} - -1; - -__END__ - -=head1 NAME - -XML::SAX::Exception - Exception classes for XML::SAX - -=head1 SYNOPSIS - - throw XML::SAX::Exception::NotSupported( - Message => "The foo feature is not supported", - ); - -=head1 DESCRIPTION - -This module is the base class for all SAX Exceptions, those defined in -the spec as well as those that one may create for one's own SAX errors. - -There are three subclasses included, corresponding to those of the SAX -spec: - - XML::SAX::Exception::NotSupported - XML::SAX::Exception::NotRecognized - XML::SAX::Exception::Parse - -Use them wherever you want, and as much as possible when you encounter -such errors. SAX is meant to use exceptions as much as possible to -flag problems. - -=head1 CREATING NEW EXCEPTION CLASSES - -All you need to do to create a new exception class is: - - @XML::SAX::Exception::MyException::ISA = ('XML::SAX::Exception') - -The given package doesn't need to exist, it'll behave correctly this -way. If your exception refines an existing exception class, then you -may also inherit from that instead of from the base class. - -=head1 THROWING EXCEPTIONS - -This is as simple as exemplified in the SYNOPSIS. In fact, there's -nothing more to know. All you have to do is: - - throw XML::SAX::Exception::MyException( Message => 'Something went wrong' ); - -and voila, you've thrown an exception which can be caught in an eval block. - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/Intro.pod --- a/common/tools/raptor/XML/SAX/Intro.pod Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,407 +0,0 @@ -=head1 NAME - -XML::SAX::Intro - An Introduction to SAX Parsing with Perl - -=head1 Introduction - -XML::SAX is a new way to work with XML Parsers in Perl. In this article -we'll discuss why you should be using SAX, why you should be using -XML::SAX, and we'll see some of the finer implementation details. The -text below assumes some familiarity with callback, or push based -parsing, but if you are unfamiliar with these techniques then a good -place to start is Kip Hampton's excellent series of articles on XML.com. - -=head1 Replacing XML::Parser - -The de-facto way of parsing XML under perl is to use Larry Wall and -Clark Cooper's XML::Parser. This module is a Perl and XS wrapper around -the expat XML parser library by James Clark. It has been a hugely -successful project, but suffers from a couple of rather major flaws. -Firstly it is a proprietary API, designed before the SAX API was -conceived, which means that it is not easily replaceable by other -streaming parsers. Secondly it's callbacks are subrefs. This doesn't -sound like much of an issue, but unfortunately leads to code like: - - sub handle_start { - my ($e, $el, %attrs) = @_; - if ($el eq 'foo') { - $e->{inside_foo}++; # BAD! $e is an XML::Parser::Expat object. - } - } - -As you can see, we're using the $e object to hold our state -information, which is a bad idea because we don't own that object - we -didn't create it. It's an internal object of XML::Parser, that happens -to be a hashref. We could all too easily overwrite XML::Parser internal -state variables by using this, or Clark could change it to an array ref -(not that he would, because it would break so much code, but he could). - -The only way currently with XML::Parser to safely maintain state is to -use a closure: - - my $state = MyState->new(); - $parser->setHandlers(Start => sub { handle_start($state, @_) }); - -This closure traps the $state variable, which now gets passed as the -first parameter to your callback. Unfortunately very few people use -this technique, as it is not documented in the XML::Parser POD files. - -Another reason you might not want to use XML::Parser is because you -need some feature that it doesn't provide (such as validation), or you -might need to use a library that doesn't use expat, due to it not being -installed on your system, or due to having a restrictive ISP. Using SAX -allows you to work around these restrictions. - -=head1 Introducing SAX - -SAX stands for the Simple API for XML. And simple it really is. -Constructing a SAX parser and passing events to handlers is done as -simply as: - - use XML::SAX; - use MySAXHandler; - - my $parser = XML::SAX::ParserFactory->parser( - Handler => MySAXHandler->new - ); - - $parser->parse_uri("foo.xml"); - -The important concept to grasp here is that SAX uses a factory class -called XML::SAX::ParserFactory to create a new parser instance. The -reason for this is so that you can support other underlying -parser implementations for different feature sets. This is one thing -that XML::Parser has always sorely lacked. - -In the code above we see the parse_uri method used, but we could -have equally well -called parse_file, parse_string, or parse(). Please see XML::SAX::Base -for what these methods take as parameters, but don't be fooled into -believing parse_file takes a filename. No, it takes a file handle, a -glob, or a subclass of IO::Handle. Beware. - -SAX works very similarly to XML::Parser's default callback method, -except it has one major difference: rather than setting individual -callbacks, you create a new class in which to recieve the callbacks. -Each callback is called as a method call on an instance of that handler -class. An example will best demonstrate this: - - package MySAXHandler; - use base qw(XML::SAX::Base); - - sub start_document { - my ($self, $doc) = @_; - # process document start event - } - - sub start_element { - my ($self, $el) = @_; - # process element start event - } - -Now, when we instantiate this as above, and parse some XML with this as -the handler, the methods start_document and start_element will be -called as method calls, so this would be the equivalent of directly -calling: - - $object->start_element($el); - -Notice how this is different to XML::Parser's calling style, which -calls: - - start_element($e, $name, %attribs); - -It's the difference between function calling and method calling which -allows you to subclass SAX handlers which contributes to SAX being a -powerful solution. - -As you can see, unlike XML::Parser, we have to define a new package in -which to do our processing (there are hacks you can do to make this -uneccessary, but I'll leave figuring those out to the experts). The -biggest benefit of this is that you maintain your own state variable -($self in the above example) thus freeing you of the concerns listed -above. It is also an improvement in maintainability - you can place the -code in a separate file if you wish to, and your callback methods are -always called the same thing, rather than having to choose a suitable -name for them as you had to with XML::Parser. This is an obvious win. - -SAX parsers are also very flexible in how you pass a handler to them. -You can use a constructor parameter as we saw above, or we can pass the -handler directly in the call to one of the parse methods: - - $parser->parse(Handler => $handler, - Source => { SystemId => "foo.xml" }); - # or... - $parser->parse_file($fh, Handler => $handler); - -This flexibility allows for one parser to be used in many different -scenarios throughout your script (though one shouldn't feel pressure to -use this method, as parser construction is generally not a time -consuming process). - -=head1 Callback Parameters - -The only other thing you need to know to understand basic SAX is the -structure of the parameters passed to each of the callbacks. In -XML::Parser, all parameters are passed as multiple options to the -callbacks, so for example the Start callback would be called as -my_start($e, $name, %attributes), and the PI callback would be called -as my_processing_instruction($e, $target, $data). In SAX, every -callback is passed a hash reference, containing entries that define our -"node". The key callbacks and the structures they receive are: - -=head2 start_element - -The start_element handler is called whenever a parser sees an opening -tag. It is passed an element structure consisting of: - -=over 4 - -=item LocalName - -The name of the element minus any namespace prefix it may -have come with in the document. - -=item NamespaceURI - -The URI of the namespace associated with this element, -or the empty string for none. - -=item Attributes - -A set of attributes as described below. - -=item Name - -The name of the element as it was seen in the document (i.e. -including any prefix associated with it) - -=item Prefix - -The prefix used to qualify this element's namespace, or the -empty string if none. - -=back - -The B are a hash reference, keyed by what we have called -"James Clark" notation. This means that the attribute name has been -expanded to include any associated namespace URI, and put together as -{ns}name, where "ns" is the expanded namespace URI of the attribute if -and only if the attribute had a prefix, and "name" is the LocalName of -the attribute. - -The value of each entry in the attributes hash is another hash -structure consisting of: - -=over 4 - -=item LocalName - -The name of the attribute minus any namespace prefix it may have -come with in the document. - -=item NamespaceURI - -The URI of the namespace associated with this attribute. If the -attribute had no prefix, then this consists of just the empty string. - -=item Name - -The attribute's name as it appeared in the document, including any -namespace prefix. - -=item Prefix - -The prefix used to qualify this attribute's namepace, or the -empty string if none. - -=item Value - -The value of the attribute. - -=back - -So a full example, as output by Data::Dumper might be: - - .... - -=head2 end_element - -The end_element handler is called either when a parser sees a closing -tag, or after start_element has been called for an empty element (do -note however that a parser may if it is so inclined call characters -with an empty string when it sees an empty element. There is no simple -way in SAX to determine if the parser in fact saw an empty element, a -start and end element with no content.. - -The end_element handler receives exactly the same structure as -start_element, minus the Attributes entry. One must note though that it -should not be a reference to the same data as start_element receives, -so you may change the values in start_element but this will not affect -the values later seen by end_element. - -=head2 characters - -The characters callback may be called in serveral circumstances. The -most obvious one is when seeing ordinary character data in the markup. -But it is also called for text in a CDATA section, and is also called -in other situations. A SAX parser has to make no guarantees whatsoever -about how many times it may call characters for a stretch of text in an -XML document - it may call once, or it may call once for every -character in the text. In order to work around this it is often -important for the SAX developer to use a bundling technique, where text -is gathered up and processed in one of the other callbacks. This is not -always necessary, but it is a worthwhile technique to learn, which we -will cover in XML::SAX::Advanced (when I get around to writing it). - -The characters handler is called with a very simple structure - a hash -reference consisting of just one entry: - -=over 4 - -=item Data - -The text data that was received. - -=back - -=head2 comment - -The comment callback is called for comment text. Unlike with -C, the comment callback *must* be invoked just once for an -entire comment string. It receives a single simple structure - a hash -reference containing just one entry: - -=over 4 - -=item Data - -The text of the comment. - -=back - -=head2 processing_instruction - -The processing instruction handler is called for all processing -instructions in the document. Note that these processing instructions -may appear before the document root element, or after it, or anywhere -where text and elements would normally appear within the document, -according to the XML specification. - -The handler is passed a structure containing just two entries: - -=over 4 - -=item Target - -The target of the processing instrcution - -=item Data - -The text data in the processing instruction. Can be an empty -string for a processing instruction that has no data element. -For example E?wiggle?E is a perfectly valid processing instruction. - -=back - -=head1 Tip of the iceberg - -What we have discussed above is really the tip of the SAX iceberg. And -so far it looks like there's not much of interest to SAX beyond what we -have seen with XML::Parser. But it does go much further than that, I -promise. - -People who hate Object Oriented code for the sake of it may be thinking -here that creating a new package just to parse something is a waste -when they've been parsing things just fine up to now using procedural -code. But there's reason to all this madness. And that reason is SAX -Filters. - -As you saw right at the very start, to let the parser know about our -class, we pass it an instance of our class as the Handler to the -parser. But now imagine what would happen if our class could also take -a Handler option, and simply do some processing and pass on our data -further down the line? That in a nutshell is how SAX filters work. It's -Unix pipes for the 21st century! - -There are two downsides to this. Number 1 - writing SAX filters can be -tricky. If you look into the future and read the advanced tutorial I'm -writing, you'll see that Handler can come in several shapes and sizes. -So making sure your filter does the right thing can be tricky. -Secondly, constructing complex filter chains can be difficult, and -simple thinking tells us that we only get one pass at our document, -when often we'll need more than that. - -Luckily though, those downsides have been fixed by the release of two -very cool modules. What's even better is that I didn't write either of -them! - -The first module is XML::SAX::Base. This is a VITAL SAX module that -acts as a base class for all SAX parsers and filters. It provides an -abstraction away from calling the handler methods, that makes sure your -filter or parser does the right thing, and it does it FAST. So, if you -ever need to write a SAX filter, which if you're processing XML -> XML, -or XML -> HTML, then you probably do, then you need to be writing it as -a subclass of XML::SAX::Base. Really - this is advice not to ignore -lightly. I will not go into the details of writing a SAX filter here. -Kip Hampton, the author of XML::SAX::Base has covered this nicely in -his article on XML.com here . - -To construct SAX pipelines, Barrie Slaymaker, a long time Perl hacker -who's modules you will probably have heard of or used, wrote a very -clever module called XML::SAX::Machines. This combines some really -clever SAX filter-type modules, with a construction toolkit for filters -that makes building pipelines easy. But before we see how it makes -things easy, first lets see how tricky it looks to build complex SAX -filter pipelines. - - use XML::SAX::ParserFactory; - use XML::Filter::Filter1; - use XML::Filter::Filter2; - use XML::SAX::Writer; - - my $output_string; - my $writer = XML::SAX::Writer->new(Output => \$output_string); - my $filter2 = XML::SAX::Filter2->new(Handler => $writer); - my $filter1 = XML::SAX::Filter1->new(Handler => $filter2); - my $parser = XML::SAX::ParserFactory->parser(Handler => $filter1); - - $parser->parse_uri("foo.xml"); - -This is a lot easier with XML::SAX::Machines: - - use XML::SAX::Machines qw(Pipeline); - - my $output_string; - my $parser = Pipeline( - XML::SAX::Filter1 => XML::SAX::Filter2 => \$output_string - ); - - $parser->parse_uri("foo.xml"); - -One of the main benefits of XML::SAX::Machines is that the pipelines -are constructed in natural order, rather than the reverse order we saw -with manual pipeline construction. XML::SAX::Machines takes care of all -the internals of pipe construction, providing you at the end with just -a parser you can use (and you can re-use the same parser as many times -as you need to). - -Just a final tip. If you ever get stuck and are confused about what is -being passed from one SAX filter or parser to the next, then -Devel::TraceSAX will come to your rescue. This perl debugger plugin -will allow you to dump the SAX stream of events as it goes by. Usage is -really very simple just call your perl script that uses SAX as follows: - - $ perl -d:TraceSAX - -And preferably pipe the output to a pager of some sort, such as more or -less. The output is extremely verbose, but should help clear some -issues up. - -=head1 AUTHOR - -Matt Sergeant, matt@sergeant.org - -$Id: Intro.pod,v 1.3 2002/04/30 07:16:00 matt Exp $ - -=cut diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/ParserDetails.ini --- a/common/tools/raptor/XML/SAX/ParserDetails.ini Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -[XML::SAX::PurePerl] -http://xml.org/sax/features/namespaces = 1 - - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/ParserFactory.pm --- a/common/tools/raptor/XML/SAX/ParserFactory.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,232 +0,0 @@ -# $Id: ParserFactory.pm,v 1.13 2002/11/19 18:25:47 matt Exp $ - -package XML::SAX::ParserFactory; - -use strict; -use vars qw($VERSION); - -$VERSION = '1.01'; - -use Symbol qw(gensym); -use XML::SAX; -use XML::SAX::Exception; - -sub new { - my $class = shift; - my %params = @_; # TODO : Fix this in spec. - my $self = bless \%params, $class; - $self->{KnownParsers} = XML::SAX->parsers(); - return $self; -} - -sub parser { - my $self = shift; - my @parser_params = @_; - if (!ref($self)) { - $self = $self->new(); - } - - my $parser_class = $self->_parser_class(); - - my $version = ''; - if ($parser_class =~ s/\s*\(([\d\.]+)\)\s*$//) { - $version = " $1"; - } - - { - no strict 'refs'; - if (!keys %{"${parser_class}::"}) { - eval "use $parser_class $version;"; - } - } - - return $parser_class->new(@parser_params); -} - -sub require_feature { - my $self = shift; - my ($feature) = @_; - $self->{RequiredFeatures}{$feature}++; - return $self; -} - -sub _parser_class { - my $self = shift; - - # First try ParserPackage - if ($XML::SAX::ParserPackage) { - return $XML::SAX::ParserPackage; - } - - # Now check if required/preferred is there - if ($self->{RequiredFeatures}) { - my %required = %{$self->{RequiredFeatures}}; - # note - we never go onto the next try (ParserDetails.ini), - # because if we can't provide the requested feature - # we need to throw an exception. - PARSER: - foreach my $parser (reverse @{$self->{KnownParsers}}) { - foreach my $feature (keys %required) { - if (!exists $parser->{Features}{$feature}) { - next PARSER; - } - } - # got here - all features must exist! - return $parser->{Name}; - } - # TODO : should this be NotSupported() ? - throw XML::SAX::Exception ( - Message => "Unable to provide required features", - ); - } - - # Next try SAX.ini - for my $dir (@INC) { - my $fh = gensym(); - if (open($fh, "$dir/SAX.ini")) { - my $param_list = XML::SAX->_parse_ini_file($fh); - my $params = $param_list->[0]->{Features}; - if ($params->{ParserPackage}) { - return $params->{ParserPackage}; - } - else { - # we have required features (or nothing?) - PARSER: - foreach my $parser (reverse @{$self->{KnownParsers}}) { - foreach my $feature (keys %$params) { - if (!exists $parser->{Features}{$feature}) { - next PARSER; - } - } - return $parser->{Name}; - } - XML::SAX->do_warn("Unable to provide SAX.ini required features. Using fallback\n"); - } - last; # stop after first INI found - } - } - - if (@{$self->{KnownParsers}}) { - return $self->{KnownParsers}[-1]{Name}; - } - else { - return "XML::SAX::PurePerl"; # backup plan! - } -} - -1; -__END__ - -=head1 NAME - -XML::SAX::ParserFactory - Obtain a SAX parser - -=head1 SYNOPSIS - - use XML::SAX::ParserFactory; - use XML::SAX::XYZHandler; - my $handler = XML::SAX::XYZHandler->new(); - my $p = XML::SAX::ParserFactory->parser(Handler => $handler); - $p->parse_uri("foo.xml"); - # or $p->parse_string("") or $p->parse_file($fh); - -=head1 DESCRIPTION - -XML::SAX::ParserFactory is a factory class for providing an application -with a Perl SAX2 XML parser. It is akin to DBI - a front end for other -parser classes. Each new SAX2 parser installed will register itself -with XML::SAX, and then it will become available to all applications -that use XML::SAX::ParserFactory to obtain a SAX parser. - -Unlike DBI however, XML/SAX parsers almost all work alike (especially -if they subclass XML::SAX::Base, as they should), so rather than -specifying the parser you want in the call to C, XML::SAX -has several ways to automatically choose which parser to use: - -=over 4 - -=item * $XML::SAX::ParserPackage - -If this package variable is set, then this package is Cd -and an instance of this package is returned by calling the C -class method in that package. If it cannot be loaded or there is -an error, an exception will be thrown. The variable can also contain -a version number: - - $XML::SAX::ParserPackage = "XML::SAX::Expat (0.72)"; - -And the number will be treated as a minimum version number. - -=item * Required features - -It is possible to require features from the parsers. For example, you -may wish for a parser that supports validation via a DTD. To do that, -use the following code: - - use XML::SAX::ParserFactory; - my $factory = XML::SAX::ParserFactory->new(); - $factory->require_feature('http://xml.org/sax/features/validation'); - my $parser = $factory->parser(...); - -Alternatively, specify the required features in the call to the -ParserFactory constructor: - - my $factory = XML::SAX::ParserFactory->new( - RequiredFeatures => { - 'http://xml.org/sax/features/validation' => 1, - } - ); - -If the features you have asked for are unavailable (for example the -user might not have a validating parser installed), then an -exception will be thrown. - -The list of known parsers is searched in reverse order, so it will -always return the last installed parser that supports all of your -requested features (Note: this is subject to change if someone -comes up with a better way of making this work). - -=item * SAX.ini - -ParserFactory will search @INC for a file called SAX.ini, which -is in a simple format: - - # a comment looks like this, - ; or like this, and are stripped anywhere in the file - key = value # SAX.in contains key/value pairs. - -All whitespace is non-significant. - -This file can contain either a line: - - ParserPackage = MyParserModule (1.02) - -Where MyParserModule is the module to load and use for the parser, -and the number in brackets is a minimum version to load. - -Or you can list required features: - - http://xml.org/sax/features/validation = 1 - -And each feature with a true value will be required. - -=item * Fallback - -If none of the above works, the last parser installed on the user's -system will be used. The XML::SAX package ships with a pure perl -XML parser, XML::SAX::PurePerl, so that there will always be a -fallback parser. - -=back - -=head1 AUTHOR - -Matt Sergeant, matt@sergeant.org - -=head1 LICENSE - -This is free software, you may use it and distribute it under the same -terms as Perl itself. - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl.pm --- a/common/tools/raptor/XML/SAX/PurePerl.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,750 +0,0 @@ -# $Id: PurePerl.pm,v 1.21 2007/02/07 09:33:50 grant Exp $ - -package XML::SAX::PurePerl; - -use strict; -use vars qw/$VERSION/; - -$VERSION = '0.91'; - -use XML::SAX::PurePerl::Productions qw($Any $CharMinusDash $SingleChar); -use XML::SAX::PurePerl::Reader; -use XML::SAX::PurePerl::EncodingDetect (); -use XML::SAX::Exception; -use XML::SAX::PurePerl::DocType (); -use XML::SAX::PurePerl::DTDDecls (); -use XML::SAX::PurePerl::XMLDecl (); -use XML::SAX::DocumentLocator (); -use XML::SAX::Base (); -use XML::SAX qw(Namespaces); -use XML::NamespaceSupport (); -use IO::File; - -if ($] < 5.006) { - require XML::SAX::PurePerl::NoUnicodeExt; -} -else { - require XML::SAX::PurePerl::UnicodeExt; -} - -use vars qw(@ISA); -@ISA = ('XML::SAX::Base'); - -my %int_ents = ( - amp => '&', - lt => '<', - gt => '>', - quot => '"', - apos => "'", - ); - -my $xmlns_ns = "http://www.w3.org/2000/xmlns/"; -my $xml_ns = "http://www.w3.org/XML/1998/namespace"; - -use Carp; -sub _parse_characterstream { - my $self = shift; - my ($fh) = @_; - confess("CharacterStream is not yet correctly implemented"); - my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh); - return $self->_parse($reader); -} - -sub _parse_bytestream { - my $self = shift; - my ($fh) = @_; - my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh); - return $self->_parse($reader); -} - -sub _parse_string { - my $self = shift; - my ($str) = @_; - my $reader = XML::SAX::PurePerl::Reader::String->new($str); - return $self->_parse($reader); -} - -sub _parse_systemid { - my $self = shift; - my ($uri) = @_; - my $reader = XML::SAX::PurePerl::Reader::URI->new($uri); - return $self->_parse($reader); -} - -sub _parse { - my ($self, $reader) = @_; - - $reader->public_id($self->{ParseOptions}{Source}{PublicId}); - $reader->system_id($self->{ParseOptions}{Source}{SystemId}); - - $self->{NSHelper} = XML::NamespaceSupport->new({xmlns => 1}); - - $self->set_document_locator( - XML::SAX::DocumentLocator->new( - sub { $reader->public_id }, - sub { $reader->system_id }, - sub { $reader->line }, - sub { $reader->column }, - sub { $reader->get_encoding }, - sub { $reader->get_xml_version }, - ), - ); - - $self->start_document({}); - - if (defined $self->{ParseOptions}{Source}{Encoding}) { - $reader->set_encoding($self->{ParseOptions}{Source}{Encoding}); - } - else { - $self->encoding_detect($reader); - } - - # parse a document - $self->document($reader); - - return $self->end_document({}); -} - -sub parser_error { - my $self = shift; - my ($error, $reader) = @_; - -# warn("parser error: $error from ", $reader->line, " : ", $reader->column, "\n"); - my $exception = XML::SAX::Exception::Parse->new( - Message => $error, - ColumnNumber => $reader->column, - LineNumber => $reader->line, - PublicId => $reader->public_id, - SystemId => $reader->system_id, - ); - - $self->fatal_error($exception); - $exception->throw; -} - -sub document { - my ($self, $reader) = @_; - - # document ::= prolog element Misc* - - $self->prolog($reader); - $self->element($reader) || - $self->parser_error("Document requires an element", $reader); - - while(length($reader->data)) { - $self->Misc($reader) || - $self->parser_error("Only Comments, PIs and whitespace allowed at end of document", $reader); - } -} - -sub prolog { - my ($self, $reader) = @_; - - $self->XMLDecl($reader); - - # consume all misc bits - 1 while($self->Misc($reader)); - - if ($self->doctypedecl($reader)) { - while (length($reader->data)) { - $self->Misc($reader) || last; - } - } -} - -sub element { - my ($self, $reader) = @_; - - return 0 unless $reader->match('<'); - - my $name = $self->Name($reader) || $self->parser_error("Invalid element name", $reader); - - my %attribs; - - while( my ($k, $v) = $self->Attribute($reader) ) { - $attribs{$k} = $v; - } - - my $have_namespaces = $self->get_feature(Namespaces); - - # Namespace processing - $self->{NSHelper}->push_context; - my @new_ns; -# my %attrs = @attribs; -# while (my ($k,$v) = each %attrs) { - if ($have_namespaces) { - while ( my ($k, $v) = each %attribs ) { - if ($k =~ m/^xmlns(:(.*))?$/) { - my $prefix = $2 || ''; - $self->{NSHelper}->declare_prefix($prefix, $v); - my $ns = - { - Prefix => $prefix, - NamespaceURI => $v, - }; - push @new_ns, $ns; - $self->SUPER::start_prefix_mapping($ns); - } - } - } - - # Create element object and fire event - my %attrib_hash; - while (my ($name, $value) = each %attribs ) { - # TODO normalise value here - my ($ns, $prefix, $lname); - if ($have_namespaces) { - ($ns, $prefix, $lname) = $self->{NSHelper}->process_attribute_name($name); - } - $ns ||= ''; $prefix ||= ''; $lname ||= ''; - $attrib_hash{"{$ns}$lname"} = { - Name => $name, - LocalName => $lname, - Prefix => $prefix, - NamespaceURI => $ns, - Value => $value, - }; - } - - %attribs = (); # lose the memory since we recurse deep - - my ($ns, $prefix, $lname); - if ($self->get_feature(Namespaces)) { - ($ns, $prefix, $lname) = $self->{NSHelper}->process_element_name($name); - } - else { - $lname = $name; - } - $ns ||= ''; $prefix ||= ''; $lname ||= ''; - - # Process remainder of start_element - $self->skip_whitespace($reader); - my $have_content; - my $data = $reader->data(2); - if ($data =~ /^\/>/) { - $reader->move_along(2); - } - else { - $data =~ /^>/ or $self->parser_error("No close element tag", $reader); - $reader->move_along(1); - $have_content++; - } - - my $el = - { - Name => $name, - LocalName => $lname, - Prefix => $prefix, - NamespaceURI => $ns, - Attributes => \%attrib_hash, - }; - $self->start_element($el); - - # warn("($name\n"); - - if ($have_content) { - $self->content($reader); - - my $data = $reader->data(2); - $data =~ /^<\// or $self->parser_error("No close tag marker", $reader); - $reader->move_along(2); - my $end_name = $self->Name($reader); - $end_name eq $name || $self->parser_error("End tag mismatch ($end_name != $name)", $reader); - $self->skip_whitespace($reader); - $reader->match('>') or $self->parser_error("No close '>' on end tag", $reader); - } - - my %end_el = %$el; - delete $end_el{Attributes}; - $self->end_element(\%end_el); - - for my $ns (@new_ns) { - $self->end_prefix_mapping($ns); - } - $self->{NSHelper}->pop_context; - - return 1; -} - -sub content { - my ($self, $reader) = @_; - - while (1) { - $self->CharData($reader); - - my $data = $reader->data(2); - - if ($data =~ /^<\//) { - return 1; - } - elsif ($data =~ /^&/) { - $self->Reference($reader) or $self->parser_error("bare & not allowed in content", $reader); - next; - } - elsif ($data =~ /^CDSect($reader) - or - $self->Comment($reader)) - and next; - } - elsif ($data =~ /^<\?/) { - $self->PI($reader) and next; - } - elsif ($data =~ /^element($reader) and next; - } - last; - } - - return 1; -} - -sub CDSect { - my ($self, $reader) = @_; - - my $data = $reader->data(9); - return 0 unless $data =~ /^move_along(9); - - $self->start_cdata({}); - - $data = $reader->data; - while (1) { - $self->parser_error("EOF looking for CDATA section end", $reader) - unless length($data); - - if ($data =~ /^(.*?)\]\]>/s) { - my $chars = $1; - $reader->move_along(length($chars) + 3); - $self->characters({Data => $chars}); - last; - } - elsif ($data =~ /(.*?)\]+$/s) { - my $chars = $1; - $reader->move_along(length($chars)); - $self->characters({Data => $chars}); - $data = $reader->data(3); - } - else { - $self->characters({Data => $data}); - $reader->move_along(length($data)); - $data = $reader->data; - } - } - $self->end_cdata({}); - return 1; -} - -sub CharData { - my ($self, $reader) = @_; - - my $data = $reader->data; - - while (1) { - return unless length($data); - - if ($data =~ /^([^<&]*)[<&]/s) { - my $chars = $1; - $self->parser_error("String ']]>' not allowed in character data", $reader) - if $chars =~ /\]\]>/; - $reader->move_along(length($chars)); - $self->characters({Data => $chars}) if length($chars); - last; - } - else { - $self->characters({Data => $data}); - $reader->move_along(length($data)); - $data = $reader->data; - } - } -} - -sub Misc { - my ($self, $reader) = @_; - if ($self->Comment($reader)) { - return 1; - } - elsif ($self->PI($reader)) { - return 1; - } - elsif ($self->skip_whitespace($reader)) { - return 1; - } - - return 0; -} - -sub Reference { - my ($self, $reader) = @_; - - return 0 unless $reader->match('&'); - - my $data = $reader->data; - - if ($data =~ /^#x([0-9a-fA-F]+);/) { - my $ref = $1; - $reader->move_along(length($ref) + 3); - my $char = chr_ref(hex($ref)); - $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader) - unless $char =~ /$SingleChar/o; - $self->characters({ Data => $char }); - return 1; - } - elsif ($data =~ /^#([0-9]+);/) { - my $ref = $1; - $reader->move_along(length($ref) + 2); - my $char = chr_ref($ref); - $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader) - unless $char =~ /$SingleChar/o; - $self->characters({ Data => $char }); - return 1; - } - else { - # EntityRef - my $name = $self->Name($reader) - || $self->parser_error("Invalid name in entity", $reader); - $reader->match(';') or $self->parser_error("No semi-colon found after entity name", $reader); - - # warn("got entity: \&$name;\n"); - - # expand it - if ($self->_is_entity($name)) { - - if ($self->_is_external($name)) { - my $value = $self->_get_entity($name); - my $ent_reader = XML::SAX::PurePerl::Reader::URI->new($value); - $self->encoding_detect($ent_reader); - $self->extParsedEnt($ent_reader); - } - else { - my $value = $self->_stringify_entity($name); - my $ent_reader = XML::SAX::PurePerl::Reader::String->new($value); - $self->content($ent_reader); - } - return 1; - } - elsif ($name =~ /^(?:amp|gt|lt|quot|apos)$/) { - $self->characters({ Data => $int_ents{$name} }); - return 1; - } - else { - $self->parser_error("Undeclared entity", $reader); - } - } -} - -sub AttReference { - my ($self, $name, $reader) = @_; - if ($name =~ /^#x([0-9a-fA-F]+)$/) { - my $chr = chr_ref(hex($1)); - $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader); - return $chr; - } - elsif ($name =~ /^#([0-9]+)$/) { - my $chr = chr_ref($1); - $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader); - return $chr; - } - else { - if ($self->_is_entity($name)) { - if ($self->_is_external($name)) { - $self->parser_error("No external entity references allowed in attribute values", $reader); - } - else { - my $value = $self->_stringify_entity($name); - return $value; - } - } - elsif ($name =~ /^(?:amp|lt|gt|quot|apos)$/) { - return $int_ents{$name}; - } - else { - $self->parser_error("Undeclared entity '$name'", $reader); - } - } -} - -sub extParsedEnt { - my ($self, $reader) = @_; - - $self->TextDecl($reader); - $self->content($reader); -} - -sub _is_external { - my ($self, $name) = @_; -# TODO: Fix this to use $reader to store the entities perhaps. - if ($self->{ParseOptions}{external_entities}{$name}) { - return 1; - } - return ; -} - -sub _is_entity { - my ($self, $name) = @_; -# TODO: ditto above - if (exists $self->{ParseOptions}{entities}{$name}) { - return 1; - } - return 0; -} - -sub _stringify_entity { - my ($self, $name) = @_; -# TODO: ditto above - if (exists $self->{ParseOptions}{expanded_entity}{$name}) { - return $self->{ParseOptions}{expanded_entity}{$name}; - } - # expand - my $reader = XML::SAX::PurePerl::Reader::URI->new($self->{ParseOptions}{entities}{$name}); - my $ent = ''; - while(1) { - my $data = $reader->data; - $ent .= $data; - $reader->move_along(length($data)) or last; - } - return $self->{ParseOptions}{expanded_entity}{$name} = $ent; -} - -sub _get_entity { - my ($self, $name) = @_; -# TODO: ditto above - return $self->{ParseOptions}{entities}{$name}; -} - -sub skip_whitespace { - my ($self, $reader) = @_; - - my $data = $reader->data; - - my $found = 0; - while ($data =~ s/^([\x20\x0A\x0D\x09]*)//) { - last unless length($1); - $found++; - $reader->move_along(length($1)); - $data = $reader->data; - } - - return $found; -} - -sub Attribute { - my ($self, $reader) = @_; - - $self->skip_whitespace($reader) || return; - - my $data = $reader->data(2); - return if $data =~ /^\/?>/; - - if (my $name = $self->Name($reader)) { - $self->skip_whitespace($reader); - $reader->match('=') or $self->parser_error("No '=' in Attribute", $reader); - $self->skip_whitespace($reader); - my $value = $self->AttValue($reader); - - if (!$self->cdata_attrib($name)) { - $value =~ s/^\x20*//; # discard leading spaces - $value =~ s/\x20*$//; # discard trailing spaces - $value =~ s/ {1,}/ /g; # all >1 space to single space - } - - return $name, $value; - } - - return; -} - -sub cdata_attrib { - # TODO implement this! - return 1; -} - -sub AttValue { - my ($self, $reader) = @_; - - my $quote = $self->quote($reader); - - my $value = ''; - - while (1) { - my $data = $reader->data; - $self->parser_error("EOF found while looking for the end of attribute value", $reader) - unless length($data); - if ($data =~ /^([^$quote]*)$quote/) { - $reader->move_along(length($1) + 1); - $value .= $1; - last; - } - else { - $value .= $data; - $reader->move_along(length($data)); - } - } - - if ($value =~ /parser_error("< character not allowed in attribute values", $reader); - } - - $value =~ s/[\x09\x0A\x0D]/\x20/g; - $value =~ s/&(#(x[0-9a-fA-F]+)|([0-9]+)|\w+);/$self->AttReference($1, $reader)/geo; - - return $value; -} - -sub Comment { - my ($self, $reader) = @_; - - my $data = $reader->data(4); - if ($data =~ /^/s) { - $comment_str .= $1; - $self->parser_error("Invalid comment (dash)", $reader) if $comment_str =~ /-$/; - $reader->move_along(length($1) + 3); - last; - } - else { - $comment_str .= $data; - $reader->move_along(length($data)); - } - } - - $self->comment({ Data => $comment_str }); - - return 1; - } - return 0; -} - -sub PI { - my ($self, $reader) = @_; - - my $data = $reader->data(2); - - if ($data =~ /^<\?/) { - $reader->move_along(2); - my ($target, $data); - $target = $self->Name($reader) || - $self->parser_error("PI has no target", $reader); - if ($self->skip_whitespace($reader)) { - $target = ''; - while (1) { - my $data = $reader->data; - $self->parser_error("End of data seen while looking for close PI marker", $reader) - unless length($data); - if ($data =~ /^(.*?)\?>/s) { - $target .= $1; - $reader->move_along(length($1) + 2); - last; - } - else { - $target .= $data; - $reader->move_along(length($data)); - } - } - } - else { - my $data = $reader->data(2); - $data =~ /^\?>/ or $self->parser_error("PI closing sequence not found", $reader); - $reader->move_along(2); - } - $self->processing_instruction({ Target => $target, Data => $data }); - - return 1; - } - return 0; -} - -sub Name { - my ($self, $reader) = @_; - - my $name = ''; - while(1) { - my $data = $reader->data; - return unless length($data); - $data =~ /^([^\s>\/&\?;=<\)\(\[\],\%\#\!\*]*)/ or return; - $name .= $1; - my $len = length($1); - $reader->move_along($len); - last if ($len != length($data)); - } - - return unless length($name); - - $name =~ /$NameChar/o or $self->parser_error("Name <$name> does not match NameChar production", $reader); - - return $name; -} - -sub quote { - my ($self, $reader) = @_; - - my $data = $reader->data; - - $data =~ /^(['"])/ or $self->parser_error("Invalid quote token", $reader); - $reader->move_along(1); - return $1; -} - -1; -__END__ - -=head1 NAME - -XML::SAX::PurePerl - Pure Perl XML Parser with SAX2 interface - -=head1 SYNOPSIS - - use XML::Handler::Foo; - use XML::SAX::PurePerl; - my $handler = XML::Handler::Foo->new(); - my $parser = XML::SAX::PurePerl->new(Handler => $handler); - $parser->parse_uri("myfile.xml"); - -=head1 DESCRIPTION - -This module implements an XML parser in pure perl. It is written around the -upcoming perl 5.8's unicode support and support for multiple document -encodings (using the PerlIO layer), however it has been ported to work with -ASCII/UTF8 documents under lower perl versions. - -The SAX2 API is described in detail at http://sourceforge.net/projects/perl-xml/, in -the CVS archive, under libxml-perl/docs. Hopefully those documents will be in a -better location soon. - -Please refer to the SAX2 documentation for how to use this module - it is merely a -front end to SAX2, and implements nothing that is not in that spec (or at least tries -not to - please email me if you find errors in this implementation). - -=head1 BUGS - -XML::SAX::PurePerl is B. Very slow. I suggest you use something else -in fact. However it is great as a fallback parser for XML::SAX, where the -user might not be able to install an XS based parser or C library. - -Currently lots, probably. At the moment the weakest area is parsing DOCTYPE declarations, -though the code is in place to start doing this. Also parsing parameter entity -references is causing me much confusion, since it's not exactly what I would call -trivial, or well documented in the XML grammar. XML documents with internal subsets -are likely to fail. - -I am however trying to work towards full conformance using the Oasis test suite. - -=head1 AUTHOR - -Matt Sergeant, matt@sergeant.org. Copyright 2001. - -Please report all bugs to the Perl-XML mailing list at perl-xml@listserv.activestate.com. - -=head1 LICENSE - -This is free software. You may use it or redistribute it under the same terms as -Perl 5.7.2 itself. - -=cut - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/DTDDecls.pm --- a/common/tools/raptor/XML/SAX/PurePerl/DTDDecls.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,603 +0,0 @@ -# $Id: DTDDecls.pm,v 1.7 2005/10/14 20:31:20 matt Exp $ - -package XML::SAX::PurePerl; - -use strict; -use XML::SAX::PurePerl::Productions qw($NameChar $SingleChar); - -sub elementdecl { - my ($self, $reader) = @_; - - my $data = $reader->data(9); - return 0 unless $data =~ /^move_along(9); - - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after ELEMENT declaration", $reader); - - my $name = $self->Name($reader); - - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after ELEMENT's name", $reader); - - $self->contentspec($reader, $name); - - $self->skip_whitespace($reader); - - $reader->match('>') or $self->parser_error("Closing angle bracket not found on ELEMENT declaration", $reader); - - return 1; -} - -sub contentspec { - my ($self, $reader, $name) = @_; - - my $data = $reader->data(5); - - my $model; - if ($data =~ /^EMPTY/) { - $reader->move_along(5); - $model = 'EMPTY'; - } - elsif ($data =~ /^ANY/) { - $reader->move_along(3); - $model = 'ANY'; - } - else { - $model = $self->Mixed_or_children($reader); - } - - if ($model) { - # call SAX callback now. - $self->element_decl({Name => $name, Model => $model}); - return 1; - } - - $self->parser_error("contentspec not found in ELEMENT declaration", $reader); -} - -sub Mixed_or_children { - my ($self, $reader) = @_; - - my $data = $reader->data(8); - $data =~ /^\(/ or return; # $self->parser_error("No opening bracket in Mixed or children", $reader); - - if ($data =~ /^\(\s*\#PCDATA/) { - $reader->match('('); - $self->skip_whitespace($reader); - $reader->move_along(7); - my $model = $self->Mixed($reader); - return $model; - } - - # not matched - must be Children - return $self->children($reader); -} - -# Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' '*' ) -# | ( '(' S* PCDATA S* ')' ) -sub Mixed { - my ($self, $reader) = @_; - - # Mixed_or_children already matched '(' S* '#PCDATA' - - my $model = '(#PCDATA'; - - $self->skip_whitespace($reader); - - my %seen; - - while (1) { - last unless $reader->match('|'); - $self->skip_whitespace($reader); - - my $name = $self->Name($reader) || - $self->parser_error("No 'Name' after Mixed content '|'", $reader); - - if ($seen{$name}) { - $self->parser_error("Element '$name' has already appeared in this group", $reader); - } - $seen{$name}++; - - $model .= "|$name"; - - $self->skip_whitespace($reader); - } - - $reader->match(')') || $self->parser_error("no closing bracket on mixed content", $reader); - - $model .= ")"; - - if ($reader->match('*')) { - $model .= "*"; - } - - return $model; -} - -# [[47]] Children ::= ChoiceOrSeq Cardinality? -# [[48]] Cp ::= ( QName | ChoiceOrSeq ) Cardinality? -# ChoiceOrSeq ::= '(' S* Cp ( Choice | Seq )? S* ')' -# [[49]] Choice ::= ( S* '|' S* Cp )+ -# [[50]] Seq ::= ( S* ',' S* Cp )+ -# // Children ::= (Choice | Seq) Cardinality? -# // Cp ::= ( QName | Choice | Seq) Cardinality? -# // Choice ::= '(' S* Cp ( S* '|' S* Cp )+ S* ')' -# // Seq ::= '(' S* Cp ( S* ',' S* Cp )* S* ')' -# [[51]] Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' MixedCardinality ) -# | ( '(' S* PCDATA S* ')' ) -# Cardinality ::= '?' | '+' | '*' -# MixedCardinality ::= '*' -sub children { - my ($self, $reader) = @_; - - return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader); -} - -sub ChoiceOrSeq { - my ($self, $reader) = @_; - - $reader->match('(') or $self->parser_error("choice/seq contains no opening bracket", $reader); - - my $model = '('; - - $self->skip_whitespace($reader); - - $model .= $self->Cp($reader); - - if (my $choice = $self->Choice($reader)) { - $model .= $choice; - } - else { - $model .= $self->Seq($reader); - } - - $self->skip_whitespace($reader); - - $reader->match(')') or $self->parser_error("choice/seq contains no closing bracket", $reader); - - $model .= ')'; - - return $model; -} - -sub Cardinality { - my ($self, $reader) = @_; - # cardinality is always optional - my $data = $reader->data; - if ($data =~ /^([\?\+\*])/) { - $reader->move_along(1); - return $1; - } - return ''; -} - -sub Cp { - my ($self, $reader) = @_; - - my $model; - my $name = eval - { - if (my $name = $self->Name($reader)) { - return $name . $self->Cardinality($reader); - } - }; - return $name if defined $name; - return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader); -} - -sub Choice { - my ($self, $reader) = @_; - - my $model = ''; - $self->skip_whitespace($reader); - - while ($reader->match('|')) { - $self->skip_whitespace($reader); - $model .= '|'; - $model .= $self->Cp($reader); - $self->skip_whitespace($reader); - } - - return $model; -} - -sub Seq { - my ($self, $reader) = @_; - - my $model = ''; - $self->skip_whitespace($reader); - - while ($reader->match(',')) { - $self->skip_whitespace($reader); - my $cp = $self->Cp($reader); - if ($cp) { - $model .= ','; - $model .= $cp; - } - $self->skip_whitespace($reader); - } - - return $model; -} - -sub AttlistDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(9); - if ($data =~ /^move_along(9); - - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after ATTLIST declaration", $reader); - my $name = $self->Name($reader); - - $self->AttDefList($reader, $name); - - $self->skip_whitespace($reader); - - $reader->match('>') or $self->parser_error("Closing angle bracket not found on ATTLIST declaration", $reader); - - return 1; - } - - return 0; -} - -sub AttDefList { - my ($self, $reader, $name) = @_; - - 1 while $self->AttDef($reader, $name); -} - -sub AttDef { - my ($self, $reader, $el_name) = @_; - - $self->skip_whitespace($reader) || return 0; - my $att_name = $self->Name($reader) || return 0; - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after Name in attribute definition", $reader); - my $att_type = $self->AttType($reader); - - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after AttType in attribute definition", $reader); - my ($mode, $value) = $self->DefaultDecl($reader); - - # fire SAX event here! - $self->attribute_decl({ - eName => $el_name, - aName => $att_name, - Type => $att_type, - Mode => $mode, - Value => $value, - }); - return 1; -} - -sub AttType { - my ($self, $reader) = @_; - - return $self->StringType($reader) || - $self->TokenizedType($reader) || - $self->EnumeratedType($reader) || - $self->parser_error("Can't match AttType", $reader); -} - -sub StringType { - my ($self, $reader) = @_; - - my $data = $reader->data(5); - return unless $data =~ /^CDATA/; - $reader->move_along(5); - return 'CDATA'; -} - -sub TokenizedType { - my ($self, $reader) = @_; - - my $data = $reader->data(8); - if ($data =~ /^(IDREFS?|ID|ENTITIES|ENTITY|NMTOKENS?)/) { - $reader->move_along(length($1)); - return $1; - } - return; -} - -sub EnumeratedType { - my ($self, $reader) = @_; - return $self->NotationType($reader) || $self->Enumeration($reader); -} - -sub NotationType { - my ($self, $reader) = @_; - - my $data = $reader->data(8); - return unless $data =~ /^NOTATION/; - $reader->move_along(8); - - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after NOTATION", $reader); - $reader->match('(') or $self->parser_error("No opening bracket in notation section", $reader); - - $self->skip_whitespace($reader); - my $model = 'NOTATION ('; - my $name = $self->Name($reader) || - $self->parser_error("No name in notation section", $reader); - $model .= $name; - $self->skip_whitespace($reader); - $data = $reader->data; - while ($data =~ /^\|/) { - $reader->move_along(1); - $model .= '|'; - $self->skip_whitespace($reader); - my $name = $self->Name($reader) || - $self->parser_error("No name in notation section", $reader); - $model .= $name; - $self->skip_whitespace($reader); - $data = $reader->data; - } - $data =~ /^\)/ or $self->parser_error("No closing bracket in notation section", $reader); - $reader->move_along(1); - - $model .= ')'; - - return $model; -} - -sub Enumeration { - my ($self, $reader) = @_; - - return unless $reader->match('('); - - $self->skip_whitespace($reader); - my $model = '('; - my $nmtoken = $self->Nmtoken($reader) || - $self->parser_error("No Nmtoken in enumerated declaration", $reader); - $model .= $nmtoken; - $self->skip_whitespace($reader); - my $data = $reader->data; - while ($data =~ /^\|/) { - $model .= '|'; - $reader->move_along(1); - $self->skip_whitespace($reader); - my $nmtoken = $self->Nmtoken($reader) || - $self->parser_error("No Nmtoken in enumerated declaration", $reader); - $model .= $nmtoken; - $self->skip_whitespace($reader); - $data = $reader->data; - } - $data =~ /^\)/ or $self->parser_error("No closing bracket in enumerated declaration", $reader); - $reader->move_along(1); - - $model .= ')'; - - return $model; -} - -sub Nmtoken { - my ($self, $reader) = @_; - return $self->Name($reader); -} - -sub DefaultDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(9); - if ($data =~ /^(\#REQUIRED|\#IMPLIED)/) { - $reader->move_along(length($1)); - return $1; - } - my $model = ''; - if ($data =~ /^\#FIXED/) { - $reader->move_along(6); - $self->skip_whitespace($reader) || $self->parser_error( - "no whitespace after FIXED specifier", $reader); - my $value = $self->AttValue($reader); - return "#FIXED", $value; - } - my $value = $self->AttValue($reader); - return undef, $value; -} - -sub EntityDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(8); - return 0 unless $data =~ /^move_along(8); - - $self->skip_whitespace($reader) || $self->parser_error( - "No whitespace after ENTITY declaration", $reader); - - $self->PEDecl($reader) || $self->GEDecl($reader); - - $self->skip_whitespace($reader); - - $reader->match('>') or $self->parser_error("No closing '>' in entity definition", $reader); - - return 1; -} - -sub GEDecl { - my ($self, $reader) = @_; - - my $name = $self->Name($reader) || $self->parser_error("No entity name given", $reader); - $self->skip_whitespace($reader) || $self->parser_error("No whitespace after entity name", $reader); - - # TODO: ExternalID calls lexhandler method. Wrong place for it. - my $value; - if ($value = $self->ExternalID($reader)) { - $value .= $self->NDataDecl($reader); - } - else { - $value = $self->EntityValue($reader); - } - - if ($self->{ParseOptions}{entities}{$name}) { - warn("entity $name already exists\n"); - } else { - $self->{ParseOptions}{entities}{$name} = 1; - $self->{ParseOptions}{expanded_entity}{$name} = $value; # ??? - } - # do callback? - return 1; -} - -sub PEDecl { - my ($self, $reader) = @_; - - return 0 unless $reader->match('%'); - - $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity marker", $reader); - my $name = $self->Name($reader) || $self->parser_error("No parameter entity name given", $reader); - $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity name", $reader); - my $value = $self->ExternalID($reader) || - $self->EntityValue($reader) || - $self->parser_error("PE is not a value or an external resource", $reader); - # do callback? - return 1; -} - -my $quotre = qr/[^%&\"]/; -my $aposre = qr/[^%&\']/; - -sub EntityValue { - my ($self, $reader) = @_; - - my $data = $reader->data; - my $quote = '"'; - my $re = $quotre; - if (!$data =~ /^"/) { - $data =~ /^'/ or $self->parser_error("Not a quote character", $reader); - $quote = "'"; - $re = $aposre; - } - $reader->move_along(1); - - my $value = ''; - - while (1) { - my $data = $reader->data; - - $self->parser_error("EOF found while reading entity value", $reader) - unless length($data); - - if ($data =~ /^($re+)/) { - my $match = $1; - $value .= $match; - $reader->move_along(length($match)); - } - elsif ($reader->match('&')) { - # if it's a char ref, expand now: - if ($reader->match('#')) { - my $char; - my $ref = ''; - if ($reader->match('x')) { - my $data = $reader->data; - while (1) { - $self->parser_error("EOF looking for reference end", $reader) - unless length($data); - if ($data !~ /^([0-9a-fA-F]*)/) { - last; - } - $ref .= $1; - $reader->move_along(length($1)); - if (length($1) == length($data)) { - $data = $reader->data; - } - else { - last; - } - } - $char = chr_ref(hex($ref)); - $ref = "x$ref"; - } - else { - my $data = $reader->data; - while (1) { - $self->parser_error("EOF looking for reference end", $reader) - unless length($data); - if ($data !~ /^([0-9]*)/) { - last; - } - $ref .= $1; - $reader->move_along(length($1)); - if (length($1) == length($data)) { - $data = $reader->data; - } - else { - last; - } - } - $char = chr($ref); - } - $reader->match(';') || - $self->parser_error("No semi-colon found after character reference", $reader); - if ($char !~ $SingleChar) { # match a single character - $self->parser_error("Character reference '&#$ref;' refers to an illegal XML character ($char)", $reader); - } - $value .= $char; - } - else { - # entity refs in entities get expanded later, so don't parse now. - $value .= '&'; - } - } - elsif ($reader->match('%')) { - $value .= $self->PEReference($reader); - } - elsif ($reader->match($quote)) { - # end of attrib - last; - } - else { - $self->parser_error("Invalid character in attribute value: " . substr($reader->data, 0, 1), $reader); - } - } - - return $value; -} - -sub NDataDecl { - my ($self, $reader) = @_; - $self->skip_whitespace($reader) || return ''; - my $data = $reader->data(5); - return '' unless $data =~ /^NDATA/; - $reader->move_along(5); - $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NDATA declaration", $reader); - my $name = $self->Name($reader) || $self->parser_error("NDATA declaration lacks a proper Name", $reader); - return " NDATA $name"; -} - -sub NotationDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(10); - return 0 unless $data =~ /^move_along(10); - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after NOTATION declaration", $reader); - $data = $reader->data; - my $value = ''; - while(1) { - $self->parser_error("EOF found while looking for end of NotationDecl", $reader) - unless length($data); - - if ($data =~ /^([^>]*)>/) { - $value .= $1; - $reader->move_along(length($1) + 1); - $self->notation_decl({Name => "FIXME", SystemId => "FIXME", PublicId => "FIXME" }); - last; - } - else { - $value .= $data; - $reader->move_along(length($data)); - $data = $reader->data; - } - } - return 1; -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/DebugHandler.pm --- a/common/tools/raptor/XML/SAX/PurePerl/DebugHandler.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,95 +0,0 @@ -# $Id: DebugHandler.pm,v 1.3 2001/11/24 17:47:53 matt Exp $ - -package XML::SAX::PurePerl::DebugHandler; - -use strict; - -sub new { - my $class = shift; - my %opts = @_; - return bless \%opts, $class; -} - -# DocumentHandler - -sub set_document_locator { - my $self = shift; - print "set_document_locator\n" if $ENV{DEBUG_XML}; - $self->{seen}{set_document_locator}++; -} - -sub start_document { - my $self = shift; - print "start_document\n" if $ENV{DEBUG_XML}; - $self->{seen}{start_document}++; -} - -sub end_document { - my $self = shift; - print "end_document\n" if $ENV{DEBUG_XML}; - $self->{seen}{end_document}++; -} - -sub start_element { - my $self = shift; - print "start_element\n" if $ENV{DEBUG_XML}; - $self->{seen}{start_element}++; -} - -sub end_element { - my $self = shift; - print "end_element\n" if $ENV{DEBUG_XML}; - $self->{seen}{end_element}++; -} - -sub characters { - my $self = shift; - print "characters\n" if $ENV{DEBUG_XML}; -# warn "Char: ", $_[0]->{Data}, "\n"; - $self->{seen}{characters}++; -} - -sub processing_instruction { - my $self = shift; - print "processing_instruction\n" if $ENV{DEBUG_XML}; - $self->{seen}{processing_instruction}++; -} - -sub ignorable_whitespace { - my $self = shift; - print "ignorable_whitespace\n" if $ENV{DEBUG_XML}; - $self->{seen}{ignorable_whitespace}++; -} - -# LexHandler - -sub comment { - my $self = shift; - print "comment\n" if $ENV{DEBUG_XML}; - $self->{seen}{comment}++; -} - -# DTDHandler - -sub notation_decl { - my $self = shift; - print "notation_decl\n" if $ENV{DEBUG_XML}; - $self->{seen}{notation_decl}++; -} - -sub unparsed_entity_decl { - my $self = shift; - print "unparsed_entity_decl\n" if $ENV{DEBUG_XML}; - $self->{seen}{entity_decl}++; -} - -# EntityResolver - -sub resolve_entity { - my $self = shift; - print "resolve_entity\n" if $ENV{DEBUG_XML}; - $self->{seen}{resolve_entity}++; - return ''; -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/DocType.pm --- a/common/tools/raptor/XML/SAX/PurePerl/DocType.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,180 +0,0 @@ -# $Id: DocType.pm,v 1.3 2003/07/30 13:39:22 matt Exp $ - -package XML::SAX::PurePerl; - -use strict; -use XML::SAX::PurePerl::Productions qw($PubidChar); - -sub doctypedecl { - my ($self, $reader) = @_; - - my $data = $reader->data(9); - if ($data =~ /^move_along(9); - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after doctype declaration", $reader); - - my $root_name = $self->Name($reader) || - $self->parser_error("Doctype declaration has no root element name", $reader); - - if ($self->skip_whitespace($reader)) { - # might be externalid... - my %dtd = $self->ExternalID($reader); - # TODO: Call SAX event - } - - $self->skip_whitespace($reader); - - $self->InternalSubset($reader); - - $reader->match('>') or $self->parser_error("Doctype not closed", $reader); - - return 1; - } - - return 0; -} - -sub ExternalID { - my ($self, $reader) = @_; - - my $data = $reader->data(6); - - if ($data =~ /^SYSTEM/) { - $reader->move_along(6); - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after SYSTEM identifier", $reader); - return (SYSTEM => $self->SystemLiteral($reader)); - } - elsif ($data =~ /^PUBLIC/) { - $reader->move_along(6); - $self->skip_whitespace($reader) || - $self->parser_error("No whitespace after PUBLIC identifier", $reader); - - my $quote = $self->quote($reader) || - $self->parser_error("Not a quote character in PUBLIC identifier", $reader); - - my $data = $reader->data; - my $pubid = ''; - while(1) { - $self->parser_error("EOF while looking for end of PUBLIC identifiier", $reader) - unless length($data); - - if ($data =~ /^([^$quote]*)$quote/) { - $pubid .= $1; - $reader->move_along(length($1) + 1); - last; - } - else { - $pubid .= $data; - $reader->move_along(length($data)); - $data = $reader->data; - } - } - - if ($pubid !~ /^($PubidChar)+$/) { - $self->parser_error("Invalid characters in PUBLIC identifier", $reader); - } - - $self->skip_whitespace($reader) || - $self->parser_error("Not whitespace after PUBLIC ID in DOCTYPE", $reader); - - return (PUBLIC => $pubid, - SYSTEM => $self->SystemLiteral($reader)); - } - else { - return; - } - - return 1; -} - -sub SystemLiteral { - my ($self, $reader) = @_; - - my $quote = $self->quote($reader); - - my $data = $reader->data; - my $systemid = ''; - while (1) { - $self->parser_error("EOF found while looking for end of Sytem Literal", $reader) - unless length($data); - if ($data =~ /^([^$quote]*)$quote/) { - $systemid .= $1; - $reader->move_along(length($1) + 1); - return $systemid; - } - else { - $systemid .= $data; - $reader->move_along(length($data)); - $data = $reader->data; - } - } -} - -sub InternalSubset { - my ($self, $reader) = @_; - - return 0 unless $reader->match('['); - - 1 while $self->IntSubsetDecl($reader); - - $reader->match(']') or $self->parser_error("No close bracket on internal subset (found: " . $reader->data, $reader); - $self->skip_whitespace($reader); - return 1; -} - -sub IntSubsetDecl { - my ($self, $reader) = @_; - - return $self->DeclSep($reader) || $self->markupdecl($reader); -} - -sub DeclSep { - my ($self, $reader) = @_; - - if ($self->skip_whitespace($reader)) { - return 1; - } - - if ($self->PEReference($reader)) { - return 1; - } - -# if ($self->ParsedExtSubset($reader)) { -# return 1; -# } - - return 0; -} - -sub PEReference { - my ($self, $reader) = @_; - - return 0 unless $reader->match('%'); - - my $peref = $self->Name($reader) || - $self->parser_error("PEReference did not find a Name", $reader); - # TODO - load/parse the peref - - $reader->match(';') or $self->parser_error("Invalid token in PEReference", $reader); - return 1; -} - -sub markupdecl { - my ($self, $reader) = @_; - - if ($self->elementdecl($reader) || - $self->AttlistDecl($reader) || - $self->EntityDecl($reader) || - $self->NotationDecl($reader) || - $self->PI($reader) || - $self->Comment($reader)) - { - return 1; - } - - return 0; -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/EncodingDetect.pm --- a/common/tools/raptor/XML/SAX/PurePerl/EncodingDetect.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,105 +0,0 @@ -# $Id: EncodingDetect.pm,v 1.6 2007/02/07 09:33:50 grant Exp $ - -package XML::SAX::PurePerl; # NB, not ::EncodingDetect! - -use strict; - -sub encoding_detect { - my ($parser, $reader) = @_; - - my $error = "Invalid byte sequence at start of file"; - - my $data = $reader->data; - if ($data =~ /^\x00\x00\xFE\xFF/) { - # BO-UCS4-be - $reader->move_along(4); - $reader->set_encoding('UCS-4BE'); - return; - } - elsif ($data =~ /^\x00\x00\xFF\xFE/) { - # BO-UCS-4-2143 - $reader->move_along(4); - $reader->set_encoding('UCS-4-2143'); - return; - } - elsif ($data =~ /^\x00\x00\x00\x3C/) { - $reader->set_encoding('UCS-4BE'); - return; - } - elsif ($data =~ /^\x00\x00\x3C\x00/) { - $reader->set_encoding('UCS-4-2143'); - return; - } - elsif ($data =~ /^\x00\x3C\x00\x00/) { - $reader->set_encoding('UCS-4-3412'); - return; - } - elsif ($data =~ /^\x00\x3C\x00\x3F/) { - $reader->set_encoding('UTF-16BE'); - return; - } - elsif ($data =~ /^\xFF\xFE\x00\x00/) { - # BO-UCS-4LE - $reader->move_along(4); - $reader->set_encoding('UCS-4LE'); - return; - } - elsif ($data =~ /^\xFF\xFE/) { - $reader->move_along(2); - $reader->set_encoding('UTF-16LE'); - return; - } - elsif ($data =~ /^\xFE\xFF\x00\x00/) { - $reader->move_along(4); - $reader->set_encoding('UCS-4-3412'); - return; - } - elsif ($data =~ /^\xFE\xFF/) { - $reader->move_along(2); - $reader->set_encoding('UTF-16BE'); - return; - } - elsif ($data =~ /^\xEF\xBB\xBF/) { # UTF-8 BOM - $reader->move_along(3); - $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^\x3C\x00\x00\x00/) { - $reader->set_encoding('UCS-4LE'); - return; - } - elsif ($data =~ /^\x3C\x00\x3F\x00/) { - $reader->set_encoding('UTF-16LE'); - return; - } - elsif ($data =~ /^\x3C\x3F\x78\x6D/) { - # $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^\x3C\x3F\x78/) { - # $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^\x3C\x3F/) { - # $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^\x3C/) { - # $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^[\x20\x09\x0A\x0D]+\x3C[^\x3F]/) { - # $reader->set_encoding('UTF-8'); - return; - } - elsif ($data =~ /^\x4C\x6F\xA7\x94/) { - $reader->set_encoding('EBCDIC'); - return; - } - - warn("Unable to recognise encoding of this document"); - return; -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Exception.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Exception.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,67 +0,0 @@ -# $Id: Exception.pm,v 1.2 2001/11/14 11:07:25 matt Exp $ - -package XML::SAX::PurePerl::Exception; - -use strict; - -use overload '""' => "stringify"; - -use vars qw/$StackTrace/; - -$StackTrace = $ENV{XML_DEBUG} || 0; - -sub throw { - my $class = shift; - die $class->new(@_); -} - -sub new { - my $class = shift; - my %opts = @_; - die "Invalid options" unless exists $opts{Message}; - - if ($opts{reader}) { - return bless { Message => $opts{Message}, - Exception => undef, # not sure what this is for!!! - ColumnNumber => $opts{reader}->column, - LineNumber => $opts{reader}->line, - PublicId => $opts{reader}->public_id, - SystemId => $opts{reader}->system_id, - $StackTrace ? (StackTrace => stacktrace()) : (), - }, $class; - } - return bless { Message => $opts{Message}, - Exception => undef, # not sure what this is for!!! - }, $class; -} - -sub stringify { - my $self = shift; - local $^W; - return $self->{Message} . " [Ln: " . $self->{LineNumber} . - ", Col: " . $self->{ColumnNumber} . "]" . - ($StackTrace ? stackstring($self->{StackTrace}) : "") . "\n"; -} - -sub stacktrace { - my $i = 2; - my @fulltrace; - while (my @trace = caller($i++)) { - my %hash; - @hash{qw(Package Filename Line)} = @trace[0..2]; - push @fulltrace, \%hash; - } - return \@fulltrace; -} - -sub stackstring { - my $stacktrace = shift; - my $string = "\nFrom:\n"; - foreach my $current (@$stacktrace) { - $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n"; - } - return $string; -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/NoUnicodeExt.pm --- a/common/tools/raptor/XML/SAX/PurePerl/NoUnicodeExt.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,28 +0,0 @@ -# $Id: NoUnicodeExt.pm,v 1.1 2002/01/30 17:35:21 matt Exp $ - -package XML::SAX::PurePerl; -use strict; - -sub chr_ref { - my $n = shift; - if ($n < 0x80) { - return chr ($n); - } - elsif ($n < 0x800) { - return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80)); - } - elsif ($n < 0x10000) { - return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80), - (($n & 0x3f) | 0x80)); - } - elsif ($n < 0x110000) - { - return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80), - ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80)); - } - else { - return undef; - } -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Productions.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Productions.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,151 +0,0 @@ -# $Id: Productions.pm,v 1.11 2003/07/30 13:39:22 matt Exp $ - -package XML::SAX::PurePerl::Productions; - -use Exporter; -@ISA = ('Exporter'); -@EXPORT_OK = qw($S $Char $VersionNum $BaseChar $Letter $Ideographic - $Extender $Digit $CombiningChar $EncNameStart $EncNameEnd $NameChar $CharMinusDash - $PubidChar $Any $SingleChar); - -### WARNING!!! All productions here must *only* match a *single* character!!! ### - -BEGIN { -$S = qr/[\x20\x09\x0D\x0A]/; - -$CharMinusDash = qr/[^-]/x; - -$Any = qr/ . /xms; - -$VersionNum = qr/ [a-zA-Z0-9_.:-]+ /x; - -$EncNameStart = qr/ [A-Za-z] /x; -$EncNameEnd = qr/ [A-Za-z0-9\._-] /x; - -$PubidChar = qr/ [\x20\x0D\x0Aa-zA-Z0-9'()\+,.\/:=\?;!*\#@\$_\%-] /x; - -if ($] < 5.006) { - eval <<' PERL'; - $Char = qr/^ [\x09\x0A\x0D\x20-\x7F]|([\xC0-\xFD][\x80-\xBF]+) $/x; - - $SingleChar = qr/^$Char$/; - - $BaseChar = qr/ [\x41-\x5A\x61-\x7A]|([\xC0-\xFD][\x80-\xBF]+) /x; - - $Extender = qr/ \xB7 /x; - - $Digit = qr/ [\x30-\x39] /x; - - $Letter = qr/^ $BaseChar $/x; - - # can't do this one without unicode - # $CombiningChar = qr/^$/msx; - - $NameChar = qr/^ $BaseChar | $Digit | [._:-] | $Extender $/x; - PERL - die $@ if $@; -} -else { - eval <<' PERL'; - - use utf8; # for 5.6 - - $Char = qr/^ [\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}] $/x; - - $SingleChar = qr/^$Char$/; - - $BaseChar = qr/ -[\x{0041}-\x{005A}\x{0061}-\x{007A}\x{00C0}-\x{00D6}\x{00D8}-\x{00F6}] | -[\x{00F8}-\x{00FF}\x{0100}-\x{0131}\x{0134}-\x{013E}\x{0141}-\x{0148}] | -[\x{014A}-\x{017E}\x{0180}-\x{01C3}\x{01CD}-\x{01F0}\x{01F4}-\x{01F5}] | -[\x{01FA}-\x{0217}\x{0250}-\x{02A8}\x{02BB}-\x{02C1}\x{0386}\x{0388}-\x{038A}] | -[\x{038C}\x{038E}-\x{03A1}\x{03A3}-\x{03CE}\x{03D0}-\x{03D6}\x{03DA}] | -[\x{03DC}\x{03DE}\x{03E0}\x{03E2}-\x{03F3}\x{0401}-\x{040C}\x{040E}-\x{044F}] | -[\x{0451}-\x{045C}\x{045E}-\x{0481}\x{0490}-\x{04C4}\x{04C7}-\x{04C8}] | -[\x{04CB}-\x{04CC}\x{04D0}-\x{04EB}\x{04EE}-\x{04F5}\x{04F8}-\x{04F9}] | -[\x{0531}-\x{0556}\x{0559}\x{0561}-\x{0586}\x{05D0}-\x{05EA}\x{05F0}-\x{05F2}] | -[\x{0621}-\x{063A}\x{0641}-\x{064A}\x{0671}-\x{06B7}\x{06BA}-\x{06BE}] | -[\x{06C0}-\x{06CE}\x{06D0}-\x{06D3}\x{06D5}\x{06E5}-\x{06E6}\x{0905}-\x{0939}] | -[\x{093D}\x{0958}-\x{0961}\x{0985}-\x{098C}\x{098F}-\x{0990}] | -[\x{0993}-\x{09A8}\x{09AA}-\x{09B0}\x{09B2}\x{09B6}-\x{09B9}\x{09DC}-\x{09DD}] | -[\x{09DF}-\x{09E1}\x{09F0}-\x{09F1}\x{0A05}-\x{0A0A}\x{0A0F}-\x{0A10}] | -[\x{0A13}-\x{0A28}\x{0A2A}-\x{0A30}\x{0A32}-\x{0A33}\x{0A35}-\x{0A36}] | -[\x{0A38}-\x{0A39}\x{0A59}-\x{0A5C}\x{0A5E}\x{0A72}-\x{0A74}\x{0A85}-\x{0A8B}] | -[\x{0A8D}\x{0A8F}-\x{0A91}\x{0A93}-\x{0AA8}\x{0AAA}-\x{0AB0}] | -[\x{0AB2}-\x{0AB3}\x{0AB5}-\x{0AB9}\x{0ABD}\x{0AE0}\x{0B05}-\x{0B0C}] | -[\x{0B0F}-\x{0B10}\x{0B13}-\x{0B28}\x{0B2A}-\x{0B30}\x{0B32}-\x{0B33}] | -[\x{0B36}-\x{0B39}\x{0B3D}\x{0B5C}-\x{0B5D}\x{0B5F}-\x{0B61}\x{0B85}-\x{0B8A}] | -[\x{0B8E}-\x{0B90}\x{0B92}-\x{0B95}\x{0B99}-\x{0B9A}\x{0B9C}] | -[\x{0B9E}-\x{0B9F}\x{0BA3}-\x{0BA4}\x{0BA8}-\x{0BAA}\x{0BAE}-\x{0BB5}] | -[\x{0BB7}-\x{0BB9}\x{0C05}-\x{0C0C}\x{0C0E}-\x{0C10}\x{0C12}-\x{0C28}] | -[\x{0C2A}-\x{0C33}\x{0C35}-\x{0C39}\x{0C60}-\x{0C61}\x{0C85}-\x{0C8C}] | -[\x{0C8E}-\x{0C90}\x{0C92}-\x{0CA8}\x{0CAA}-\x{0CB3}\x{0CB5}-\x{0CB9}\x{0CDE}] | -[\x{0CE0}-\x{0CE1}\x{0D05}-\x{0D0C}\x{0D0E}-\x{0D10}\x{0D12}-\x{0D28}] | -[\x{0D2A}-\x{0D39}\x{0D60}-\x{0D61}\x{0E01}-\x{0E2E}\x{0E30}\x{0E32}-\x{0E33}] | -[\x{0E40}-\x{0E45}\x{0E81}-\x{0E82}\x{0E84}\x{0E87}-\x{0E88}\x{0E8A}] | -[\x{0E8D}\x{0E94}-\x{0E97}\x{0E99}-\x{0E9F}\x{0EA1}-\x{0EA3}\x{0EA5}\x{0EA7}] | -[\x{0EAA}-\x{0EAB}\x{0EAD}-\x{0EAE}\x{0EB0}\x{0EB2}-\x{0EB3}\x{0EBD}] | -[\x{0EC0}-\x{0EC4}\x{0F40}-\x{0F47}\x{0F49}-\x{0F69}\x{10A0}-\x{10C5}] | -[\x{10D0}-\x{10F6}\x{1100}\x{1102}-\x{1103}\x{1105}-\x{1107}\x{1109}] | -[\x{110B}-\x{110C}\x{110E}-\x{1112}\x{113C}\x{113E}\x{1140}\x{114C}\x{114E}] | -[\x{1150}\x{1154}-\x{1155}\x{1159}\x{115F}-\x{1161}\x{1163}\x{1165}] | -[\x{1167}\x{1169}\x{116D}-\x{116E}\x{1172}-\x{1173}\x{1175}\x{119E}\x{11A8}] | -[\x{11AB}\x{11AE}-\x{11AF}\x{11B7}-\x{11B8}\x{11BA}\x{11BC}-\x{11C2}] | -[\x{11EB}\x{11F0}\x{11F9}\x{1E00}-\x{1E9B}\x{1EA0}-\x{1EF9}\x{1F00}-\x{1F15}] | -[\x{1F18}-\x{1F1D}\x{1F20}-\x{1F45}\x{1F48}-\x{1F4D}\x{1F50}-\x{1F57}] | -[\x{1F59}\x{1F5B}\x{1F5D}\x{1F5F}-\x{1F7D}\x{1F80}-\x{1FB4}\x{1FB6}-\x{1FBC}] | -[\x{1FBE}\x{1FC2}-\x{1FC4}\x{1FC6}-\x{1FCC}\x{1FD0}-\x{1FD3}] | -[\x{1FD6}-\x{1FDB}\x{1FE0}-\x{1FEC}\x{1FF2}-\x{1FF4}\x{1FF6}-\x{1FFC}] | -[\x{2126}\x{212A}-\x{212B}\x{212E}\x{2180}-\x{2182}\x{3041}-\x{3094}] | -[\x{30A1}-\x{30FA}\x{3105}-\x{312C}\x{AC00}-\x{D7A3}] - /x; - - $Extender = qr/ -[\x{00B7}\x{02D0}\x{02D1}\x{0387}\x{0640}\x{0E46}\x{0EC6}\x{3005}\x{3031}-\x{3035}\x{309D}-\x{309E}\x{30FC}-\x{30FE}] -/x; - - $Digit = qr/ -[\x{0030}-\x{0039}\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{0966}-\x{096F}] | -[\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}] | -[\x{0BE7}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}] | -[\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}] -/x; - - $CombiningChar = qr/ -[\x{0300}-\x{0345}\x{0360}-\x{0361}\x{0483}-\x{0486}\x{0591}-\x{05A1}] | -[\x{05A3}-\x{05B9}\x{05BB}-\x{05BD}\x{05BF}\x{05C1}-\x{05C2}\x{05C4}] | -[\x{064B}-\x{0652}\x{0670}\x{06D6}-\x{06DC}\x{06DD}-\x{06DF}\x{06E0}-\x{06E4}] | -[\x{06E7}-\x{06E8}\x{06EA}-\x{06ED}\x{0901}-\x{0903}\x{093C}] | -[\x{093E}-\x{094C}\x{094D}\x{0951}-\x{0954}\x{0962}-\x{0963}\x{0981}-\x{0983}] | -[\x{09BC}\x{09BE}\x{09BF}\x{09C0}-\x{09C4}\x{09C7}-\x{09C8}] | -[\x{09CB}-\x{09CD}\x{09D7}\x{09E2}-\x{09E3}\x{0A02}\x{0A3C}\x{0A3E}\x{0A3F}] | -[\x{0A40}-\x{0A42}\x{0A47}-\x{0A48}\x{0A4B}-\x{0A4D}\x{0A70}-\x{0A71}] | -[\x{0A81}-\x{0A83}\x{0ABC}\x{0ABE}-\x{0AC5}\x{0AC7}-\x{0AC9}\x{0ACB}-\x{0ACD}] | -[\x{0B01}-\x{0B03}\x{0B3C}\x{0B3E}-\x{0B43}\x{0B47}-\x{0B48}] | -[\x{0B4B}-\x{0B4D}\x{0B56}-\x{0B57}\x{0B82}-\x{0B83}\x{0BBE}-\x{0BC2}] | -[\x{0BC6}-\x{0BC8}\x{0BCA}-\x{0BCD}\x{0BD7}\x{0C01}-\x{0C03}\x{0C3E}-\x{0C44}] | -[\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}-\x{0C56}\x{0C82}-\x{0C83}] | -[\x{0CBE}-\x{0CC4}\x{0CC6}-\x{0CC8}\x{0CCA}-\x{0CCD}\x{0CD5}-\x{0CD6}] | -[\x{0D02}-\x{0D03}\x{0D3E}-\x{0D43}\x{0D46}-\x{0D48}\x{0D4A}-\x{0D4D}\x{0D57}] | -[\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}] | -[\x{0EBB}-\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}-\x{0F19}\x{0F35}\x{0F37}\x{0F39}] | -[\x{0F3E}\x{0F3F}\x{0F71}-\x{0F84}\x{0F86}-\x{0F8B}\x{0F90}-\x{0F95}] | -[\x{0F97}\x{0F99}-\x{0FAD}\x{0FB1}-\x{0FB7}\x{0FB9}\x{20D0}-\x{20DC}\x{20E1}] | -[\x{302A}-\x{302F}\x{3099}\x{309A}] -/x; - - $Ideographic = qr/ -[\x{4E00}-\x{9FA5}\x{3007}\x{3021}-\x{3029}] -/x; - - $Letter = qr/^ $BaseChar | $Ideographic $/x; - - $NameChar = qr/^ $Letter | $Digit | [._:-] | $CombiningChar | $Extender $/x; - PERL - - die $@ if $@; -} - -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,137 +0,0 @@ -# $Id: Reader.pm,v 1.11 2005/10/14 20:31:20 matt Exp $ - -package XML::SAX::PurePerl::Reader; - -use strict; -use XML::SAX::PurePerl::Reader::URI; -use XML::SAX::PurePerl::Productions qw( $SingleChar $Letter $NameChar ); -use Exporter (); - -use vars qw(@ISA @EXPORT_OK); -@ISA = qw(Exporter); -@EXPORT_OK = qw( - EOF - BUFFER - LINE - COLUMN - ENCODING - XML_VERSION -); - -use constant EOF => 0; -use constant BUFFER => 1; -use constant LINE => 2; -use constant COLUMN => 3; -use constant ENCODING => 4; -use constant SYSTEM_ID => 5; -use constant PUBLIC_ID => 6; -use constant XML_VERSION => 7; - -require XML::SAX::PurePerl::Reader::Stream; -require XML::SAX::PurePerl::Reader::String; - -if ($] >= 5.007002) { - require XML::SAX::PurePerl::Reader::UnicodeExt; -} -else { - require XML::SAX::PurePerl::Reader::NoUnicodeExt; -} - -sub new { - my $class = shift; - my $thing = shift; - - # try to figure if this $thing is a handle of some sort - if (ref($thing) && UNIVERSAL::isa($thing, 'IO::Handle')) { - return XML::SAX::PurePerl::Reader::Stream->new($thing)->init; - } - my $ioref; - if (tied($thing)) { - my $class = ref($thing); - no strict 'refs'; - $ioref = $thing if defined &{"${class}::TIEHANDLE"}; - } - else { - eval { - $ioref = *{$thing}{IO}; - }; - undef $@; - } - if ($ioref) { - return XML::SAX::PurePerl::Reader::Stream->new($thing)->init; - } - - if ($thing =~ /new($thing)->init; - } - - # assume it is a uri - return XML::SAX::PurePerl::Reader::URI->new($thing)->init; -} - -sub init { - my $self = shift; - $self->[LINE] = 1; - $self->[COLUMN] = 1; - $self->read_more; - return $self; -} - -sub data { - my ($self, $min_length) = (@_, 1); - if (length($self->[BUFFER]) < $min_length) { - $self->read_more; - } - return $self->[BUFFER]; -} - -sub match { - my ($self, $char) = @_; - my $data = $self->data; - if (substr($data, 0, 1) eq $char) { - $self->move_along(1); - return 1; - } - return 0; -} - -sub public_id { - my $self = shift; - @_ and $self->[PUBLIC_ID] = shift; - $self->[PUBLIC_ID]; -} - -sub system_id { - my $self = shift; - @_ and $self->[SYSTEM_ID] = shift; - $self->[SYSTEM_ID]; -} - -sub line { - shift->[LINE]; -} - -sub column { - shift->[COLUMN]; -} - -sub get_encoding { - my $self = shift; - return $self->[ENCODING]; -} - -sub get_xml_version { - my $self = shift; - return $self->[XML_VERSION]; -} - -1; - -__END__ - -=head1 NAME - -XML::Parser::PurePerl::Reader - Abstract Reader factory class - -=cut diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,25 +0,0 @@ -# $Id: NoUnicodeExt.pm,v 1.3 2003/07/30 13:39:23 matt Exp $ - -package XML::SAX::PurePerl::Reader; -use strict; - -sub set_raw_stream { - # no-op -} - -sub switch_encoding_stream { - my ($fh, $encoding) = @_; - throw XML::SAX::Exception::Parse ( - Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding", - ) if $encoding !~ /(ASCII|UTF\-?8)/i; -} - -sub switch_encoding_string { - my (undef, $encoding) = @_; - throw XML::SAX::Exception::Parse ( - Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding", - ) if $encoding !~ /(ASCII|UTF\-?8)/i; -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader/Stream.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader/Stream.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,84 +0,0 @@ -# $Id: Stream.pm,v 1.7 2005/10/14 20:31:20 matt Exp $ - -package XML::SAX::PurePerl::Reader::Stream; - -use strict; -use vars qw(@ISA); - -use XML::SAX::PurePerl::Reader qw( - EOF - BUFFER - LINE - COLUMN - ENCODING - XML_VERSION -); -use XML::SAX::Exception; - -@ISA = ('XML::SAX::PurePerl::Reader'); - -# subclassed by adding 1 to last element -use constant FH => 8; -use constant BUFFER_SIZE => 4096; - -sub new { - my $class = shift; - my $ioref = shift; - XML::SAX::PurePerl::Reader::set_raw_stream($ioref); - my @parts; - @parts[FH, LINE, COLUMN, BUFFER, EOF, XML_VERSION] = - ($ioref, 1, 0, '', 0, '1.0'); - return bless \@parts, $class; -} - -sub read_more { - my $self = shift; - my $buf; - my $bytesread = read($self->[FH], $buf, BUFFER_SIZE); - if ($bytesread) { - $self->[BUFFER] .= $buf; - return 1; - } - elsif (defined($bytesread)) { - $self->[EOF]++; - return 0; - } - else { - throw XML::SAX::Exception::Parse( - Message => "Error reading from filehandle: $!", - ); - } -} - -sub move_along { - my $self = shift; - my $discarded = substr($self->[BUFFER], 0, $_[0], ''); - - # Wish I could skip this lot - tells us where we are in the file - my $lines = $discarded =~ tr/\n//; - $self->[LINE] += $lines; - if ($lines) { - $discarded =~ /\n([^\n]*)$/; - $self->[COLUMN] = length($1); - } - else { - $self->[COLUMN] += $_[0]; - } -} - -sub set_encoding { - my $self = shift; - my ($encoding) = @_; - # warn("set encoding to: $encoding\n"); - XML::SAX::PurePerl::Reader::switch_encoding_stream($self->[FH], $encoding); - XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding); - $self->[ENCODING] = $encoding; -} - -sub bytepos { - my $self = shift; - tell($self->[FH]); -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader/String.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader/String.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,61 +0,0 @@ -# $Id: String.pm,v 1.5 2003/07/30 13:39:23 matt Exp $ - -package XML::SAX::PurePerl::Reader::String; - -use strict; -use vars qw(@ISA); - -use XML::SAX::PurePerl::Reader qw( - LINE - COLUMN - BUFFER - ENCODING - EOF -); - -@ISA = ('XML::SAX::PurePerl::Reader'); - -use constant DISCARDED => 7; - -sub new { - my $class = shift; - my $string = shift; - my @parts; - @parts[BUFFER, EOF, LINE, COLUMN, DISCARDED] = - ($string, 0, 1, 0, ''); - return bless \@parts, $class; -} - -sub read_more () { } - -sub move_along { - my $self = shift; - my $discarded = substr($self->[BUFFER], 0, $_[0], ''); - $self->[DISCARDED] .= $discarded; - - # Wish I could skip this lot - tells us where we are in the file - my $lines = $discarded =~ tr/\n//; - $self->[LINE] += $lines; - if ($lines) { - $discarded =~ /\n([^\n]*)$/; - $self->[COLUMN] = length($1); - } - else { - $self->[COLUMN] += $_[0]; - } -} - -sub set_encoding { - my $self = shift; - my ($encoding) = @_; - - XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding, "utf-8"); - $self->[ENCODING] = $encoding; -} - -sub bytepos { - my $self = shift; - length($self->[DISCARDED]); -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader/URI.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader/URI.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,57 +0,0 @@ -# $Id: URI.pm,v 1.1 2001/11/11 18:41:51 matt Exp $ - -package XML::SAX::PurePerl::Reader::URI; - -use strict; - -use XML::SAX::PurePerl::Reader; -use File::Temp qw(tempfile); -use Symbol; - -## NOTE: This is *not* a subclass of Reader. It just returns Stream or String -## Reader objects depending on what it's capabilities are. - -sub new { - my $class = shift; - my $uri = shift; - # request the URI - if (-e $uri && -f _) { - my $fh = gensym; - open($fh, $uri) || die "Cannot open file $uri : $!"; - return XML::SAX::PurePerl::Reader::Stream->new($fh); - } - elsif ($uri =~ /^file:(.*)$/ && -e $1 && -f _) { - my $file = $1; - my $fh = gensym; - open($fh, $file) || die "Cannot open file $file : $!"; - return XML::SAX::PurePerl::Reader::Stream->new($fh); - } - else { - # request URI, return String reader - require LWP::UserAgent; - my $ua = LWP::UserAgent->new; - $ua->agent("Perl/XML/SAX/PurePerl/1.0 " . $ua->agent); - - my $req = HTTP::Request->new(GET => $uri); - - my $fh = tempfile(); - - my $callback = sub { - my ($data, $response, $protocol) = @_; - print $fh $data; - }; - - my $res = $ua->request($req, $callback, 4096); - - if ($res->is_success) { - seek($fh, 0, 0); - return XML::SAX::PurePerl::Reader::Stream->new($fh); - } - else { - die "LWP Request Failed"; - } - } -} - - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/Reader/UnicodeExt.pm --- a/common/tools/raptor/XML/SAX/PurePerl/Reader/UnicodeExt.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,23 +0,0 @@ -# $Id: UnicodeExt.pm,v 1.4 2003/07/30 13:39:23 matt Exp $ - -package XML::SAX::PurePerl::Reader; -use strict; - -use Encode; - -sub set_raw_stream { - my ($fh) = @_; - binmode($fh, ":bytes"); -} - -sub switch_encoding_stream { - my ($fh, $encoding) = @_; - binmode($fh, ":encoding($encoding)"); -} - -sub switch_encoding_string { - Encode::from_to($_[0], $_[1], "utf-8"); -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/UnicodeExt.pm --- a/common/tools/raptor/XML/SAX/PurePerl/UnicodeExt.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,22 +0,0 @@ -# $Id: UnicodeExt.pm,v 1.1 2002/01/30 17:35:21 matt Exp $ - -package XML::SAX::PurePerl; -use strict; - -no warnings 'utf8'; - -sub chr_ref { - return chr(shift); -} - -if ($] >= 5.007002) { - require Encode; - - Encode::define_alias( "UTF-16" => "UCS-2" ); - Encode::define_alias( "UTF-16BE" => "UCS-2" ); - Encode::define_alias( "UTF-16LE" => "ucs-2le" ); - Encode::define_alias( "UTF16LE" => "ucs-2le" ); -} - -1; - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/PurePerl/XMLDecl.pm --- a/common/tools/raptor/XML/SAX/PurePerl/XMLDecl.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -# $Id: XMLDecl.pm,v 1.3 2003/07/30 13:39:22 matt Exp $ - -package XML::SAX::PurePerl; - -use strict; -use XML::SAX::PurePerl::Productions qw($S $VersionNum $EncNameStart $EncNameEnd); - -sub XMLDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(5); - # warn("Looking for xmldecl in: $data"); - if ($data =~ /^<\?xml$S/o) { - $reader->move_along(5); - $self->skip_whitespace($reader); - - # get version attribute - $self->VersionInfo($reader) || - $self->parser_error("XML Declaration lacks required version attribute, or version attribute does not match XML specification", $reader); - - if (!$self->skip_whitespace($reader)) { - my $data = $reader->data(2); - $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); - $reader->move_along(2); - return; - } - - if ($self->EncodingDecl($reader)) { - if (!$self->skip_whitespace($reader)) { - my $data = $reader->data(2); - $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); - $reader->move_along(2); - return; - } - } - - $self->SDDecl($reader); - - $self->skip_whitespace($reader); - - my $data = $reader->data(2); - $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); - $reader->move_along(2); - } - else { - # warn("first 5 bytes: ", join(',', unpack("CCCCC", $data)), "\n"); - # no xml decl - if (!$reader->get_encoding) { - $reader->set_encoding("UTF-8"); - } - } -} - -sub VersionInfo { - my ($self, $reader) = @_; - - my $data = $reader->data(11); - - # warn("Looking for version in $data"); - - $data =~ /^(version$S*=$S*(["'])($VersionNum)\2)/o or return 0; - $reader->move_along(length($1)); - my $vernum = $3; - - if ($vernum ne "1.0") { - $self->parser_error("Only XML version 1.0 supported. Saw: '$vernum'", $reader); - } - - return 1; -} - -sub SDDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(15); - - $data =~ /^(standalone$S*=$S*(["'])(yes|no)\2)/o or return 0; - $reader->move_along(length($1)); - my $yesno = $3; - - if ($yesno eq 'yes') { - $self->{standalone} = 1; - } - else { - $self->{standalone} = 0; - } - - return 1; -} - -sub EncodingDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(12); - - $data =~ /^(encoding$S*=$S*(["'])($EncNameStart$EncNameEnd*)\2)/o or return 0; - $reader->move_along(length($1)); - my $encoding = $3; - - $reader->set_encoding($encoding); - - return 1; -} - -sub TextDecl { - my ($self, $reader) = @_; - - my $data = $reader->data(6); - $data =~ /^<\?xml$S+/ or return; - $reader->move_along(5); - $self->skip_whitespace($reader); - - if ($self->VersionInfo($reader)) { - $self->skip_whitespace($reader) || - $self->parser_error("Lack of whitespace after version attribute in text declaration", $reader); - } - - $self->EncodingDecl($reader) || - $self->parser_error("Encoding declaration missing from external entity text declaration", $reader); - - $self->skip_whitespace($reader); - - $data = $reader->data(2); - $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); - - return 1; -} - -1; diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/XML/SAX/placeholder.pl --- a/common/tools/raptor/XML/SAX/placeholder.pl Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1 +0,0 @@ -# ignore me diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/preprocess_log.pl --- a/common/tools/raptor/preprocess_log.pl Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,111 +0,0 @@ -#!perl -w -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Preprocess a raptor log, trying to countermeasure a list of known anomalies - -use strict; - -use Getopt::Long; - -my $help = 0; -GetOptions( - 'help!' => \$help, -); - -if ($help) -{ - warn <<"EOF"; -Preprocess a raptor log, trying to countermeasure a list of known anomalies - -Usage: perl preprocess_log.pl < INFILE > OUTFILE -EOF - exit(0); -} - -while (my $line = <>) -{ - if ($line =~ m{<[^<^>]+>.*&.*]+>}) - { - $line = escape_ampersand($line); - } - elsif ($line =~ m{<\?xml\s.*encoding=.*\".*\?>}) - { - $line = set_encoding_utf8($line); - } - elsif ($line =~ m{}) - { - $line = unterminated_archive_tag($line, scalar <>, $.) - } - elsif ($line =~ m{make.exe: Circular .* <- .* dependency dropped.}) - { - $line = escape_left_angle_bracket($line); - } - - print $line; -} - -sub escape_ampersand -{ - my ($line) = @_; - - warn "escape_ampersand\n"; - warn "in: $line"; - - $line =~ s,&,&,g; - - warn "out: $line"; - return $line; -} - -sub set_encoding_utf8 -{ - my ($line) = @_; - - warn "set_encoding_utf8\n"; - warn "in: $line"; - - $line =~ s,encoding=".*",encoding="utf-8",; - - warn "out: $line"; - return $line; -} - -sub unterminated_archive_tag -{ - my $line = shift; - my $nextLine = shift; - my $lineNum = shift; - - if ($nextLine !~ m{()|()}) - { - warn "unterminated_archive_tag\n"; - warn "in: $line"; - $line =~ s{>}{/>}; - warn "out: $line"; - } - - return $line . $nextLine; -} - -sub escape_left_angle_bracket -{ - my ($line) = @_; - - warn "escape_left_angle_bracket\n"; - warn "in: $line"; - - $line =~ s,<,<,g; - - warn "out: $line"; - return $line; -} diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/releaseables.pl --- a/common/tools/raptor/releaseables.pl Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Extract releaseable (whatlog) information from Raptor log files - -use strict; -use releaseables; -use FindBin; -use lib $FindBin::Bin; -use XML::SAX; -use RaptorSAXHandler; -use Getopt::Long; - -our $basedir = '.'; -my $help = 0; -GetOptions(( - 'basedir=s' => \$basedir, - 'help!' => \$help -)); -my @logfiles = @ARGV; - -$help = 1 if (!@logfiles); - -if ($help) -{ - print "Extract releaseable (whatlog) information from Raptor log files\n"; - print "Usage: perl releaseables.pl [OPTIONS] FILE1 FILE2 ...\n"; - print "where OPTIONS are:\n"; - print "\t--basedir=DIR Generate output under DIR (defaults to current dir)\n"; - exit(0); -} - -my $releaseablesdir = "$::basedir/releaseables"; -$releaseablesdir =~ s,/,\\,g; # this is because rmdir doens't cope correctly with the forward slashes -system("rmdir /S /Q $releaseablesdir") if (-d "$releaseablesdir"); -mkdir("$releaseablesdir"); - -my $saxhandler = RaptorSAXHandler->new(); -$saxhandler->add_observer('releaseables', $releaseables::reset_status); - -my $parser = XML::SAX::ParserFactory->parser(Handler=>$saxhandler); -for (@logfiles) -{ - $parser->parse_uri($_); -} - diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/releaseables.pm --- a/common/tools/raptor/releaseables.pm Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,292 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Raptor parser module. -# Extract releaseable (whatlog) information - -package releaseables; - -use strict; - -our $reset_status = {}; -my $buildlog_status = {}; -my $whatlog_status = {}; -my $bitmap_status = {}; -my $resource_status = {}; -my $build_status = {}; -my $export_status = {}; -my $stringtable_status = {}; -my $archive_status = {}; -my $archive_member_status = {}; -my $whatlog_default_status = {}; - -$reset_status->{name} = 'reset_status'; -$reset_status->{next_status} = {buildlog=>$buildlog_status}; - -$buildlog_status->{name} = 'buildlog_status'; -$buildlog_status->{next_status} = {whatlog=>$whatlog_status}; -$buildlog_status->{on_start} = 'releaseables::on_start_buildlog'; - -$whatlog_status->{name} = 'whatlog_status'; -$whatlog_status->{next_status} = {bitmap=>$bitmap_status, resource=>$resource_status, build=>$build_status, export=>$export_status, stringtable=>$stringtable_status, archive=>$archive_status, '?default?'=>$whatlog_default_status}; -$whatlog_status->{on_start} = 'releaseables::on_start_whatlog'; -$whatlog_status->{on_end} = 'releaseables::on_end_whatlog'; - -$bitmap_status->{name} = 'bitmap_status'; -$bitmap_status->{next_status} = {}; -$bitmap_status->{on_start} = 'releaseables::on_start_bitmap'; -$bitmap_status->{on_end} = 'releaseables::on_end_whatlog_subtag'; -$bitmap_status->{on_chars} = 'releaseables::on_chars_whatlog_subtag'; - -$resource_status->{name} = 'resource_status'; -$resource_status->{next_status} = {}; -$resource_status->{on_start} = 'releaseables::on_start_resource'; -$resource_status->{on_end} = 'releaseables::on_end_whatlog_subtag'; -$resource_status->{on_chars} = 'releaseables::on_chars_whatlog_subtag'; - -$build_status->{name} = 'build_status'; -$build_status->{next_status} = {}; -$build_status->{on_start} = 'releaseables::on_start_build'; -$build_status->{on_end} = 'releaseables::on_end_whatlog_subtag'; -$build_status->{on_chars} = 'releaseables::on_chars_whatlog_subtag'; - -$stringtable_status->{name} = 'stringtable_status'; -$stringtable_status->{next_status} = {}; -$stringtable_status->{on_start} = 'releaseables::on_start_stringtable'; -$stringtable_status->{on_end} = 'releaseables::on_end_whatlog_subtag'; -$stringtable_status->{on_chars} = 'releaseables::on_chars_whatlog_subtag'; - -$archive_status->{name} = 'archive_status'; -$archive_status->{next_status} = {member=>$archive_member_status}; - -$archive_member_status->{name} = 'archive_member_status'; -$archive_member_status->{next_status} = {}; -$archive_member_status->{on_start} = 'releaseables::on_start_archive_member'; -$archive_member_status->{on_end} = 'releaseables::on_end_whatlog_subtag'; -$archive_member_status->{on_chars} = 'releaseables::on_chars_whatlog_subtag'; - -$export_status->{name} = 'export_status'; -$export_status->{next_status} = {}; -$export_status->{on_start} = 'releaseables::on_start_export'; - -$whatlog_default_status->{name} = 'whatlog_default_status'; -$whatlog_default_status->{next_status} = {}; -$whatlog_default_status->{on_start} = 'releaseables::on_start_whatlog_default'; - -my $whatlog_info = {}; -my $curbldinf = 'unknown'; -my $curconfig = 'unknown'; -my $curfiletype = 'unknown'; -my $characters = ''; - -sub on_start_buildlog -{ - -} - -sub on_start_whatlog -{ - my ($el) = @_; - - $whatlog_info = {}; - - my $bldinf = ''; - my $config = ''; - my $attributes = $el->{Attributes}; - for (keys %{$attributes}) - { - #print "reading attribute $_\n"; - if ($attributes->{$_}->{'LocalName'} eq 'bldinf') - { - $bldinf = $attributes->{$_}->{'Value'}; - #print "bldinf=$bldinf\n"; - } - elsif ($attributes->{$_}->{'LocalName'} eq 'config') - { - $config = $attributes->{$_}->{'Value'}; - $config =~ s,\.whatlog$,,; - } - } - - if ($bldinf eq '') - { - print "WARNING: whatlog tag with no bldinf attribute. Skipping\n"; - return; - } - - $curbldinf = $bldinf; - $curconfig = $config; - $whatlog_info->{$curbldinf} = {} if (!defined $whatlog_info->{$curbldinf}); - $whatlog_info->{$curbldinf}->{$curconfig} = {} if (!defined $whatlog_info->{$curbldinf}->{$curconfig}); -} - -sub on_start_whatlog_subtag -{ - my ($ft) = @_; - - $curfiletype = $ft; - $characters = ''; - $whatlog_info->{$curbldinf}->{$curconfig}->{$curfiletype} = [] if (! defined $whatlog_info->{$curbldinf}->{$curconfig}->{$curfiletype}); -} - -sub on_chars_whatlog_subtag -{ - my ($ch) = @_; - - $characters .= $ch->{Data}; - - #print "characters is now -->$characters<--\n"; -} - -sub on_end_whatlog_subtag -{ - $characters = normalize_filepath($characters); - - push(@{$whatlog_info->{$curbldinf}->{$curconfig}->{$curfiletype}}, $characters); - - $curfiletype = 'unknown'; - $characters = ''; -} - -sub on_start_bitmap -{ - on_start_whatlog_subtag('bitmap'); -} - -sub on_start_resource -{ - on_start_whatlog_subtag('resource'); -} - -sub on_start_build -{ - on_start_whatlog_subtag('build'); -} - -sub on_start_stringtable -{ - on_start_whatlog_subtag('stringtable'); -} - -sub on_start_archive_member -{ - on_start_whatlog_subtag('export'); -} - -sub on_start_export -{ - my ($el) = @_; - - $whatlog_info->{$curbldinf}->{$curconfig}->{export} = [] if (! defined $whatlog_info->{$curbldinf}->{$curconfig}->{export}); - - my $destination = ''; - my $attributes = $el->{Attributes}; - for (keys %{$attributes}) - { - #print "reading attribute $_\n"; - if ($attributes->{$_}->{'LocalName'} eq 'destination') - { - $destination = $attributes->{$_}->{'Value'}; - #print "destination=$destination\n"; - last; - } - } - - if ($destination eq '') - { - print "WARNING: export tag with no destination attribute. Skipping\n"; - return; - } - - $destination = normalize_filepath($destination); - - push(@{$whatlog_info->{$curbldinf}->{$curconfig}->{export}}, $destination); -} - -sub on_end_whatlog -{ - my $unknown_counter = 0; - - for my $bldinf (keys %{$whatlog_info}) - { - for my $config (keys %{$whatlog_info->{$bldinf}}) - { - my $normalized = lc($bldinf); - $normalized =~ s,^[A-Za-z]:,,; - $normalized =~ s,[\\],/,g; - - $normalized =~ m,^/sf/([^/]+)/([^/]+)/,; - my $layer = $1; - my $package = $2; - - mkdir("$::basedir/releaseables/$layer"); - mkdir("$::basedir/releaseables/$layer/$package"); - - my $filename = "$::basedir/releaseables/$layer/$package/info.tsv"; - - print "Writing info file $filename\n" if (!-f$filename); - open(FILE, ">>$filename"); - - for my $filetype (keys %{$whatlog_info->{$bldinf}->{$config}}) - { - for (sort(@{$whatlog_info->{$bldinf}->{$config}->{$filetype}})) - { - print FILE "$_\t$filetype\t$config\n"; - } - } - - close(FILE); - } - } -} - -sub normalize_filepath -{ - my ($filepath) = @_; - - if ($filepath =~ m,[^\s^\r^\n]+(.*)[\r\n]+(.*)[^\s^\r^\n]+,) - { - print "WARNING: file path string extends over multiple line: $filepath. Removing all NL's and CR's\n"; - } - - # strip all CR's and NL's - $filepath =~ s,[\r\n],,g; - - # strip all whitespaces at string start/end - $filepath =~ s,^\s+,,g; - $filepath =~ s,\s+$,,g; - - # remove drive letter and colon from the beginning of the string - $filepath =~ s,^[A-Za-z]:,,; - - # normalize slashes - $filepath =~ s,\\,/,g; - $filepath =~ s,//,/,g; - - if ($filepath !~ m,^/epoc32/,i) - { - print "WARNING: file '$filepath' doesn't seem valid. Writing to info file anyway\n"; - } - - return $filepath; -} - -sub on_start_whatlog_default -{ - my ($el) = @_; - - my $tagname = $el->{LocalName}; - - print "WARNING: unsupported tag '$tagname' in context\n"; -} - -1; \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/truclean.pl --- a/common/tools/raptor/truclean.pl Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,110 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Extracts output text in context which doesn't belong to 's - -use strict; -use Getopt::Long; - -my $RELEASEABLES_DIR = "/releaseables"; - -my $releaseablesdir = ""; -my $packageexpr = ''; -my $help = 0; -GetOptions(( - 'packageexpr:s' => \$packageexpr, - 'releaseablesdir:s' => \$RELEASEABLES_DIR, - 'help!' => \$help -)); - -$packageexpr =~ m,([^/^\\]+)[/\\]([^/^\\]+),; -my $layer_expr = $1; -my $package_expr = $2; -$help = 1 if (!$layer_expr or !$package_expr); - -if ($help) -{ - print "Extracts text which doesn't belong to recipes from a raptor log file\n"; - print "Usage: perl truclean.pl --packageexpr=LAYER_EXPR/PACKAGE_EXPR [OPTIONS]\n"; - print "where:\n"; - print "\tLAYER_EXPR can be * or the name of a layer\n"; - print "\tPACKAGE_EXPR can be * or the name of a package\n"; - print "and OPTIONS are:\n"; - print "\t--releaseablesdir=DIR Use DIR as the root of the releaseables dir (default: $RELEASEABLES_DIR\n"; - exit(0); -} - -$RELEASEABLES_DIR = $releaseablesdir if ($releaseablesdir); - -my @layers = (); -if ($layer_expr eq '*') -{ - opendir(DIR, $RELEASEABLES_DIR); - @layers = readdir(DIR); - closedir(DIR); - @layers = grep(!/^\.\.?$/, @layers); -} -else -{ - push(@layers, $layer_expr); -} -#for (@layers) {print "$_\n"}; - -for my $layer (@layers) -{ - my @packages = (); - if ($package_expr eq '*') - { - opendir(DIR, "$RELEASEABLES_DIR/$layer"); - @packages = readdir(DIR); - closedir(DIR); - @packages = grep(!/^\.\.?$/, @packages); - } - else - { - push(@packages, $package_expr); - } - #for (@pacakges) {print "$_\n"}; - - for my $package (@packages) - { - print "Processing package $layer/$package...\n"; - - open(FILE, "$RELEASEABLES_DIR/$layer/$package/info.tsv"); - while () - { - my $line = $_; - - if ($line =~ m,([^\t]*)\t([^\t]*)\t([^\t]*),) - { - my $file = $1; - my $type = $2; - my $config = $3; - - if (-f $file) - { - print "removing file: '$file'\n"; - unlink($file); - } - else - { - print "WARNING: file '$file' doesn't exist.\n"; - } - } - else - { - print "WARNING: line '$line' doesn't match the expected tab-separated pattern\n"; - } - } - close(FILE); - } -} \ No newline at end of file diff -r 9ed73a51c728 -r 5239d4d0bed1 common/tools/raptor/uh.pl --- a/common/tools/raptor/uh.pl Fri Mar 05 16:16:43 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,403 +0,0 @@ -# Copyright (c) 2009 Symbian Foundation Ltd -# This component and the accompanying materials are made available -# under the terms of the License "Eclipse Public License v1.0" -# which accompanies this distribution, and is available -# at the URL "http://www.eclipse.org/legal/epl-v10.html". -# -# Initial Contributors: -# Symbian Foundation Ltd - initial contribution. -# -# Contributors: -# -# Description: -# Unite and HTML-ize Raptor log files - -use strict; -use FindBin; -use lib $FindBin::Bin; -use RaptorError; -use RaptorWarning; -use RaptorInfo; -use RaptorUnreciped; -use RaptorRecipe; - -use XML::SAX; -use RaptorSAXHandler; -use Getopt::Long; - -our $raptorbitsdir = 'raptorbits'; -our $basedir = ''; -my $outputdir = "html"; -our $raptor_config = 'dummy_config'; -our $current_log_file = ''; -my $help = 0; -GetOptions(( - 'basedir=s' => \$basedir, - 'help!' => \$help -)); -my @logfiles = @ARGV; - -$help = 1 if (!@logfiles); - -if ($help) -{ - print "Unite and HTML-ize Raptor log files.\n"; - print "Usage: perl uh.pl [OPTIONS] FILE1 FILE2 ...\n"; - print "where OPTIONS are:\n"; - print "\t--basedir=DIR Generate output under DIR (defaults to current dir)\n"; - exit(0); -} - -if ($basedir) -{ - $raptorbitsdir = "$basedir/raptorbits"; - $outputdir = "$basedir/html"; -} -mkdir($basedir) if (!-d$basedir); - -$raptorbitsdir =~ s,/,\\,g; # this is because rmdir doens't cope correctly with the forward slashes - -system("rmdir /S /Q $raptorbitsdir") if (-d $raptorbitsdir); -mkdir($raptorbitsdir); -#print "Created dir $raptorbitsdir.\n"; - -# create empty summary file anyway -open(SUMMARY, ">$raptorbitsdir/summary.csv"); -close(SUMMARY); - -my $saxhandler = RaptorSAXHandler->new(); -$saxhandler->add_observer('RaptorError', $RaptorError::reset_status); -$saxhandler->add_observer('RaptorWarning', $RaptorWarning::reset_status); -$saxhandler->add_observer('RaptorInfo', $RaptorInfo::reset_status); -$saxhandler->add_observer('RaptorUnreciped', $RaptorUnreciped::reset_status); -$saxhandler->add_observer('RaptorRecipe', $RaptorRecipe::reset_status); - -our $allbldinfs = {}; - -my $parser = XML::SAX::ParserFactory->parser(Handler=>$saxhandler); -for (@logfiles) -{ - print "Reading file: $_\n"; - $current_log_file = $_; - $parser->parse_uri($_); -} - -my @allpackages = distinct_packages($allbldinfs); - -print "Generating HTML...\n"; - -system("rd /S /Q $outputdir") if (-d $outputdir); -mkdir ($outputdir); - -my $raptor_errors = {}; -my $raptor_warnings = {}; -my $raptor_unreciped = {}; -my $general_failures_num_by_severity = {}; -my $general_failures_by_category_severity = {}; -my $recipe_failures_num_by_severity = {}; -my $recipe_failures_by_package_severity = {}; -#my $severities = {}; -my @severities = ('critical', 'major', 'minor', 'unknown'); - -# READ SUMMARY.CSV FILE -my $csv_file = "$raptorbitsdir/summary.csv"; -my $csv_linenum = 0; -open(CSV, $csv_file); -while() -{ - $csv_linenum ++; - my $line = $_; - - if ($line =~ /([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*),([^,]*)/) - { - my $failure = {}; - $failure->{category} = $1; - $failure->{subcategory} = $2; - $failure->{severity} = $3; - $failure->{config} = $4; - $failure->{component} = $5; - $failure->{mmp} = $6; - $failure->{phase} = $7; - $failure->{recipe} = $8; - $failure->{file} = $9; - $failure->{linenum} = $10; - - my $failure_package = ''; - - if (!$failure->{category}) - { - print "WARNING: summary line without a category at $csv_file line $csv_linenum. Skipping\n"; - next; - } - - if ($failure->{category} =~ m,^recipe_failure$,i and !$failure->{component}) - { - print "WARNING: recipe_failure with component field empty at $csv_file line $csv_linenum. Skipping\n"; - next; - } - if ($failure->{component}) - { - if ($failure->{component} =~ m,/((os|mw|app|tools|ostools|adaptation)/[^/]*),) - { - $failure_package = $1; - } - else - { - print "WARNING: summary line with wrong component path at $csv_file line $csv_linenum. Skipping\n"; - next; - } - } - - $failure->{subcategory} = 'uncategorized' if (!$failure->{subcategory}); - $failure->{severity} = 'unknown' if (!$failure->{severity}); - $failure->{mmp} = '-' if (!$failure->{mmp}); - - # populate severities dynamically. - #$severities->{$failure->{severity}} = 1; - - # put failure items into their category container - if ($failure->{category} =~ /^raptor_(error|warning|unreciped)$/i) - { - $general_failures_num_by_severity->{$failure->{category}} = {} if (!defined $general_failures_num_by_severity->{$failure->{category}}); - my $general_failure = $general_failures_num_by_severity->{$failure->{category}}; - - if (!defined $general_failure->{$failure->{severity}}) - { - $general_failure->{$failure->{severity}} = 1; - } - else - { - $general_failure->{$failure->{severity}} ++; - } - - $general_failures_by_category_severity->{$failure->{category}} = {} if (!defined $general_failures_by_category_severity->{$failure->{category}}); - $general_failures_by_category_severity->{$failure->{category}}->{$failure->{severity}} = [] if (!defined $general_failures_by_category_severity->{$failure->{category}}->{$failure->{severity}}); - push(@{$general_failures_by_category_severity->{$failure->{category}}->{$failure->{severity}}}, $failure); - } - elsif ($failure->{category} =~ /^recipe_failure$/i) - { - $recipe_failures_num_by_severity->{$failure_package} = {} if (!defined $recipe_failures_num_by_severity->{$failure_package}); - my $package_failure = $recipe_failures_num_by_severity->{$failure_package}; - - if (!defined $package_failure->{$failure->{severity}}) - { - $package_failure->{$failure->{severity}} = 1; - } - else - { - $package_failure->{$failure->{severity}} ++; - } - - $recipe_failures_by_package_severity->{$failure_package} = {} if (!defined $recipe_failures_by_package_severity->{$failure_package}); - $recipe_failures_by_package_severity->{$failure_package}->{$failure->{severity}} = [] if (!defined $recipe_failures_by_package_severity->{$failure_package}->{$failure->{severity}}); - push(@{$recipe_failures_by_package_severity->{$failure_package}->{$failure->{severity}}}, $failure); - } - } - else - { - print "WARNING: line does not match expected format at $csv_file line $csv_linenum. Skipping\n"; - } -} -close(CSV); - -# PRINT HTML SUMMARY -my $aggregated_html = "$outputdir/index.html"; -open(AGGREGATED, ">$aggregated_html"); -print AGGREGATED "RAPTOR BUILD SUMMARY
\n"; - -print AGGREGATED "
GENERAL FAILURES
\n"; -print AGGREGATED "\n"; -my $tableheader = ""; -for (@severities) { $tableheader .= ""; } -$tableheader .= ""; -print AGGREGATED "$tableheader\n"; -for my $category (keys %{$general_failures_num_by_severity}) -{ - print_category_specific_summary($category, $general_failures_by_category_severity->{$category}); - my $categoryline = ""; - for (@severities) - { - my $failuresbyseverity = 0; - $failuresbyseverity = $general_failures_num_by_severity->{$category}->{$_} if (defined $general_failures_num_by_severity->{$category}->{$_}); - $categoryline .= ""; - } - $categoryline .= ""; - print AGGREGATED "$categoryline\n"; -} -print AGGREGATED "
category$_
$category$failuresbyseverity
\n"; -print AGGREGATED "
\n"; - -print AGGREGATED "
PACKAGE-SPECIFIC FAILURES
\n"; -print AGGREGATED "\n"; -$tableheader = ""; -for (@severities) { $tableheader .= ""; } -$tableheader .= ""; -print AGGREGATED "$tableheader\n"; -for my $package (@allpackages) -{ - if (defined $recipe_failures_num_by_severity->{$package}) - { - print_package_specific_summary($package, $recipe_failures_by_package_severity->{$package}); - my $packagesummaryhtml = $package; - $packagesummaryhtml =~ s,/,_,; - $packagesummaryhtml .= ".html"; - my $packageline = ""; - for (@severities) - { - my $failuresbyseverity = 0; - $failuresbyseverity = $recipe_failures_num_by_severity->{$package}->{$_} if (defined $recipe_failures_num_by_severity->{$package}->{$_}); - $packageline .= ""; - } - $packageline .= ""; - print AGGREGATED "$packageline\n"; - } - else - { - my $packageline = ""; - for (@severities) { $packageline .= ""; } - $packageline .= ""; - print AGGREGATED "$packageline\n"; - } -} -print AGGREGATED "
package$_
$package$failuresbyseverity
$package0
\n"; -close(AGGREGATED); - -translate_detail_files_to_html(); - -print "OK, done. Please open $outputdir/index.html.\n"; - - -sub print_category_specific_summary -{ - my ($category, $failures_by_severity) = @_; - - my $filenamebase = $category; - $filenamebase =~ s,/,_,; - - open(SPECIFIC, ">$outputdir/$filenamebase.html"); - print SPECIFIC "FAILURES FOR CATEGORY $category
\n"; - - for my $severity (@severities) - { - if (defined $failures_by_severity->{$severity}) - { - print SPECIFIC "
".uc($severity)."
\n"; - print SPECIFIC "\n"; - # $subcategory, $severity, $mmp, $phase, $recipe, $file, $line - my $tableheader = ""; - print SPECIFIC "$tableheader\n"; - - for my $failure (@{$failures_by_severity->{$severity}}) - { - my $failureline = ""; - $failureline .= ""; - $failureline .= ""; - $failureline .= ""; - print SPECIFIC "$failureline\n"; - } - - print SPECIFIC "
categorylog filelog snippet
$failure->{subcategory}$failure->{config}item $failure->{linenum}
\n"; - print SPECIFIC "
\n"; - } - } - - close(SPECIFIC); -} - -sub print_package_specific_summary -{ - my ($package, $failures_by_severity) = @_; - - my $filenamebase = $package; - $filenamebase =~ s,/,_,; - - open(SPECIFIC, ">$outputdir/$filenamebase.html"); - print SPECIFIC "FAILURES FOR PACKAGE $package
\n"; - - for my $severity (@severities) - { - if (defined $failures_by_severity->{$severity}) - { - print SPECIFIC "
".uc($severity)."
\n"; - print SPECIFIC "\n"; - # $subcategory, $severity, $mmp, $phase, $recipe, $file, $line - my $tableheader = ""; - print SPECIFIC "$tableheader\n"; - - for my $failure (@{$failures_by_severity->{$severity}}) - { - my $failureline = ""; - $failureline .= ""; - $failureline .= ""; - $failureline .= ""; - $failureline .= ""; - $failureline .= ""; - $failureline .= ""; - print SPECIFIC "$failureline\n"; - } - - print SPECIFIC "
categoryconfigurationmmpphaserecipelog snippet
$failure->{subcategory}$failure->{config}$failure->{mmp}$failure->{phase}$failure->{recipe}item $failure->{linenum}
\n"; - print SPECIFIC "
\n"; - } - } - - close(SPECIFIC); -} - -sub translate_detail_files_to_html -{ - opendir(DIR, $raptorbitsdir); - my @failurefiles = readdir(DIR); - closedir(DIR); - @failurefiles = grep(/\.txt$/, @failurefiles); - - for my $file (@failurefiles) - { - $file =~ /(.*)\.txt$/; - my $filenamebase = $1; - - my $filecontent = ''; - open(FILE, "$raptorbitsdir/$file"); - { - local $/=undef; - $filecontent = ; - } - close(FILE); - - $filecontent =~ s,---(failure_item_\d+)---,---$1---,g; - $filecontent = "
$filecontent
"; - - open(FILE, ">$outputdir/$filenamebase\_failures.html"); - print FILE $filecontent; - close(FILE); - } -} - -sub distinct_packages -{ - my ($allbldinfs) = @_; - - my $allpackages = {}; - - for my $bldinf (keys %{$allbldinfs}) - { - # normalize bldinf path - $bldinf = lc($bldinf); - $bldinf =~ s,^[A-Za-z]:,,; - $bldinf =~ s,[\\],/,g; - - my $package = ''; - if ($bldinf =~ m,/((os|mw|app|tools|ostools|adaptation)/[^/]*),) - { - $package = $1; - } - else - { - print "WARNING: can't understand bldinf attribute of recipe: $bldinf. Won't dump to failed recipes file.\n"; - } - - $allpackages->{$package} = 1; - } - - return sort {$a cmp $b} keys %{$allpackages}; -} \ No newline at end of file