package
XML::RelaxNG::Compact::PXB;
use
version ;
our
$VERSION
=
'0.15'
;
Hide Show 83 lines of Pod
use
fields
qw(debug top_dir datatypes_root project_root schema_version test_dir footer nsregistry
_schema_version_dir _TESTS _fh _fhtest _path _root _known_class _existed DEBUG)
;
XML::RelaxNG::Compact::PXB->mk_accessors(XML::RelaxNG::Compact::PXB->show_fields(
'Public'
),
'_fh'
,
'_fhtest'
,
'_TESTS'
);
Hide Show 72 lines of Pod
};
sub
new {
my
(
$that
,
$param
) =
@_
;
my
$class
=
ref
(
$that
) ||
$that
;
my
$self
= fields::new(
$class
);
$self
->top_dir(
"$FindBin::Bin"
);
$self
->datatypes_root(
"XMLTypes"
);
$self
->project_root(
"API"
);
$self
->schema_version(
"1.0"
);
$self
->footer(POD::Credentials->new());
$self
->DEBUG(-1);
$self
->test_dir(
"/t"
);
$self
->{_known_class} ={};
$self
->{_existed}={};
$self
->{_path} = [];
if
(
$param
&&
ref
(
$param
) ne
'HASH'
) {
croak(
"ONLY hash ref accepted as param and not: "
. Dumper
$param
);
}
map
{
$self
->{
$_
} =
$param
->{
$_
}
if
$self
->can(
$_
) &&
$param
->{
$_
} }
keys
%{
$param
};
(
my
$version
=
$self
->schema_version) =~ s/v//i;
$self
->schema_version(qv(
"$version"
));
$version
=~ s/\./_/g;
$self
->{_schema_version_dir} =
"v$version"
;
if
(
$self
->nsregistry &&
ref
(
$self
->nsregistry) eq
'HASH'
) {
$self
->nsregistry({%{
$self
->nsregistry}, %{
$XSD_NS
}});
}
else
{
$self
->nsregistry(
$XSD_NS
);
}
$self
->footer->end_module(1);
$self
->footer->see_also(
' Automatically generated by L<XML::RelaxNG::Compact::PXB> '
)
unless
$self
->footer->see_also;
return
$self
;
}
sub
_makeAPIPath {
my
(
$self
,
$classname
,
$ns
) =
@_
;
my
$classnameUP
=
ucfirst
(
$classname
);
print
"MakePath: ::$ns packagepath="
.
$self
->_packagePath .
" classnameUP=$classnameUP\n"
if
$self
->DEBUG > 1;
push
@{
$self
->{_path}},
$classnameUP
;
my
$classname_tmp
=
$self
->project_root .
"::"
.
$self
->datatypes_root .
"::"
.
$self
->{_schema_version_dir} .
"::$ns"
.
$self
->_packagePath;
unless
(
$self
->{_existed}->{
$classname_tmp
} ) {
$self
->{_existed}->{
$classname_tmp
} =
$classname
;
$self
->{_known_class}->{
$classname
}{
$ns
} =
$classname_tmp
;
}
return
$self
;
}
sub
_packagePath {
my
(
$self
) =
@_
;
my
$path
=
'::'
;
if
(@{
$self
->{_path}}) {
$path
.=
join
'::'
, @{
$self
->{_path}};
}
else
{
$path
=
''
;
}
return
$path
;
}
sub
_dirPath {
my
(
$self
) =
@_
;
my
$path
=
'/'
;
if
(@{
$self
->{_path}}) {
$path
.=
join
'/'
, @{
$self
->{_path}};
}
else
{
$path
=
''
;
}
return
$path
;
}
Hide Show 25 lines of Pod
sub
buildAPI {
my
(
$self
,
$param
) =
@_
;
my
$name
=
$param
->{name};
my
$element
=
$param
->{element};
my
$parent
=
$param
->{parent};
$self
->_printHelpers
unless
$parent
;
my
$ns
=
$element
->{attrs}->{xmlns};
croak(
" Malformed definition: something is missing name=$name ns=$ns element="
. Dumper
$element
)
unless
$name
&&
$ns
&&
$element
;
$self
->_makeAPIPath(
$name
,
$ns
);
if
(
$element
&&
ref
(
$element
) eq
'HASH'
&&
$element
->{attrs}) {
if
(
ref
(
$element
->{elements}) eq
'ARRAY'
&& !
$self
->_TESTS) {
mkpath([
$self
->top_dir .
"/"
.
$self
->project_root .
"/"
.
$self
->datatypes_root .
"/"
.
$self
->{_schema_version_dir} .
"/$ns"
.
$self
->_dirPath], 1, 0755);
}
foreach
my
$el
(@{
$element
->{elements}}) {
if
(
ref
(
$el
) eq
'ARRAY'
) {
if
(
ref
(
$el
->[1]) eq
'HASH'
&&
$el
->[1]->{attrs}) {
$self
->buildAPI({
name
=>
$el
->[0],
element
=>
$el
->[1],
parent
=>
$element
});
}
elsif
(
ref
(
$el
->[1]) eq
'ARRAY'
) {
foreach
my
$sub_el
(@{
$el
->[1]}) {
next
unless
$sub_el
;
if
(
ref
(
$sub_el
) eq
'HASH'
&&
$sub_el
->{attrs}) {
$self
->buildAPI({
name
=>
$el
->[0],
element
=>
$sub_el
,
parent
=>
$element
});
}
elsif
(
ref
(
$sub_el
) eq
'ARRAY'
&&
scalar
@{
$sub_el
} == 1) {
$self
->buildAPI({
name
=>
$el
->[0],
element
=>
$sub_el
->[0],
parent
=>
$element
});
}
else
{
croak(
" Malformed definition: name="
.
$el
->[0] .
" sub_el Dump="
. Dumper(
$sub_el
) .
" el Dump="
. Dumper
$el
);
}
}
}
}
}
$self
->buildClass(
$name
,
$element
,
$parent
)
if
defined
$self
->_dirPath &&
defined
$self
->_packagePath;
my
$child_dir
=
$self
->top_dir .
"/"
.
$self
->project_root .
"/"
.
$self
->datatypes_root .
"/"
.
$self
->{_schema_version_dir} .
"/$ns"
.
$self
->_dirPath;
rmdir
$child_dir
if
( -d
$child_dir
);
pop
@{
$self
->{_path}}
if
defined
$self
->_dirPath &&
defined
$self
->_packagePath;
}
else
{
croak(
"Malformed definition: ended up in non element"
);
}
return
$self
;
}
Hide Show 7 lines of Pod
sub
buildHelpers {
my
(
$self
) =
@_
;
$self
->_printHelpers();
return
$self
;
}
Hide Show 7 lines of Pod
sub
buildAM {
my
(
$self
,
$arr_names
) =
@_
;
croak(
" Only array ref parameter accepted"
. Dumper
$arr_names
)
unless
ref
(
$arr_names
) eq
'ARRAY'
;
foreach
my
$name
(@{
$arr_names
}) {
$self
->sayIt(
qq"
\=head2 get_$name
accessor for $name, assumes hash based class
\=cut
sub get_$name {
my(\$self) = \@_;
return \$self->{$name};
}
\=head2 set_$name
mutator for $name, assumes hash based class
\=cut
sub set_$name {
my(\$self,\$value) = \@_;
if(\$value) {
\$self->{$name} = \$value;
}
return \$self->{$name};
}
"
);
}
return
$self
;
}
Hide Show 8 lines of Pod
sub
buildTests {
my
$self
=
shift
;
$self
->_TESTS(1);
$self
->buildAPI(
@_
);
return
$self
;
}
Hide Show 25 lines of Pod
sub
buildClass {
my
(
$self
,
$name
,
$element
,
$parent
) =
@_
;
my
$ns
=
$element
->{attrs}->{xmlns};
my
$path
=
$self
->top_dir .
"/"
.
$self
->project_root .
"/"
.
$self
->datatypes_root .
"/"
.
$self
->{_schema_version_dir} .
"/$ns"
.
$self
->_dirPath;
my
$root
=
$self
->project_root .
"::"
.
$self
->datatypes_root .
"::"
.
$self
->{_schema_version_dir} .
"::$ns"
.
$self
->_packagePath;
my
$className
=
$root
;
my
@elements
=
grep
(
ref
(
$_
) eq
'ARRAY'
&&
$_
->[0] &&
$_
->[1], @{
$element
->{elements}});
my
@elementnodes
=
grep
(
ref
(
$_
->[1]),
@elements
);
my
@textnodes
=
grep
(
$_
->[1] eq
'text'
&& !
ref
(
$_
->[1]),
@elements
);
my
$elements_names
=
@elementnodes
?
join
(
" "
,
map
{
$_
->[0] }
@elementnodes
):
''
;
my
$texts_names
=
@textnodes
?
join
(
" "
,
map
{
$_
->[0] }
@textnodes
):
''
;
my
@attributes
=
grep
(!/xmlns/,
keys
%{
$element
->{attrs}});
my
$attributes_names
=
@attributes
?
join
" "
,
@attributes
:
''
;
my
%parent_sql
= ();
if
(
$parent
&&
ref
(
$parent
) eq
'HASH'
&&
$parent
->{sql}) {
foreach
my
$table
(
keys
%{
$parent
->{sql}}) {
foreach
my
$field
(
keys
%{
$parent
->{sql}->{
$table
}}) {
my
$value
=
$parent
->{sql}->{
$table
}->{
$field
}->{value};
$value
= [
$value
]
if
ref
(
$value
) ne
'ARRAY'
;
foreach
my
$possible
(@{
$value
}) {
$parent_sql
{
$table
}{
$field
}{
$possible
}++;
}
}
}
}
my
%sql_pass
=();
my
%sql_here
=();
if
(
$element
->{sql}) {
foreach
my
$table
(
keys
%{
$element
->{sql}}) {
foreach
my
$field
(
keys
%{
$element
->{sql}->{
$table
}}) {
my
$value
=
$element
->{sql}->{
$table
}->{
$field
}->{value};
unless
(
$value
) {
croak(
" SQL config malformed for element=$name table=$table field=$field, but value is missied"
);
}
my
$condition
=
$element
->{sql}->{
$table
}->{
$field
}->{
if
};
my
(
$attr_name
,
$set
,
$cond_string
) = (
''
,
''
,
''
);
if
(
$condition
) {
$cond_string
=
'( 1 '
;
my
@conditions
= (
ref
$condition
eq
ref
[])?@{
$condition
}:
qw/$condition/
;
foreach
my
$cond
(
@conditions
) {
(
$attr_name
,
$set
) =
split
(
':'
,
$cond
);
$cond_string
.=
$set
?
" || (\$self->get_$attr_name eq '$set') "
:
" || (\$self->get_$attr_name)"
;
}
$cond_string
.=
' )'
;
}
$value
= [
$value
]
if
ref
(
$value
) ne
'ARRAY'
;
foreach
my
$possible
(@{
$value
}) {
next
if
%parent_sql
&&
$parent_sql
{
$table
}{
$field
} && !
$parent_sql
{
$table
}{
$field
}{
$name
};
if
(
$elements_names
=~ /\b
$possible
\b/) {
$sql_pass
{
$possible
}{
$table
}{
$field
} =
$cond_string
;
}
else
{
$sql_here
{
$possible
}{
$table
}{
$field
} =
$cond_string
;
}
}
}
}
}
$self
->buildTest(\
@elementnodes
, \
@attributes
,
$className
,
$name
,
$element
);
return
if
(
$self
->_TESTS);
$self
->_fh(IO::File->new(
$path
.
".pm"
,
"w+"
));
croak(
" Failed to open file :"
.
$path
.
".pm"
)
unless
$self
->_fh;
print
(
"\n Classname: $path ... Attributes: $attributes_names \n Elements: $elements_names\n"
)
if
$self
->DEBUG > 0;
print
(
" Config:"
. Dumper
$element
)
if
$self
->DEBUG>2;
my
$version
=
$self
->schema_version;
$self
->sayIt(
qq/package $className;
use strict;
use warnings;
use utf8;
use English qw(-no_match_vars);
use version; our \$VERSION = '$version';
\=head1 NAME
$className - this is data binding class for '$name' element from the XML schema namespace $ns
\=head1 DESCRIPTION
Object representation of the $name element of the $ns XML namespace.
Object fields are:
/
);
map
{
$self
->sayIt(
" Scalar: $_,"
) }
@attributes
;
map
{
$self
->sayIt(
" Object reference: "
.
$_
->[0] .
" => type "
.
ref
(
$_
->[1]) .
","
) }
@elements
;
$self
->sayIt(
qq/
The constructor accepts only single parameter, it could be a hashref with keyd parameters hash or DOM of the '$name' element
Alternative way to create this object is to pass hashref to this hash: { xml => <xml string> }
Please remember that namespace prefix is used as namespace id for mapping which not how it was intended by XML standard. The consequence of that
is if you serve some XML on one end of the webservices pipeline then the same namespace prefixes MUST be used on the one for the same namespace URNs.
This constraint can be fixed in the future releases.
Note: this class utilizes L<Log::Log4perl> module, see corresponded docs on CPAN.
\=head1 SYNOPSIS
use $className;
use Log::Log4perl qw(:easy);
Log::Log4perl->easy_init();
my \$el = $className->new(\$DOM_Obj);
my \$xml_string = \$el->asString();
my \$el2 = $className->new({xml => \$xml_string});
see more available methods below
\=head1 METHODS
\=cut
use XML::LibXML;
use Scalar::Util qw(blessed);
use Log::Log4perl qw(get_logger);
use Readonly;
/
);
my
$localized_path
=
$self
->project_root .
"::"
.
$self
->datatypes_root .
"::"
.
$self
->{_schema_version_dir};
$self
->sayIt(
"use $localized_path\::Element qw(getElement);"
);
$self
->sayIt(
"use $localized_path\::NSMap;"
);
foreach
my
$el
(
@elementnodes
) {
foreach
my
$ns
(
keys
%{
$self
->{_known_class}->{
$el
->[0]}}) {
$self
->sayIt(
"use "
.
$self
->{_known_class}->{
$el
->[0]}{
$ns
} .
";"
)
if
$self
->{_known_class}->{
$el
->[0]}{
$ns
};
}
}
$self
->saying(
"use fields qw(nsmap idmap LOGGER $attributes_names $elements_names $texts_names"
);
$self
->saying(
" text "
)
if
$element
->{text};
$self
->sayIt(
");"
);
$self
->sayIt(
qq/
\=head2 new({})
creates object, accepts DOM with element's tree or hashref to the list of
keyed parameters:
/
);
map
{
$self
->sayIt(
" $_ => undef,"
)}
@attributes
;
map
{
$self
->sayIt(
" "
.
$_
->[0] .
" => "
.
ref
(
$_
->[1]) .
","
)}
@elementnodes
;
$self
->sayIt(
" text => 'text'"
)
if
$element
->{text};
$self
->sayIt(
qq/
returns: \$self
\=cut
Readonly::Scalar our \$COLUMN_SEPARATOR => ':';
Readonly::Scalar our \$CLASSPATH => '$className';
Readonly::Scalar our \$LOCALNAME => '$name';
sub new {
my (\$that, \$param) = \@_;
my \$class = ref(\$that) || \$that;
my \$self = fields::new(\$class );
\$self->set_LOGGER(get_logger(\$CLASSPATH));
\$self->set_nsmap($localized_path\::NSMap->new());
\$self->get_nsmap->mapname(\$LOCALNAME, '$ns');
/
);
$self
->sayIt(
qq"
if(\$param) {
if(blessed \$param && \$param->can('getName') && (\$param->getName =~ m/\$LOCALNAME\$/xm) ) {
return \$self->fromDOM(\$param);
} elsif(ref(\$param) ne 'HASH') {
\$self->get_LOGGER->logdie(\"
ONLY hash
ref
accepted as param \" . \
$param
);
return
;
}
if
(\
$param
->{xml}) {
my
\
$parser
= XML::LibXML->new();
\
$parser
->expand_xinclude(1);
my
\
$dom
;
eval
{
my
\
$doc
= \
$parser
->parse_string(\
$param
->{xml});
\
$dom
= \
$doc
->getDocumentElement;
};
if
(\
$EVAL_ERROR
) {
\
$self
->get_LOGGER->logdie(\" Failed to parse XML :\" . \
$param
->{xml} . \" \\n ERROR: \\n\" . \
$EVAL_ERROR
);
return
;
}
return
\
$self
->fromDOM(\
$dom
);
}
\
$self
->get_LOGGER->debug(\"Parsing parameters: \" . (
join
' : '
,
keys
\%{\
$param
}));
foreach
my
\
$param_key
(
keys
\%{\
$param
}) {
\
$self
->{\
$param_key
} = \
$param
->{\
$param_key
}
if
\
$self
->can(\"get_\
$param_key
\");
}
\
$self
->get_LOGGER->debug(\"Done\");
}
return
\
$self
;
}
\=head2 getDOM (\
$parent
)
accepts parent DOM serializes current object into the DOM, attaches it to the parent DOM tree and
returns
$name
object DOM
\=cut
sub
getDOM {
my
(\
$self
, \
$parent
) = \
@_
;
my
\
$$name
;
eval
{
my
\
@nss
;
unless
(\
$parent
) {
my
\
$nsses
= \
$self
->registerNamespaces();
\
@nss
=
map
{\
$_
if
(\
$_
&& \
$_
ne \
$self
->get_nsmap->mapname( \
$LOCALNAME
))}
keys
\%{\
$nsses
};
push
(\
@nss
, \
$self
->get_nsmap->mapname( \
$LOCALNAME
));
}
push
\
@nss
, \
$self
->get_nsmap->mapname( \
$LOCALNAME
)
unless
\
@nss
;
\
$$name
= getElement({
name
=> \
$LOCALNAME
,
parent
=> \
$parent
,
ns
=> \\\
@nss
,
attributes
=> [
");
foreach
my
$attr
(
@attributes
) {
print
(
"_printConditional:: $attr = "
.
$element
->{attrs}->{
$attr
})
if
$self
->DEBUG> 2;
$self
->sayIt(
$self
->_printConditional(
$attr
,
$element
->{attrs}->{
$attr
},
'get'
));
}
$self
->sayIt(
" ],"
);
$self
->sayIt(
$self
->_printConditional(
'text'
,
$element
->{text} ,
'get'
))
if
(
$element
->{text});
$self
->sayIt(
" });"
);
$self
->sayIt(
" };"
);
$self
->sayIt(
" if(\$EVAL_ERROR) {"
);
$self
->sayIt(
" \$self->get_LOGGER->logdie(\" Failed at creating DOM: \$EVAL_ERROR\");"
);
$self
->sayIt(
" }"
);
foreach
my
$els
(
@elementnodes
) {
croak(
" Malformed elements declaration: name=$name and this thingy: els=$els must be an ARRAY ref "
)
unless
ref
(
$els
) eq
'ARRAY'
;
my
$condition
= _conditionParser(
$els
->[2]);
my
$subname
=
$els
->[0];
$condition
->{logic} .=
" && "
if
$condition
->{logic};
if
(
ref
(
$els
->[1]) eq
'ARRAY'
) {
if
(
scalar
@{
$els
->[1]} > 1 ) {
if
(
ref
(
$els
->[1]->[0]) ne
'ARRAY'
) {
$self
->_printGetDOM(
$subname
,
$name
,
$condition
->{logic});
}
else
{
$self
->_printGetArrayDom(
$subname
,
$name
,
$condition
->{logic});
}
}
else
{
$self
->_printGetArrayDom(
$subname
,
$name
,
$condition
->{logic});
}
}
elsif
(
ref
(
$els
->[1]) eq
'HASH'
) {
$self
->_printGetDOM(
$subname
,
$name
,
$condition
->{logic});
}
}
if
(
$texts_names
) {
$self
->sayIt(
qq!
foreach my \$textnode (qw/$texts_names/) {
if(\$self->{\$textnode}) {
my \$domtext = getElement({name => \$textnode,
parent => \$$name,
ns => [\$self->get_nsmap->mapname(\$LOCALNAME)],
text => \$self->{\$textnode},
});
\$domtext?\$$name->appendChild(\$domtext):
\$self->get_LOGGER->logdie("Failed to append new text element \$textnode to $name");
}
}
!
);
}
$self
->sayIt(
" return \$$name;\n}"
);
$self
->buildAM([
'LOGGER'
,
'nsmap'
,
'idmap'
,
'text'
,
@attributes
,
map
{
$_
->[0] }
@elementnodes
,
@textnodes
]);
foreach
my
$el
(
@elementnodes
) {
my
$subname
=
$el
->[0];
if
(
ref
(
$el
->[1]) eq
'ARRAY'
) {
$self
->sayIt(
qq/
\=head2 add\u${subname}()
if any of subelements can be an array then this method will provide
facility to add another element to the array and will return ref to such array
or just set the element to a new one, if element has and 'id' attribute then it will
create idmap
Accepts: obj
Returns: arrayref of objects
\=cut
sub add\u${subname} {
my (\$self,\$new) = \@_;
\$self->get_$subname && ref(\$self->get_$subname) eq 'ARRAY'?push \@{\$self->get_$subname}, \$new:
\$self->set_$subname([\$new]);
\$self->get_LOGGER->debug("Added new to $subname");
\$self->buildIdMap; ## rebuild index map
return \$self->get_$subname;
}
\=head2 remove\u${subname}ById()
removes specific element from the array of ${subname} elements by id ( if id is supported by this element )
Accepts: single param - id - which is id attribute of the element
if there is no array then it will return undef and warning
if it removed some id then \$id will be returned
\=cut
sub remove\u${subname}ById {
my (\$self, \$id) = \@_;
if(ref(\$self->get_$subname) eq 'ARRAY' && \$self->get_idmap->{$subname} &&
exists \$self->get_idmap->{$subname}{\$id}) {
undef \$self->get_$subname->\[\$self->get_idmap->{$subname}{\$id}\];
my \@tmp = grep { defined \$_ } \@{\$self->get_$subname};
\$self->set_$subname([\@tmp]);
\$self->buildIdMap; ## rebuild index map
return \$id;
} elsif(!ref(\$self->get_$subname) || ref(\$self->get_$subname) ne 'ARRAY') {
\$self->get_LOGGER->warn("Failed to remove element because ${subname} not an array for non-existent id:\$id");
} else {
\$self->get_LOGGER->warn("Failed to remove element for non-existent id:\$id");
}
return;
}
\=head2 get\u${subname}ById()
get specific element from the array of ${subname} elements by id ( if id is supported by this element )
Accepts single param - id
if there is no array then it will return just an object
\=cut
sub get\u${subname}ById {
my (\$self, \$id) = \@_;
if(ref(\$self->get_$subname) eq 'ARRAY' && \$self->get_idmap->{$subname} &&
exists \$self->get_idmap->{$subname}{\$id} ) {
return \$self->get_$subname->\[\$self->get_idmap->{$subname}{\$id}\];
} elsif(!ref(\$self->get_$subname) || ref(\$self->get_$subname) ne 'ARRAY') {
return \$self->get_$subname;
}
\$self->get_LOGGER->warn("Requested element for non-existent id:\$id");
return;
}
/
);
}
}
$self
->sayIt(
qq/
\=head2 querySQL ()
depending on SQL mapping declaration it will return some hash ref to the declared fields
for example querySQL ()
Accepts one optional parameter - query hashref, it will fill this hashref
will return:
{ <table_name1> => {<field name1> => <value>, ...},...}
\=cut
sub querySQL {
my (\$self, \$query) = \@_;
/
);
if
(
$element
->{sql}) {
$self
->saying(
" my \%defined_table = ("
);
foreach
my
$table
(
keys
%{
$element
->{sql}}) {
$self
->saying(
" '$table' => ["
);
foreach
my
$field
(
keys
%{
$element
->{sql}->{
$table
}}) {
$self
->saying(
" '$field', "
);
}
$self
->saying(
" ], "
);
}
$self
->sayIt(
" );"
);
}
foreach
my
$subname
(
keys
%sql_pass
) {
foreach
my
$table
(
keys
%{
$sql_pass
{
$subname
}}) {
foreach
my
$entry
(
keys
%{
$sql_pass
{
$subname
}{
$table
}}) {
$self
->saying(
" \$query->{$table}{$entry}= ["
);
foreach
my
$nss
(
keys
%{
$self
->{_known_class}->{
$subname
}}) {
$self
->saying(
" '"
.
$self
->{_known_class}->{
$subname
}{
$nss
} .
"',"
);
}
$self
->sayIt(
" ];"
);
}
}
}
foreach
my
$subname
(
keys
%sql_here
) {
foreach
my
$table
(
keys
%{
$sql_here
{
$subname
}}) {
foreach
my
$entry
(
keys
%{
$sql_here
{
$subname
}{
$table
}}) {
$self
->sayIt(
" \$query->{$table}{$entry}= [ '$className' ] if!(defined \$query->{$table}{$entry}) || ref(\$query->{$table}{$entry});"
);
}
}
}
if
(
$elements_names
) {
$self
->sayIt(
qq!
foreach my \$subname (qw/$elements_names/) {
if(\$self->{\$subname} && (ref(\$self->{\$subname}) eq 'ARRAY' || blessed \$self->{\$subname})) {
my \@array = ref(\$self->{\$subname}) eq 'ARRAY'?\@{\$self->{\$subname}}:(\$self->{\$subname});
foreach my \$el (\@array) {
if(blessed \$el && \$el->can('querySQL')) {
\$el->querySQL(\$query);
\$self->get_LOGGER->debug("Querying $name for subclass \$subname");
} else {
\$self->get_LOGGER->logdie("Failed for $name Unblessed member or querySQL is not implemented by subclass \$subname");
}
}
}
}
!
);
}
if
(
%sql_here
) {
$self
->sayIt(
qq/
eval {
foreach my \$table ( keys \%defined_table) {
foreach my \$entry (\@{\$defined_table{\$table}}) {
if(ref(\$query->{\$table}{\$entry}) eq 'ARRAY') {
foreach my \$classes (\@{\$query->{\$table}{\$entry}}) {
if(\$classes && \$classes eq '$className') {
/
);
my
$if_sub_cond
=
' if '
;
foreach
my
$subname
(
@attributes
,
'text'
) {
if
(
$sql_here
{
$subname
}) {
$self
->sayIt(_getSQLSub(
$sql_here
{
$subname
},
$subname
,
$if_sub_cond
));
$if_sub_cond
=
' elsif '
;
}
}
$self
->sayIt(
qq/
}
}
}
}
}
};
if(\$EVAL_ERROR) {
\$self->get_LOGGER->logdie("SQL query building is failed here " . \$EVAL_ERROR);
}
/
);
}
$self
->sayIt(
" return \$query;"
);
$self
->sayIt(
"}"
);
$self
->sayIt(
qq/
\=head2 buildIdMap()
if any of subelements has id then get a map of it in form of
hashref to { element}{id} = index in array and store in the idmap field
\=cut
sub buildIdMap {
my \$self = shift;
my \%map = ();
/
);
if
(
@elementnodes
) {
$self
->sayIt(
qq"
foreach my \$field (qw/$elements_names/) {
my \@array = ref(\$self->{\$field}) eq 'ARRAY'?\@{\$self->{\$field}}:(\$self->{\$field});
my \$i = 0;
foreach my \$el (\@array) {
if(\$el && blessed \$el && \$el->can('get_id') && \$el->get_id) {
\$map{\$field}{\$el->get_id} = \$i;
}
\$i++;
}
}
return \$self->set_idmap(\\\%map);
"
);
}
else
{
$self
->sayIt(
" return;"
);
}
$self
->sayIt(
"}"
);
$self
->sayIt(
qq/
\=head2 asString()
shortcut to get DOM and convert into the XML string
returns nicely formatted XML string representation of the $name object
\=cut
sub asString {
my \$self = shift;
my \$dom = \$self->getDOM();
return \$dom->toString('1');
}
\=head2 registerNamespaces ()
will parse all subelements
returns reference to hash with namespace prefixes
most parsers are expecting to see namespace registration info in the document root element declaration
\=cut
sub registerNamespaces {
my (\$self, \$nsids) = \@_;
my \$local_nss = {reverse \%{\$self->get_nsmap->mapname}};
unless(\$nsids) {
\$nsids = \$local_nss;
} else {
\%{\$nsids} = (\%{\$local_nss}, \%{\$nsids});
}
/
);
if
(
@elementnodes
) {
$self
->sayIt(
qq"
foreach my \$field (qw/$elements_names/) {
my \@array = ref(\$self->{\$field}) eq 'ARRAY'?\@{\$self->{\$field}}:(\$self->{\$field});
foreach my \$el (\@array) {
if(blessed \$el && \$el->can('registerNamespaces') ) {
my \$fromNSmap = \$el->registerNamespaces(\$nsids);
my \%ns_idmap = \%{\$fromNSmap};
foreach my \$ns (keys \%ns_idmap) {
\$nsids->{\$ns}++;
}
}
}
}
"
);
}
$self
->sayIt(
" return \$nsids;"
);
$self
->sayIt(
"}"
);
$self
->sayIt(
qq/
\=head2 fromDOM (\$)
accepts parent XML DOM element tree as parameter
returns $name object
\=cut
sub fromDOM {
my (\$self, \$dom) = \@_;
/
);
print
(
" fromDOM for: name=$name "
)
if
$self
->DEBUG>2;
foreach
my
$attr
(
@attributes
) {
print
(
" fromDOM for: "
. Dumper
$element
->{attrs})
if
$self
->DEBUG>2;
$self
->sayIt(
$self
->_printConditional(
$attr
,
$element
->{attrs}->{
$attr
},
'set'
));
$self
->sayIt(
" \$self->get_LOGGER->debug(\"Attribute $attr= \". \$self->get_$attr) if \$self->get_$attr;"
);
}
$self
->sayIt(
$self
->_printConditional(
'text'
,
$element
->{text},
'set'
))
if
(
$element
->{text});
if
(
@elements
) {
$self
->sayIt(
qq/ foreach my \$childnode (\$dom->childNodes) {
my \$getname = \$childnode->getName;
my (\$nsid, \$tagname) = split \$COLUMN_SEPARATOR, \$getname;
next unless(\$nsid && \$tagname);
my \$element;
/
);
my
$conditon_head
=
' if'
;
foreach
my
$els
(
@elementnodes
) {
croak(
"Element must be an array ref here: name=$name els=$els"
)
unless
ref
(
$els
) eq
'ARRAY'
;
print
"fromDOM subelement: "
. Dumper
$els
if
$self
->DEBUG > 3;
my
$subname
=
$els
->[0];
my
$condition
= _conditionParser(
$els
->[2]);
$condition
->{logic} .=
" && "
if
$condition
->{logic};
print
" fromDOM choice sub_subelement: "
. Dumper
$els
->[1]
if
$self
->DEBUG > 3;
if
(
ref
(
$els
->[1]) eq
'ARRAY'
) {
if
(
scalar
@{
$els
->[1]} > 1) {
foreach
my
$choice
(@{
$els
->[1]}) {
if
(
ref
(
$choice
) ne
'ARRAY'
) {
$self
->_printFromDOM(
$subname
,
$choice
,
'CHOICE'
,
$conditon_head
,
$condition
->{logic});
$conditon_head
=
' elsif'
;
}
elsif
(
scalar
@{
$choice
} == 1 ) {
$self
->_printFromDOM(
$subname
,
$choice
->[0],
'ARRAY'
,
$conditon_head
,
$condition
->{logic});
$conditon_head
=
' elsif'
;
}
else
{
croak(
" Malformed element definition: name=$name subelement=$subname"
);
}
}
}
else
{
my
$sub_el
=
ref
$els
->[1]->[0] eq
'ARRAY'
?
$els
->[1]->[0]->[0]:
$els
->[1]->[0];
print
" fromDOM 0 from sub_subelement: "
. Dumper
$els
->[1]->[0]
if
$self
->DEBUG > 3;
$self
->_printFromDOM(
$subname
,
$sub_el
,
'ARRAY'
,
$conditon_head
,
$condition
->{logic});
}
}
elsif
(
ref
(
$els
->[1]) eq
'HASH'
) {
$self
->_printFromDOM(
$subname
,
$els
->[1],
'HASH'
,
$conditon_head
,
$condition
->{logic});
}
$conditon_head
=
' elsif'
;
}
if
(
@textnodes
) {
$self
->sayIt(
" $conditon_head (\$childnode->textContent && \$self->can(\"get_\$tagname\")) {"
);
$self
->sayIt(
" \$self->{\$tagname} = \$childnode->textContent; ## text node"
);
$self
->sayIt(
" }"
);
}
$self
->sayIt(
" }"
);
$self
->sayIt(
" \$self->buildIdMap;\n \$self->registerNamespaces;"
);
}
$self
->sayIt(
" return \$self;\n}"
);
$self
->sayIt(
$self
->footer->asString());
$self
->_fh->
close
;
return
;
}
sub
_placeCritidy {
my
(
$self
) =
@_
;
my
$basename
=
$self
->top_dir .
'/'
.
$self
->test_dir .
'/conf'
;
unless
( -e
"$basename/perltidyrc"
) {
$self
->_fh(IO::File->new(
"$basename/perltidyrc"
,
'w+'
));
$self
->sayIt(
qq{# PBP .perltidyrc file
-i=4 # Indent level is 4 cols
-ci=4 # Continuation indent is 4 cols
-st # Output to STDOUT
-b # backup original to .bak and modify file in-place
-se # Errors to STDERR
-vt=0 # Maximal vertical tightness
-cti=0 # No extra indentation for closing brackets
-pt=1 # Medium parenthesis tightness
-lp # line up parentheses, brackets, and non-BLOCK braces
-bt=1 # Medium brace tightness
-ce # cuddled else; use this style: '\}
else
\{'
-bar
-sbt=1
-bbt=1
-nolq
-nsfs
-nolq
-wbb=
"% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= && += -= /= |= >>= ||= .= %= ^= x="
});
}
unless
( -e
"$basename/perlcritic"
) {
$self
->_fh(IO::File->new(
"$basename/perlcritic"
,
'w+'
));
$self
->sayIt(
qq{
severity = 2
only = 1
theme = (pbp + core + bugs + readability)
## layout according to the supplied perltidy
[CodeLayout::RequireTidyCode]
perltidyrc = $basename/perltidyrc
#--------------------------------------------------------------
# I think these are really important, so always load them
[TestingAndDebugging::RequireUseStrict]
severity = 5
[TestingAndDebugging::RequireUseWarnings]
severity = 5
[Variables::ProhibitLocalVars]
severity = 5
#--------------------------------------------------------------
# I think these are less important, so only load when asked
[Variables::ProhibitPackageVars]
severity = 1
[ControlStructures::ProhibitPostfixControls]
allow = if unless
severity = 2
#--------------------------------------------------------------
# I do not agree with these at all or their
# presence may create more worse than good
# or they depend on the personal taste and not reason
[-NamingConventions::ProhibitMixedCaseVars]
[-NamingConventions::ProhibitMixedCaseSubs]
[-ControlStructures::ProhibitUnlessBlocks]
[-Documentation::RequirePodSections]
[-Documentation::RequirePodAtEnd]
[-TestingAndDebugging::ProhibitNoStrict]
[-Subroutines::ProhibitExcessComplexity]
[-Miscellanea::RequireRcsKeywords]
[-ValuesAndExpressions::ProhibitNoisyQuotes]
[-ValuesAndExpressions::ProhibitInterpolationOfLiterals]
[-CodeLayout::ProhibitParensWithBuiltins]
[-CodeLayout::ProhibitTrailingWhitespace]
#--------------------------------------------------------------
}
);
}
return
;
}
Hide Show 15 lines of Pod
sub
buildTest {
my
(
$self
,
$elementnodes
,
$attributes
,
$className
,
$name
,
$element
) =
@_
;
my
$relative_path
=
$self
->top_dir .
'/'
.
$self
->test_dir;
mkpath ([
$relative_path
], 1, 0755);
mkpath ([
"$relative_path/conf"
], 1, 0755);
print
"Creating perlcritic and perltidyrc config files ... "
if
$self
->DEBUG > 0;
$self
->_placeCritidy();
print
" Creating simple test.pl file "
if
$self
->DEBUG > 0;
unless
(-e
$self
->top_dir .
"/test.pl"
) {
$self
->_fh(IO::File->new(
$self
->top_dir .
"/test.pl"
,
"w+"
));
$self
->sayIt(
qq{use strict;
use warnings;
use Test::Harness;
use FindBin qw(\$Bin);
BEGIN \{
unshift \@INC, "\$Bin" ;
unshift \@INC, "\$Bin/../";
\}
;
if
(\
$ARGV
[0] && \
$ARGV
[0] eq
'-v'
) \{
\
$Test::Harness::Verbose
= 1;
shift
\
@ARGV
;
\}
Test::Harness::runtests(<\
$Bin
/t/*.t>);
});
}
print
" Creating test suit... "
if
$self
->DEBUG > 0;
(
my
$test_filename
=
$className
) =~ s/(\w)\:\:(\w)/$1\_\_$2/g;
$self
->_fh(IO::File->new(
"$relative_path/$test_filename.t"
,
"w+"
));
croak(
" Failed to open test suite file: $! $relative_path/$test_filename.t"
)
unless
$self
->_fh;
my
$test_number
= 2;
my
$ns
=
$element
->{attrs}->{xmlns};
$self
->sayIt(
qq/
use warnings;
use strict;
use Test::More;
use Data::Dumper;
use FindBin qw(\$Bin);
use Log::Log4perl qw(:easy :levels);
use English qw( -no_match_vars);
/
);
$self
->sayIt(
'use Test::Perl::Critic (-severity => 3, -verbose => 4, -profile => "$Bin/conf/perlcritic");'
);
$self
->sayIt(
qq/
## see BEGIN block at the bottom for the number of tests and use_ok package check
Log::Log4perl->easy_init(\$ERROR);
/
);
my
@element_names
=
map
{
$_
->[0]} @{
$elementnodes
};
foreach
my
$el
(
@element_names
) {
foreach
my
$ns
(
keys
%{
$self
->{_known_class}->{
$el
}}) {
if
(
$self
->{_known_class}->{
$el
}{
$ns
}) {
$self
->sayIt(
"use_ok '"
.
$self
->{_known_class}->{
$el
}{
$ns
} .
"';"
);
$self
->sayIt(
"#"
,
$test_number
++);
}
}
}
$self
->sayIt(
"#"
,
$test_number
++);
$self
->sayIt(
'critic_ok("$Bin/../'
.
$self
->project_root . "/
" . $self->datatypes_root . "
/" .
$self
->{_schema_version_dir} .
"/$ns"
.
$self
->_dirPath . '.pm
", "
perl critic have not found any problems")
or diag(
" perl critic found problems "
);');
my
$accessors
=
'get_nsmap get_idmap '
.
join
(
' '
,
map
{
"get_$_"
} @{
$attributes
},
@element_names
);
$self
->sayIt(
"#"
,
$test_number
++);
$self
->sayIt(
"can_ok($className->new(), qw/$accessors/);"
);
$self
->sayIt(
qq/
my \$obj1 = undef;
#$test_number
eval {
\$obj1 = $className->new({
/
);
map
{
$self
->saying(
" '$_' => 'value_$_',"
)} @{
$attributes
};
$self
->sayIt(
" })\n};\nok(\$obj1 && !\$EVAL_ERROR, \"Create object $className...\") or diag(\$EVAL_ERROR);\n undef \$EVAL_ERROR;"
);
$self
->sayIt(
'#'
, ++
$test_number
);
$self
->sayIt(
"my \$ns = \$obj1->get_nsmap->mapname('$name');"
);
$self
->sayIt(
"ok(\$ns eq '"
.
$element
->{attrs}->{xmlns} .
"', \" mapname('$name')... \");"
);
foreach
my
$att
(@{
$attributes
}) {
$self
->sayIt(
'#'
, ++
$test_number
);
$self
->sayIt(
"my \$$att = \$obj1->get_$att;"
);
$self
->sayIt(
"ok(\$$att eq 'value_$att', \"Checking accessor obj1->get_$att ... \") or diag(' Accessor test failed ');"
);
}
foreach
my
$subel
(@{
$elementnodes
}) {
my
$subel1
= (
ref
(
$subel
->[1]) eq
'ARRAY'
)?
((
ref
(
$subel
->[1]->[0]) eq
'ARRAY'
)?
$subel
->[1]->[0]->[0]:
$subel
->[1]->[0]):
((
ref
(
$subel
->[1]) eq
'HASH'
)?
$subel
->[1]:
undef
);
next
unless
$subel1
;
$self
->sayIt(
'#'
, ++
$test_number
);
my
$subel_name
=
$subel
->[0];
$self
->sayIt(
"my \$obj_$subel_name;"
);
$self
->sayIt(
'eval {'
);
$self
->saying(
" \$obj_$subel_name = "
.
$self
->{_known_class}->{
$subel_name
}{
$subel1
->{attrs}->{xmlns}} .
"->new({"
);
map
{
$self
->saying(
" '$_' => 'value$_',"
)
if
$_
ne
'xmlns'
&&
$subel1
->{attrs}->{
$_
}}
keys
%{
$subel1
->{attrs}};
$self
->sayIt(
' });'
);
(
ref
(
$subel
->[1]) eq
'ARRAY'
&& $
$self
->sayIt(
" \$obj1->set_$subel_name(\$obj_$subel_name);"
);
$self
->sayIt(
'};'
);
$self
->sayIt(
"ok(\$obj_$subel_name && \!\$EVAL_ERROR, \"Create subelement object $subel_name and set it\") or diag(\$EVAL_ERROR);"
);
$self
->sayIt(
'undef $EVAL_ERROR;'
);
}
$self
->sayIt(
'#'
, ++
$test_number
);
$self
->sayIt(
'my $string;'
);
$self
->sayIt(
'eval {'
);
$self
->sayIt(
' $string = $obj1->asString'
);
$self
->sayIt(
'};'
);
$self
->sayIt(
'ok($string && !$EVAL_ERROR, "Converting to XML string: $string") or diag($EVAL_ERROR);'
);
$self
->sayIt(
'undef $EVAL_ERROR;'
);
$self
->sayIt(
'#'
, ++
$test_number
);
$self
->sayIt(
'my $obj22;'
);
$self
->sayIt(
'eval {'
);
$self
->sayIt(
" \$obj22 = $className->new({xml => \$string});"
);
$self
->sayIt(
'};'
);
$self
->sayIt(
'ok($obj22 && !$EVAL_ERROR, "Re-create object from XML string: ") or diag($EVAL_ERROR);'
);
$self
->sayIt(
'undef $EVAL_ERROR;'
);
$self
->sayIt(
'#'
, ++
$test_number
);
$self
->sayIt(
'my $dom1 = $obj1->getDOM();'
);
$self
->sayIt(
'my $obj2;'
);
$self
->sayIt(
'eval {'
);
$self
->sayIt(
" \$obj2 = $className->new(\$dom1);"
);
$self
->sayIt(
'};'
);
$self
->sayIt(
'ok($obj2 && !$EVAL_ERROR, "Re-create object from DOM XML: ") or diag($EVAL_ERROR);'
);
$self
->sayIt(
'undef $EVAL_ERROR;'
);
$self
->sayIt(
qq!
BEGIN {
plan tests => $test_number;
use_ok '$className';
}
1;
!
);
$self
->_fh->
close
;
}
sub
_printGetArrayDom {
my
(
$self
,
$subname
,
$name
,
$logic
) =
@_
;
$self
->sayIt(
qq/
if($logic\$self->get_$subname && ref(\$self->get_$subname) eq 'ARRAY') {
foreach my \$subel (\@{\$self->get_$subname}) {
if(blessed \$subel && \$subel->can("getDOM")) {
my \$subDOM = \$subel->getDOM(\$$name);
\$subDOM?\$$name->appendChild(\$subDOM):\$self->get_LOGGER->logdie("Failed to append $subname element with value:" . \$subDOM->toString);
}
}
}
/
);
}
sub
_printGetDOM {
my
(
$self
,
$subname
,
$name
,
$cond_string
) =
@_
;
$self
->sayIt(
qq/
if($cond_string\$self->get_$subname && blessed \$self->get_$subname && \$self->get_$subname->can("getDOM")) {
my \$${subname}DOM = \$self->get_$subname->getDOM(\$$name);
\$${subname}DOM?\$$name->appendChild(\$${subname}DOM):\$self->get_LOGGER->logdie("Failed to append $subname element with value:" . \$${subname}DOM->toString);
}
/
);
}
sub
_conditionParser {
my
$value
=
shift
;
my
$result
= {
condition
=>
''
,
logic
=>
''
,
regexp
=>
''
};
return
$result
unless
$value
;
$value
=~ s/^(
scalar
|enum|set|
if
|
unless
|exclude)\:?//;
$result
->{condition} = $1;
my
@list
=
split
","
,
$value
unless
$result
->{condition} eq
'scalar'
;
if
(
@list
) {
$result
->{logic} =
"(\$self->get_"
. (
join
" && \$self->get_"
,
@list
) .
")"
;
$result
->{regexp} =
" =~ m/("
. (
join
"|"
,
@list
) .
")\$/"
;
if
(
$result
->{condition} eq
'unless'
) {
$result
->{logic} =
"!"
.
$result
->{logic};
}
elsif
(
$result
->{condition} eq
'exclude'
) {
$result
->{regexp} =~ s/\=\~/\!\~/;
}
}
return
$result
;
}
sub
_printConditional {
my
(
$self
,
$key
,
$value
,
$what
) =
@_
;
my
$string
;
my
$arrayref_signleft
= (
$key
ne
'text'
)?
"["
:
''
;
my
$arrayref_signright
= (
$key
ne
'text'
)?
"]"
:
''
;
my
$fromDomArg
= (
$key
ne
'text'
)?
"\$dom->getAttribute('$key')"
:
"\$dom->textContent"
;
my
$condition
= _conditionParser(
$value
);
print
(
"$value Enum List:: "
. (
join
":"
,
map
{
" $_= "
.
$condition
->{
$_
}}
keys
%{
$condition
}))
if
$self
->DEBUG > 0 && !
$condition
->{condition} eq
'scalar'
;
if
(
$condition
->{condition} eq
'scalar'
) {
$string
=
$what
eq
'get'
?
" $arrayref_signleft'$key' => \$self->$what\_$key$arrayref_signright,\n"
:
" \$self->$what\_$key($fromDomArg) if($fromDomArg);\n"
;
}
elsif
(
$condition
->{condition} =~ /^
if
|
unless
$/ &&
$condition
->{logic}) {
$string
=
$what
eq
'get'
?
" $arrayref_signleft '$key' => ("
.
$condition
->{logic}.
"?\$self->$what\_$key:undef)$arrayref_signright,\n"
:
" \$self->$what\_$key($fromDomArg) if("
.
$condition
->{logic}.
" && $fromDomArg);\n"
;
}
elsif
(
$condition
->{condition} =~ /enum|set|exclude/ &&
$condition
->{regexp}) {
my
$regexp
=
$what
eq
'get'
?
"(\$self->$what\_$key "
.
$condition
->{regexp} .
")"
:
"($fromDomArg "
.
$condition
->{regexp} .
")"
;
$string
=
$what
eq
'get'
?
" $arrayref_signleft'$key' => ($regexp?\$self->$what\_$key:undef)$arrayref_signright,\n"
:
" \$self->$what\_$key($fromDomArg) if($fromDomArg && $regexp);\n"
;
}
else
{
croak(
"Malformed , unknown condition="
.
$condition
->{condition} );
}
return
$string
;
}
sub
_getSQLSub {
my
(
$sql_fields
,
$subname
,
$if_cond
) =
@_
;
my
$head_string
=
" $if_cond(\$self->get_$subname && ("
;
my
$add
=
' '
;
foreach
my
$table
(
keys
%{
$sql_fields
}) {
$head_string
.=
"$add( "
;
my
@cond_string
= ();
foreach
my
$field
(
keys
%{
$sql_fields
->{
$table
}}) {
my
$cond
=
$sql_fields
->{
$table
}{
$field
};
$cond
.=
' && '
if
$cond
;
push
@cond_string
,
" ($cond\$entry eq '$field')"
;
}
$head_string
.= (
join
" or "
,
@cond_string
) .
")"
;
$add
=
' || '
;
}
$head_string
.=
" )) {\n"
;
$head_string
.=
" \$query->{\$table}{\$entry} = \$self->get_$subname;\n"
;
$head_string
.=
" \$self->get_LOGGER->debug(\" Got value for SQL query \$table.\$entry: \" . \$self->get_$subname);\n"
;
$head_string
.=
" last; \n"
;
$head_string
.=
" }\n"
;
return
$head_string
;
}
sub
_printFromDOM {
my
(
$self
,
$subname
,
$el
,
$type
,
$conditon_head
,
$cond_string
) =
@_
;
my
$subnameUP
=
ucfirst
(
$subname
);
my
$ns
=
$el
->{
'attrs'
}{
'xmlns'
};
print
"Building fromDOM: type=$type subname=$subname head=$conditon_head string=$cond_string ns=$ns class="
.
$self
->{_known_class}->{
$subname
}{
$ns
} .
"\n"
if
$self
->DEBUG > 2;
$self
->sayIt(
" $conditon_head ($cond_string\$tagname eq '$subname' && \$nsid eq '"
.
$el
->{'attrs
'}{'
xmlns
'} ."'
&& \
$self
->can(\"get_\
$tagname
\")) {");
$self
->sayIt(
" eval {"
);
$self
->sayIt(
" \$element = "
.
$self
->{_known_class}->{
$subname
}{
$el
->{
'attrs'
}{
'xmlns'
}} .
"->new(\$childnode)"
);
$self
->sayIt(
" };"
);
$self
->sayIt(
" if(\$EVAL_ERROR || !(\$element && blessed \$element)) {"
);
$self
->sayIt(
" \$self->get_LOGGER->logdie(\" Failed to load and add $subnameUP : \" . \$dom->toString . \" error: \" . \$EVAL_ERROR);"
);
$self
->sayIt(
" return;"
);
$self
->sayIt(
" }"
);
$self
->sayIt(((
$type
eq
'ARRAY'
)?" (\
$self
->get_
$subname
&&
ref
(\
$self
->get_
$subname
) eq
'ARRAY'
)?
push
\@{\
$self
->get_
$subname
}, \
$element
:
\
$self
->set_
$subname
([\
$element
]);":
" \$self->set_$subname(\$element)"
) .
"; ### add another $subname "
);
$self
->sayIt(
" } "
);
}
Hide Show 6 lines of Pod
sub
saying {
my
(
$self
,
@string
) =
@_
;
croak(
"Filehandle must be set"
)
unless
$self
->_fh &&
$self
->_fh->isa(
'IO::File'
);
$self
->_fh->
print
(
join
''
,
@string
);
}
Hide Show 6 lines of Pod
sub
sayIt {
my
(
$self
,
@string
) =
@_
;
$self
->saying(
@string
);
$self
->_fh->
print
(
"\n"
);
}
sub
_printHelpers {
my
(
$self
) =
@_
;
my
$root_package
=
$self
->project_root .
'::'
.
$self
->datatypes_root .
'::'
.
$self
->{_schema_version_dir};
mkpath ([
$self
->top_dir .
'/'
.
$self
->project_root .
'/'
.
$self
->datatypes_root .
'/'
.
$self
->{_schema_version_dir} ], 1, 0755);
$self
->_fh(IO::File->new(
$self
->top_dir .
"/"
.
$self
->project_root .
'/'
.
$self
->datatypes_root .
"/"
.
$self
->{_schema_version_dir} .
"/Element.pm"
,
"w+"
));
croak(
"Failed to open Element.pm file"
)
unless
$self
->_fh;
my
$registry_string
;
foreach
my
$prefix
(
keys
%{
$self
->nsregistry}) {
$registry_string
.=
" '$prefix' => '"
.
$self
->nsregistry->{
$prefix
} .
"',\n"
;
}
my
$element_package
=
"$root_package\:\:Element"
;
my
$nsmap_package
=
"$root_package\:\:NSMap"
;
my
$version
=
$self
->schema_version;
$self
->sayIt(
qq/package $element_package;
use strict;
use warnings;
use version;our \$VERSION = qw("$version");
use base 'Exporter';
\=head1 NAME
$element_package - static class for basic element manipulations
\=head1 DESCRIPTION
it exports only single call - getElement which allows to create XML DOM out of perl object
This module was automatically build by L<XML::RelaxNG::Compact::PXB>.
\=cut
our \@EXPORT_OK = qw(\&getElement);
use Readonly;
use Scalar::Util qw(blessed);
use XML::LibXML;
use Log::Log4perl qw(get_logger);
use Data::Dumper;
Readonly::Scalar our \$CLASSPATH => '$element_package';
Readonly::Hash our %NSREGISTRY => ($registry_string);
our \$LOGGER = get_logger(\$CLASSPATH);
\=head1 METHODS
\=head2 getElement ()
create element from some data struct and return it as DOM
accepts 1 parameter - hashref to hash of keyd parameters
where:
'name' => name of the element
'ns' => [ namespace id1, namespace id2 ...] array ref
'parent' => parent DOM if provided ( element will be created in context of the parent),
'attributes' => arrayref to the array of attributes pairs,
where to get i-th attribute one has to \$attr->[i]->[0] for name and \$attr->[i]->[1] for value
'text' => <CDATA>
creates new element, returns this element
\=back
\=cut
sub getElement {
my \$param = shift;
my \$data;
unless(\$param && ref(\$param) eq 'HASH' && \$param->{name}) {
\$LOGGER->logdie(" Need single hashref parameter as { name => '', parent => DOM_obj, attributes => [], text => ''} with at least name key defined");
}
my \$name = \$param->{name};
my \$attrs = \$param->{attributes};
my \$text = \$param->{text};
my \$nss = \$param->{ns}; ## reference to array ref with ns prefixes for this element
if(\$param->{parent} && blessed(\$param->{parent}) && \$param->{parent}->isa('XML::LibXML::Document')) {
\$data = \$param->{parent}->createElement(\$name);
} else {
\$data = XML::LibXML::Element->new(\$name);
}
## validation of the namespace prefixes registered
if(\$nss) {
foreach my \$ns (\@{\$nss}) {
next unless \$ns;
unless(\$NSREGISTRY{\$ns}) {
\$LOGGER->error("Attempted to create element with un-supported namespace prefix");
}
\$data->setNamespace(\$NSREGISTRY{\$ns}, \$ns, 1);
}
} else {
\$LOGGER->error("Attempted to create element without namespace");
}
if((\$attrs && ref(\$attrs) eq 'ARRAY') || \$text) {
if(\$attrs && ref(\$attrs) eq 'ARRAY') {
foreach my \$attr (\@{\$attrs}) {
if(\$attr->[0] && \$attr->[1]) {
unless(ref(\$attr->[1])) {
\$data->setAttribute(\$attr->[0], \$attr->[1]);
} else {
\$LOGGER->warn("Attempted to create ".\$attr->[0]." with this: ".\$attr->[1]." dump:" . sub { Dumper(\$attr->[1])});
}
}
}
}
if(\$text) {
unless(ref(\$text)) {
my \$text_el = XML::LibXML::Text->new(\$text);
\$data->appendChild(\$text_el);
} else {
\$LOGGER->warn(" Attempted to create text with non scalar: \$text dump:" . sub {Dumper(\$text)});
}
}
} else {
\$LOGGER->warn(" Attempted to create empty element with name \$name, failed to do so, will return undef ");
}
return \$data;
}
/
);
$self
->sayIt(
$self
->footer->asString());
$self
->_fh(IO::File->new(
$self
->top_dir .
"/"
.
$self
->project_root .
"/"
.
$self
->datatypes_root .
"/"
.
$self
->{_schema_version_dir} .
"/NSMap.pm"
,
"w+"
));
croak(
" Failed to open NSMap.pm file"
)
unless
$self
->_fh;
$self
->sayIt(
qq/package $nsmap_package;
use strict;
use warnings;
use version;our \$VERSION = qv("$version");
\=head1 NAME
$nsmap_package - element names to namespace prefix mapper
\=head1 DESCRIPTION
this class designed to map element localname to registered namespace, the object of this
class is supposed to be member of the each PXB binded object in order to allow propagation of the
registered namespaces throughout the API
\=head1 SYNOPSIS
use $nsmap_package;
my \$nsmap = $nsmap_package->new();
\$nsmap->mapname(\$ELEMENT_LOCALNAME, 'ns_prefix');
\=head1 METHODS
\=head2 new({})
new - constructor, accepts single parameter - hashref with the hash of:
<element_name> => <URI>,..., <element_name> => <URI> # mapped element on ns hashref
the namespace registry track relation between namespace URI and used prefix
\=cut
use Data::Dumper;
use Readonly;
use Log::Log4perl qw(get_logger);
use fields qw(nsmap);
Readonly::Scalar our \$CLASSPATH => '$nsmap_package';
our \$LOGGER = get_logger(\$CLASSPATH);
sub new {
my (\$class, \$param) = \@_;
\$class = ref(\$class) || \$class;
my \$self = fields::new(\$class);
if (\$param) {
unless( ref(\$param) eq 'HASH') {
\$LOGGER->logdie("ONLY hash ref accepted as param and not: " . Dumper \$param );
}
foreach my \$key (keys \%{\$param}) {
\$self->mapname(\$key => \$param->{\$key});
}
} else {
\$self->{nsmap} = {};
}
return \$self;
}
\=head2 mapname()
maps localname on the prefix
accepts:
with single parameter ( element name ) it will return
namespace prefix and with two parameters it will map namespace prefix
to specific element name
and without parameters it will return the whole namespaces hashref
\=cut
sub mapname {
my (\$self, \$element, \$nsid) = \@_;
if (\$element && \$nsid) {
\$self->{nsmap}->{\$element} = \$nsid;
return \$self;
} elsif(\$element && \$self->{nsmap}->{\$element} && !\$nsid) {
return \$self->{nsmap}->{\$element};
} elsif(!\$nsid && !\$element) {
return \$self->{nsmap};
}
return;
}
/
);
$self
->buildAM([
qw/nsmap/
]);
$self
->sayIt(
$self
->footer->asString());
}
Hide Show 15 lines of Pod
1;