package perfSONAR_PS::DataModels::APIBuilder; =head1 NAME perfSONAR_PS::DataModels::APIBuilder - builder utils to build binding perl objects collection =head1 DESCRIPTION single call is here with several private ones the public call is: buildAPI(, , ,); =head1 SYNOPSIS ### use perfSONAR_PS::DataModels::DataModel qw($message); use perfSONAR_PS::DataModels::APIBuilderqw(&buildAPI $API_ROOT $TOP_DIR $DATATYPES_ROOT) ; $API_ROOT = 'perfSONAR_PS'; $TOP_DIR = "/tmp/API/" .$API_ROOT; $DATATYPES_ROOT = 'Datatypes'; buildAPI('message', $message, '','' ); #### =cut =head1 API =head2 Exported variables $API_ROOT - name of the API ( empty string by default) $TOP_DIR - top dirname of the API location( /tmp/API by default) $DATATYPES_ROOT - dirname for schema datamodel files =cut use strict; use warnings; use IO::File; use File::Path; use Data::Dumper; use Log::Log4perl qw(get_logger); BEGIN { use Exporter (); our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); use version; our $VERSION = 0.08; %EXPORT_TAGS = (); use base qw(Exporter); @EXPORT_OK = qw( ); @EXPORT_OK =qw( &buildAPI &buildClass $DATATYPES_ROOT $API_ROOT $TOP_DIR $SCHEMA_VERSION $TEST_DIR); } our @EXPORT_OK; our ( $API_ROOT, $TOP_DIR, $DATATYPES_ROOT, $SCHEMA_VERSION, $TEST_DIR) = ('', '/tmp/API', 'Datatypes', APIBuilder->VERSION, "$TOP_DIR/../"); my %known_classes = (); my %existed = (); my $logger = get_logger( "APIBuilder" ); # # prints second parameter ( string) to multiple filehandles passed as arrayref # sub printMulti { my ($fharr, $msg) = @_; foreach my $fh (@{$fharr}) { print $fh $msg; } } # # for new classname, path, root and ns will check if this package already exists and # then update path and root with appended classname and return root and path # where root is the API modules tree path and path is the directory pathname # without top dir name # sub _makeAPIPath { my ($classname, $path, $root, $ns) = @_; my $classnameUP = ucfirst($classname); print "ROOT= $API_ROOT\:\:$DATATYPES_ROOT\:\:$SCHEMA_VERSION\:\:$ns$root\:\:$classnameUP\n"; unless ( $existed{"$API_ROOT\:\:$DATATYPES_ROOT\:\:$SCHEMA_VERSION\:\:$ns$root\:\:$classnameUP"} ) { $path .= "/$classnameUP"; $root .= "\:\:$classnameUP"; $existed{ "$API_ROOT\:\:$DATATYPES_ROOT\:\:$SCHEMA_VERSION\:\:$ns$root" } = $classname; $known_classes{$classname}{$ns} = "$API_ROOT\:\:$DATATYPES_ROOT\:\:$SCHEMA_VERSION\:\:$ns$root" ; } return ($root, $path); } =head2 buildAPI builds the whole API recursively accepts four parameters - name of the root element - message by default - top hashref ( object to be built) - path ( empty by default ) - root API name ( empty by default ) =cut sub buildAPI { my ($name, $element, $path, $root, $parent ) = @_; my $ns = $element->{attrs}->{xmlns}; ($root, $path) = _makeAPIPath($name, $path, $root, $ns ); if( $element && ref($element) eq 'HASH' && $element->{attrs} ) { if (ref($element->{elements}) eq 'ARRAY') { mkpath ([ "$TOP_DIR/$DATATYPES_ROOT/$SCHEMA_VERSION/$ns/$path" ], 1, 0755) ; } foreach my $el (@{$element->{elements}}) { if(ref($el) eq 'ARRAY') { if(ref($el->[1]) eq 'HASH' && $el->[1]->{attrs}) { buildAPI($el->[0], $el->[1], $path, $root, $element ); } elsif(ref($el->[1]) eq 'ARRAY') { foreach my $sub_el (@{$el->[1]}) { if(ref($sub_el) eq 'HASH' && $sub_el->{attrs}) { buildAPI($el->[0], $sub_el, $path, $root, $element ); } elsif(ref($sub_el) eq 'ARRAY' && scalar @{$sub_el} == 1) { buildAPI($el->[0], $sub_el->[0], $path, $root, $element ); } else { $logger->error(" Malformed definition: name=" . $el->[0] . " Dump=" . Dumper $sub_el); } } } } } buildClass( "$TOP_DIR/$DATATYPES_ROOT/$SCHEMA_VERSION/$ns/$path", "$API_ROOT\:\:$DATATYPES_ROOT\:\:$SCHEMA_VERSION\:\:$ns$root" , $name, $element, $parent); } return; } =head2 buildClass builds single class on the filesystem and corresponded test file accepts four parameters - full path to the class ( except for .pm extension) - full package name - name of the element - hashref with the element definition - hashref with parent definition if its not the root element =cut sub buildClass { my ($path, $root, $name, $element, $parent ) = @_; my $className = $root; my $fh = IO::File->new( $path . ".pm","w+"); $logger->error(" Failed to open file :" . $path . ".pm") unless $fh; #------------------------------------------------------------------------------ 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 =(); ### hash with pass through my %sql_here =(); ### hash with sql to get here # preprocessing sql config 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) { $logger->error(" SQL config malformed for element=$name table=$table field=$field, but value is missied"); return; } my $condition = $element->{sql}->{$table}->{$field}->{if}; my ($attr_name, $set) = $condition?$condition =~ m/^(\w+):?(\w+)?$/:('',''); my $cond_string = $condition && $set?" (\$self->$attr_name eq '$set') ":$condition?" (\$self->$attr_name)":''; $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/) { #### if name of the possible element is among the members of this object the pass it there $sql_pass{$possible}{$table}{$field} = $cond_string; } else { ###### otherwise set it with some value ( text or attribute ) $sql_here{$possible}{$table}{$field} = $cond_string; } } } } } #-------------------------------------------- build tests buildTest(\@elementnodes, \@attributes, $className, $name, $element); $logger->debug("\n...... List of Attributes:$attributes_names \n Texts: $texts_names \n Elements: $elements_names\n"); #---------------------------------------------- ( my $version = $SCHEMA_VERSION ) =~ tr/_/./; #-------------------------------------------- print $fh <[0] . " => type " . ref($_->[1]) . ",\n" } @elements ; print $fh <new(\$DOM_Obj); =head1 METHODS =cut use XML::LibXML; use Scalar::Util qw(blessed); use Log::Log4perl qw(get_logger); use perfSONAR_PS::Datatypes::Element qw(getElement); use perfSONAR_PS::Datatypes::Namespace; use perfSONAR_PS::Datatypes::NSMap; use Readonly; EOB foreach my $el (@elementnodes) { foreach my $ns (keys %{$known_classes{$el->[0]}}) { print $fh "use " . $known_classes{$el->[0]}{$ns} . ";\n" if $known_classes{$el->[0]}{$ns}; } } print $fh <{text}; print $fh ");\n"; print $fh <mk_accessors($className->show_fields('Public')); =head2 new( ) creates object, accepts DOM with element tree or hashref to the list of keyd parameters EOD map { print $fh " $_ => undef, \n" } @attributes ; map { print $fh " " . $_->[0] . " => " . ref($_->[1]) . ",\n" } @elementnodes; print $fh "text => 'text'\n" if $element->{text}; print $fh < ':'; Readonly::Scalar our \$CLASSPATH => '$className'; Readonly::Scalar our \$LOCALNAME => '$name'; sub new { my \$that = shift; my \$param = shift; my \$logger = get_logger( \$CLASSPATH ); my \$class = ref(\$that) || \$that; my \$self = fields::new(\$class ); \$self->nsmap(perfSONAR_PS::Datatypes::NSMap->new()); EOF print $fh " \$self->nsmap->mapname( \$LOCALNAME, '" . $element->{attrs}->{xmlns} . "');\n"; print $fh <can('getName') && (\$param->getName =~ m/\$LOCALNAME\$/xm) ) { return \$self->fromDOM(\$param); } elsif(ref(\$param) ne 'HASH') { \$logger->error("ONLY hash ref accepted as param " . \$param ); return; } if(\$param->{xml}) { my \$parser = XML::LibXML->new(); my \$dom; eval { my \$doc = \$parser->parse_string( \$param->{xml}); \$dom = \$doc->getDocumentElement; }; if(\$EVAL_ERROR) { \$logger->error(" Failed to parse XML :" . \$param->{xml} . " \\n ERROR: \\n" . \$EVAL_ERROR); return; } return \$self->fromDOM( \$dom ); } \$logger->debug("Parsing parameters: " . (join " : ", keys \%{\$param})); no strict 'refs'; foreach my \$param_key (keys \%{\$param}) { \$self->\$param_key( \$param->{\$param_key} ) if \$self->can(\$param_key); } use strict; \$logger->debug("Done "); } return \$self; } sub DESTROY { my \$self = shift; \$self->SUPER::DESTROY if \$self->can("SUPER::DESTROY"); return; } =head2 getDOM (\$) accept parent DOM return $name object DOM, generated from object contents =cut sub getDOM { my \$self = shift; my \$parent = shift; my \$logger = get_logger( \$CLASSPATH ); my \$$name = getElement({name => \$LOCALNAME, parent => \$parent , ns => [\$self->nsmap->mapname( \$LOCALNAME )], attributes => [ EOG #------------------------------- foreach my $attr (@attributes) { $logger->debug("_printConditional:: $attr = " . $element->{attrs}->{$attr}); print $fh _printConditional( $attr, $element->{attrs}->{$attr}, 'get'); } print $fh " ],\n"; # end for attributes print $fh _printConditional( 'text', $element->{text} , 'get') if ($element->{text} ); print $fh " }); \n"; ### deal with subelements ### ### each subel defined as [ name => obj ] or [name => [obj]] or [name => [obj1,obj2]] or [name => [[obj1],[obj2]]] ### ### just object arrayref of objects choice between two obj chiice between two obj arrayref ### foreach my $els (@elementnodes) { $logger->fatal(" What the heck: name=$name els=$els ") 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') { printGetDOM($fh, $subname, $name, $condition->{logic}); } else { printGetArrayDom($fh, $subname, $name, $condition->{logic}); } } else { printGetArrayDom($fh, $subname, $name, $condition->{logic}); } } elsif(ref($els->[1]) eq 'HASH') { printGetDOM($fh, $subname, $name, $condition->{logic}); } } if( $texts_names ) { print $fh " foreach my \$textnode (qw/$texts_names /) {\n"; print $fh " if(\$self->{\$textnode}) { \n"; print $fh " my \$domtext = getElement({name => \$textnode, parent => \$$name , ns => [\$self->nsmap->mapname(\$LOCALNAME)],\n"; print $fh " text => \$self->{\$textnode},\n"; print $fh " });\n"; print $fh " \$domtext?\$$name->appendChild(\$domtext):\$logger->error(\"Failed to append new text element \$textnode to $name \");\n"; print $fh " } \n"; print $fh " } \n"; } print $fh " return \$$name;\n}\n"; foreach my $el (@elementnodes) { my $subname = $el->[0]; if(ref($el->[1]) eq 'ARRAY') { print $fh <$subname && ref(\$self->$subname) eq 'ARRAY'?push \@{\$self->$subname}, \$new:\$self->$subname([\$new]); \$logger->debug("Added new to $subname"); \$self->buildIdMap; ## rebuild index map \$self->buildRefIdMap; ## rebuild ref index map return \$self->$subname; } =head2 remove\u${subname}ById() remove 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 warninig if it removed some id then \$id will be returned =cut sub remove\u${subname}ById { my \$self = shift; my \$id = shift; my \$logger = get_logger( \$CLASSPATH ); if(ref(\$self->$subname) eq 'ARRAY' && \$self->idmap->{$subname} && exists \$self->idmap->{$subname}{\$id}) { \$self->$subname->\[\$self->idmap->{$subname}{\$id}\]->DESTROY; my \@tmp = grep { defined \$_ } \@{\$self->$subname}; \$self->$subname([\@tmp]); \$self->buildRefIdMap; ## rebuild ref index map \$self->buildIdMap; ## rebuild index map return \$id; } elsif(!ref(\$self->$subname) || ref(\$self->$subname) ne 'ARRAY') { \$logger->warn("Failed to remove element because ${subname} not an array for non-existent id:\$id"); } else { \$logger->warn("Failed to remove element for non-existant id:\$id"); } return; } =head2 get\u${subname}ByMetadataIdRef() get specific object from the array of ${subname} elements by MetadataIdRef( if MetadataIdRef is supported by this element ) accepts single param - MetadataIdRef if there is no array then it will return just an object =cut sub get\u${subname}ByMetadataIdRef { my \$self = shift; my \$id = shift; my \$logger = get_logger( \$CLASSPATH ); if(ref(\$self->$subname) eq 'ARRAY' && \$self->refidmap->{$subname} && exists \$self->refidmap->{$subname}{\$id}) { my \$$subname = \$self->$subname->\[\$self->refidmap->{$subname}{\$id}\]; return (\$$subname->can("metadataIdRef") && \$$subname->metadataIdRef eq \$id)?\$$subname:undef; } elsif(\$self->$subname && (!ref(\$self->$subname) || (ref(\$self->$subname) ne 'ARRAY' && blessed \$self->$subname && \$self->$subname->can("metadataIdRef") && \$self->$subname->metadataIdRef eq \$id))) { return \$self->$subname; } \$logger->warn("Requested element for non-existent metadataIdRef:\$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 = shift; my \$id = shift; my \$logger = get_logger( \$CLASSPATH ); if(ref(\$self->$subname) eq 'ARRAY' && \$self->idmap->{$subname} && exists \$self->idmap->{$subname}{\$id} ) { return \$self->$subname->\[\$self->idmap->{$subname}{\$id}\]; } elsif(!ref(\$self->$subname) || ref(\$self->$subname) ne 'ARRAY') { return \$self->$subname; } \$logger->warn("Requested element for non-existent id:\$id"); return; } EOH5 } } print $fh < 'hepnrc1.hep.net' },} =cut sub querySQL { my \$self = shift; my \$query = shift; ### undef at first and then will be hash ref my \$logger = get_logger( \$CLASSPATH ); EOH56 if($element->{sql}) { print $fh " my \%defined_table = ("; foreach my $table (keys %{$element->{sql}}) { print $fh " '$table' => ["; foreach my $field (keys %{$element->{sql}->{$table}}) { print $fh " '$field', "; } print $fh " ], "; } print $fh " );\n"; } foreach my $subname (keys %sql_pass) { foreach my $table (keys %{$sql_pass{$subname}}) { foreach my $entry (keys %{$sql_pass{$subname}{$table}}) { print $fh " \$query->{$table}{$entry}= ["; foreach my $nss (keys %{ $known_classes{$subname}}) { print $fh " '$known_classes{$subname}{$nss}',"; } print $fh " ];\n"; } } } foreach my $subname (keys %sql_here) { foreach my $table (keys %{$sql_here{$subname}}) { foreach my $entry (keys %{$sql_here{$subname}{$table}}) { print $fh " \$query->{$table}{$entry}= [ '$className' ] if!(defined \$query->{$table}{$entry}) || ref(\$query->{$table}{$entry});\n"; } } } if($elements_names) { print $fh <{\$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); \$logger->debug("Quering $name for subclass \$subname"); } else { \$logger->error(" Failed for $name Unblessed member or querySQL is not implemented by subclass \$subname"); } } } } EOH78 } if(%sql_here) { print $fh " eval { \n"; print $fh " foreach my \$table ( keys \%defined_table) { \n"; print $fh " foreach my \$entry (\@{\$defined_table{\$table}}) { \n"; print $fh " if(ref(\$query->{\$table}{\$entry}) eq 'ARRAY') {\n"; print $fh " foreach my \$classes (\@{\$query->{\$table}{\$entry}}) { \n"; print $fh " if(\$classes && \$classes eq '$className' ) { \n"; my $if_sub_cond = ' if '; foreach my $subname (@attributes, 'text') { if($sql_here{$subname}) { print $fh getSQLSub($sql_here{$subname}, $subname, $if_sub_cond ); $if_sub_cond = ' elsif '; } } print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; print $fh " }; \n if (\$EVAL_ERROR) { \$logger->logcroak(\" SQL query building is failed here \" . \$EVAL_ERROR)};\n"; } print $fh " return \$query;\n"; print $fh "}\n"; print $fh <can("getDOM")) { \$logger->error(" Please supply defined object of $name "); return; } ### for each field ( element or attribute ) ### merge elements, add if its arrayref and overwrite attribtues for the same elements ### merge only if namespace is the same foreach my \$member_name (\$new_${name}->show_fields) { ### double check if objects are the same if(\$self->can(\$member_name)) { my \$current_member = \$self->{\$member_name}; my \$new_member = \$new_${name}->{\$member_name}; ### check if both objects are defined if(\$current_member && \$new_member) { ### if one of them array then just add another one if(blessed \$current_member && blessed \$new_member && \$current_member->can("merge") && ( \$current_member->nsmap->mapname(\$member_name) eq \$new_member->nsmap->mapname(\$member_name) ) ) { \$current_member->merge(\$new_member); \$self->{\$member_name} = \$current_member; \$logger->debug(" Merged \$member_name , got" . \$current_member->asString); ### if its array then just push } elsif(ref(\$current_member) eq 'ARRAY'){ \$self->{\$member_name}=[\$current_member, \$new_member]; \$logger->debug(" Pushed extra to \$member_name "); } ## thats it, dont merge if new member is just a scalar } elsif( \$new_member) { \$self->{\$member_name} = \$new_member; } } else { \$logger->error(" This field \$member_name, found in supplied $name is not supported by $name class"); return; } } return \$self; } =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 = (); my \$logger = get_logger( \$CLASSPATH ); EOHH if( @elementnodes ) { print $fh " foreach my \$field (qw/$elements_names/) {\n"; print $fh " my \@array = ref(\$self->{\$field}) eq 'ARRAY'?\@{\$self->{\$field}}:(\$self->{\$field});\n"; print $fh " my \$i = 0;\n"; print $fh " foreach my \$el ( \@array) {\n"; print $fh " if(\$el && blessed \$el && \$el->can(\"id\") && \$el->id) { \n"; print $fh " \$map->{\$field}{\$el->id} = \$i; \n"; print $fh " }\n"; print $fh " \$i++;\n"; print $fh " }\n"; print $fh " }\n"; print $fh " return \$self->idmap(\$map);\n"; } else { print $fh " return;\n"; } print $fh "}\n"; print $fh <{\$field}) eq 'ARRAY'?\@{\$self->{\$field}}:(\$self->{\$field});\n"; print $fh " my \$i = 0;\n"; print $fh " foreach my \$el ( \@array) {\n"; print $fh " if(\$el && blessed \$el && \$el->can(\"metadataIdRef\") && \$el->metadataIdRef ) { \n"; print $fh " \$map{\$field}{\$el->metadataIdRef} = \$i; \n"; print $fh " }\n"; print $fh " \$i++;\n"; print $fh " }\n"; print $fh " }\n"; print $fh " return \$self->refidmap(\\\%map);\n"; } else { print $fh " return;\n"; } print $fh "}\n"; print $fh <getDOM(); return \$dom->toString('1'); } =head2 registerNamespaces () will parse all subelements and register all namepspaces within the $name namespace =cut sub registerNamespaces { my \$self = shift; my \$logger = get_logger( \$CLASSPATH ); my \$nsids = shift; my \$local_nss = {reverse \%{\$self->nsmap->mapname}}; unless(\$nsids) { \$nsids = \$local_nss; } else { \%{\$nsids} = ( \%{\$local_nss}, \%{\$nsids}); } EOH1 if( @elementnodes ) { print $fh " foreach my \$field (qw/$elements_names/) {\n"; print $fh " my \@array = ref(\$self->{\$field}) eq 'ARRAY'?\@{\$self->{\$field}}:(\$self->{\$field});\n"; print $fh " foreach my \$el ( \@array) {\n"; print $fh " if(blessed \$el && \$el->can(\"registerNamespaces\") ) { \n"; print $fh " my \$fromNSmap = \$el->registerNamespaces(\$nsids); \n"; print $fh " my \%ns_idmap = \%{\$fromNSmap}; \n"; print $fh " foreach my \$ns ( keys \%ns_idmap) {\n"; print $fh " \$nsids->{\$ns}++\n"; print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; } print $fh " return \$nsids;\n"; print $fh "}\n"; print $fh <debug(" fromDOM for: name=$name "); foreach my $attr (@attributes) { print $fh _printConditional($attr, $element->{attrs}->{$attr}, 'from'); print $fh " \$logger->debug(\" Attribute $attr= \". \$self->$attr) if \$self->$attr; \n"; } print $fh _printConditional('text', $element->{text}, 'from') if ($element->{text}) ; if(@elements) { print $fh " foreach my \$childnode (\$dom->childNodes) { \n"; print $fh " my \$getname = \$childnode->getName;\n"; print $fh " my (\$nsid, \$tagname) = split \$COLUMN_SEPARATOR, \$getname; \n"; print $fh " unless(\$nsid && \$tagname) { \n"; ## print $fh " \$logger->warn(\" Undefined tag=\$getname\"); \n"; print $fh " next;\n"; print $fh " }\n"; my $conditon_head = ' if'; foreach my $els (@elementnodes) { $logger->fatal(" What the heck: name=$name els=$els ") unless ref($els) eq 'ARRAY'; my $subname = $els->[0]; my $condition = conditionParser($els->[2]); $condition->{logic} .= " && " if $condition->{logic}; if(ref($els->[1]) eq 'ARRAY') { if(scalar @{$els->[1]} > 1 ) { foreach my $choice (@{$els->[1]}) { if(ref($choice) ne 'ARRAY') { printFromDOM($fh, $subname, $choice, 'CHOICE', $conditon_head, $condition->{logic}); $conditon_head = ' elsif'; } elsif(scalar @{$choice} == 1 ) { printFromDOM($fh, $subname, $choice->[0], 'ARRAY', $conditon_head, $condition->{logic}); $conditon_head = ' elsif'; } else { $logger->logdie(" Malformed element definition: name=$name subelement=$subname "); } } } else { printFromDOM($fh, $subname, $els->[1]->[0] , 'ARRAY',$conditon_head, $condition->{logic}); } } elsif (ref($els->[1]) eq 'HASH') { printFromDOM($fh, $subname,$els->[1], 'HASH',$conditon_head, $condition->{logic}); } $conditon_head = ' elsif'; } if( @textnodes) { print $fh "$conditon_head (\$childnode->textContent && \$self->can(\"\$tagname\")) { \n"; print $fh " \$self->{\$tagname} = \$childnode->textContent; ## text node \n"; print $fh " } "; } if(@elementnodes || @textnodes) { print $fh " ### \$dom->removeChild(\$childnode); ##remove processed element from the current DOM so subclass can deal with remaining elements\n"; } print $fh " }\n"; print $fh " \$self->buildIdMap;\n \$self->buildRefIdMap;\n \$self->registerNamespaces;\n "; } print $fh "\n return \$self;\n}\n"; print $fh <new( "$TEST_DIR$className.t" ,"w+"); $logger->error(" Failed to open test suite file : $TEST_DIR$className.t") unless $fhtest; print $fhtest <[0]}}) { print $fhtest "use " . $known_classes{$el->[0]}{$ns} . ";\n" if $known_classes{$el->[0]}{$ns}; } } print $fhtest <init("$TOP_DIR/logger.conf"); my \$obj1 = undef; #2 eval { \$obj1 = $className->new({ EOTB map { print $fhtest " '$_' => 'value_$_'," } @{$attributes}; print $fhtest "})\n};\n ok( \$obj1 && \!\$EVAL_ERROR , \"Create object $className...\" . \$EVAL_ERROR);\n \$EVAL_ERROR = undef; \n"; print $fhtest "#3\n"; print $fhtest " my \$ns = \$obj1->nsmap->mapname('$name');\n"; print $fhtest " ok(\$ns eq '". $element->{attrs}->{xmlns} . "', \" mapname('$name')... \");\n"; my $testn = '4'; foreach my $att (@{$attributes}) { print $fhtest "#$testn\n"; print $fhtest " my \$$att = \$obj1->$att;\n"; print $fhtest " ok(\$$att eq 'value_$att', \" checking accessor obj1->$att ... \");\n"; $testn++; } 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; print $fhtest "#$testn\n"; my $subel_name = $subel->[0]; print $fhtest " my \$obj_$subel_name = undef;\n"; print $fhtest " eval {\n"; print $fhtest " \$obj_$subel_name = " . $known_classes{$subel_name}{$subel1->{attrs}->{xmlns}} ."->new({"; map { print $fhtest " '$_' => 'value$_'," if $_ ne 'xmlns' && $subel1->{attrs}->{$_}} keys %{$subel1->{attrs}}; print $fhtest "});\n"; (ref($subel->[1]) eq 'ARRAY' && $#{$subel->[1]} == 0)?print $fhtest " \$obj1->add\u$subel_name(\$obj_$subel_name);\n": print $fhtest " \$obj1->$subel_name(\$obj_$subel_name);\n "; print $fhtest " }; \n"; print $fhtest " ok( \$obj_$subel_name && \!\$EVAL_ERROR , \"Create subelement object $subel_name and set it ...\" . \$EVAL_ERROR);\n \$EVAL_ERROR = undef; \n"; $testn++; } print $fhtest "#$testn\n"; print $fhtest " my \$string = undef;\n"; print $fhtest " eval {\n"; print $fhtest " \$string = \$obj1->asString \n"; print $fhtest " };\n"; print $fhtest " ok(\$string && \!\$EVAL_ERROR , \" Converting to string XML: \$string \" . \$EVAL_ERROR);\n"; print $fhtest " \$EVAL_ERROR = undef;\n"; $testn++; print $fhtest "#$testn\n"; print $fhtest " my \$obj22 = undef; \n"; print $fhtest " eval {\n"; print $fhtest " \$obj22 = $className->new({xml => \$string});\n"; print $fhtest " };\n"; print $fhtest " ok( \$obj22 && \!\$EVAL_ERROR , \" re-create object from XML string: \". \$EVAL_ERROR);\n"; print $fhtest " \$EVAL_ERROR = undef;\n"; $testn++; print $fhtest "#$testn\n"; print $fhtest " my \$dom1 = \$obj1->getDOM();\n"; print $fhtest " my \$obj2 = undef; \n"; print $fhtest " eval {\n"; print $fhtest " \$obj2 = $className->new(\$dom1);\n"; print $fhtest " };\n"; print $fhtest " ok( \$obj2 && \!\$EVAL_ERROR , \" re-create object from DOM XML: \". \$EVAL_ERROR);\n"; print $fhtest " \$EVAL_ERROR = undef;\n"; close $fhtest; } # # auxiliary private function # prints part of getSQL which maps available entries on sql request hash # sub getSQLSub { my ($sql_fields, $subname, $if_cond ) = @_; my $head_string = " $if_cond(\$self->$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->$subname;\n"; $head_string .= " \$logger->debug(\" Got value for SQL query \$table.\$entry: \" . \$self->$subname);\n"; $head_string .= " last; \n"; $head_string .= " }\n"; return $head_string; } # # auxiliary private function # printing fromDOM part # # sub printFromDOM { my ($fh, $subname, $el, $type, $conditon_head, $cond_string ) = @_; my $subnameUP = ucfirst($subname); $logger->debug("Building fromDOM: type=$type subname=$subname"); print $fh "$conditon_head ($cond_string\$tagname eq '$subname' && \$nsid eq '". $el->{'attrs'}{'xmlns'} . "' && \$self->can(\$tagname)) { \n"; print $fh " my \$element = undef;\n"; print $fh " eval {\n"; print $fh " \$element = " . $known_classes{$subname}{$el->{'attrs'}{'xmlns'}} . "->new(\$childnode) \n"; print $fh " };\n"; print $fh " if(\$EVAL_ERROR || !(\$element && blessed \$element)) {\n"; print $fh " \$logger->error(\" Failed to load and add $subnameUP : \" . \$dom->toString . \" error: \" . \$EVAL_ERROR);\n"; print $fh " return;\n"; print $fh " }\n"; print $fh (($type eq 'ARRAY')?" (\$self->$subname && ref(\$self->$subname) eq 'ARRAY')?push \@{\$self->$subname}, \$element:\$self->$subname([\$element]);": " \$self->$subname(\$element)") . "; ### add another $subname \n"; print $fh " } "; } # # auxiliary private function # printing getDom part for arrayref members ( when its more then single instance of the sublelement ) # sub printGetArrayDom { my ($fh, $subname, $name, $logic) = @_; print $fh " if($logic\$self->$subname && ref(\$self->$subname) eq 'ARRAY' ) {\n"; print $fh " foreach my \$subel (\@{\$self->$subname}) { \n"; print $fh " if(blessed \$subel && \$subel->can(\"getDOM\")) { \n"; print $fh " my \$subDOM = \$subel->getDOM(\$$name);\n"; print $fh " \$subDOM?\$$name->appendChild(\$subDOM):\$logger->error(\"Failed to append $subname elements with value: \" . \$subDOM->toString ); \n"; print $fh " }\n"; print $fh " }\n"; print $fh " }\n"; } # # auxiliary private function # printing getDom part for singular object members # sub printGetDOM { my ($fh, $subname, $name, $cond_string) = @_; print $fh " if($cond_string\$self->$subname && blessed \$self->$subname && \$self->$subname->can(\"getDOM\")) {\n"; print $fh " my \$${subname}DOM = \$self->$subname->getDOM(\$$name);\n"; print $fh " \$${subname}DOM?\$$name->appendChild(\$${subname}DOM):\$logger->error(\"Failed to append $subname with value: \" . \$${subname}DOM->toString ); \n"; print $fh " }\n"; } # # auxiliary private function # will parse conditional string and return regexp and logical condition # accepted parameter: $value is string to parse # will return hashref to the resulted hash with keys: {condition , logic => , regexp } # 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->" . (join " && \$self->", @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; } # # auxiliary private function # analyze condition and return conditional string to be used in getDOM|fromDOM # accepted parameters: $key - [attribute | 'text'], $value - condition to parse, $what - ['get' | 'from'] # # sub _printConditional { my ($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); $logger->debug("$value Enum List:: " . ( join ":", map { " $_= " . $condition->{$_}} keys %{$condition})) unless $condition->{condition} eq 'scalar'; if($condition->{condition} eq 'scalar') { $string = $what eq 'get'?" $arrayref_signleft'$key' => \$self->$key$arrayref_signright,\n": " \$self->$key($fromDomArg) if($fromDomArg);\n"; } elsif($condition->{condition} =~ /^if|unless$/ && $condition->{logic}) { $string = $what eq 'get'?" $arrayref_signleft '$key' => (".$condition->{logic}."?\$self->$key:undef)$arrayref_signright,\n": " \$self->$key($fromDomArg) if(" . $condition->{logic}. " && $fromDomArg);\n"; }elsif($condition->{condition} =~ /enum|set|exclude/ && $condition->{regexp}) { my $regexp = $what eq 'get'?"(\$self->$key " . $condition->{regexp} . ")":"($fromDomArg " . $condition->{regexp} .")"; $string = $what eq 'get'?" $arrayref_signleft'$key' => ($regexp?\$self->$key:undef)$arrayref_signright,\n": " \$self->$key($fromDomArg) if($fromDomArg && $regexp);\n"; } else { $logger->fatal("Malfromed , uknown condition=" . $condition->{condition} ); } return $string; } 1;