view release on metacpan or  search on metacpan

lib/XML/Compile/Schema.pm  view on Meta::CPAN

    {   $_->{used} = 0 for values %$table;
    }

    $table->{''}   = +{ uri => '', prefix => '', used => 0 }
        if $block_default && !grep $_->{prefix} eq '', values %$table;

    # very strong preference for 'xsi'
    $table->{&SCHEMA2001i} = +{ uri => SCHEMA2001i, prefix => 'xsi', used => 0 };

    $table;
}


sub compileType($$@)
{   my ($self, $action, $type, %args) = @_;

    # translator can only create elements, not types.
    my $elem           = delete $args{element} || $type;
    my ($ens, $elocal) = unpack_type $elem;
    my ($ns, $local)   = unpack_type $type;

    my $SchemaNS = SCHEMA2001;

    my $defs     = $ns ? <<_DIRTY_TRICK1 : <<_DIRTY_TRICK2;
<schema xmlns="$SchemaNS"
   targetNamespace="$ens"
   xmlns:tns="$ns">
  <element name="$elocal" type="tns:$local" />
</schema>
_DIRTY_TRICK1
<schema xmlns="$SchemaNS"
   targetNamespace="$ens"
   elementFormDefault="unqualified"
   >
  <element name="$elocal" type="$local" />
</schema>
_DIRTY_TRICK2

    $self->importDefinitions($defs);
    $self->compile($action, $elem, %args);
}


sub template($@)
{   my ($self, $action, $type, %args) = @_;

    my ($to_perl, $to_xml)
      = $action eq 'PERL' ? (1, 0)
      : $action eq 'XML'  ? (0, 1)
      : $action eq 'TREE' ? (0, 0)
      : error __x"template output is either in XML or PERL layout, not '{action}'"
        , action => $action;

    my $show
      = exists $args{show_comments} ? $args{show_comments}
      : exists $args{show} ? $args{show} # pre-0.79 option name 
      : 'ALL';

    $show    = 'struct,type,occur,facets' if $show eq 'ALL';
    $show    = '' if $show eq 'NONE';
    my %show = map {("show_$_" => 1)} split m/\,/, $show;
    my $nss  = $self->namespaces;

    my $indent                  = $args{indent} || "  ";
    $args{check_occurs}         = 1;
    $args{mixed_elements}     ||= 'ATTRIBUTES';
    $args{default_values}     ||= 'EXTEND';
    $args{abstract_types}     ||= 'ERROR';

    exists $args{include_namespaces}
        or $args{include_namespaces} = 1;

    # it could be used to add extra comment lines
    error __x"typemaps not implemented for XML template examples"
        if $to_xml && defined $args{typemap} && keys %{$args{typemap}};

    my @rewrite = $self->_key_rewrite(delete $args{key_rewrite});
    my @blocked = $self->_block_nss(delete $args{block_namespace});

    my $table   = $args{prefixes} = $self->_namespaceTable
      (($args{prefixes} || $args{output_namespaces})
      , $args{namespace_reset}
      , !$args{use_default_namespace}
      );

    my $used = $to_xml && $show{show_type};
    $table->{&SCHEMA2001}
       ||= +{prefix => 'xs',  uri => SCHEMA2001,  used => $used};
    $table->{&SCHEMA2001i}
       ||= +{prefix => 'xsi', uri => SCHEMA2001i, used => $used};

    my $transl  = XML::Compile::Translate->new
     ( 'TEMPLATE'
     , nss         => $self->namespaces
     );

    my $compiled = $transl->compile
     ( $type
     , %args
     , rewrite         => \@rewrite
     , block_namespace => \@blocked   # not yet supported
     , output          => $action
     );
    $compiled or return;

    my $ast = $compiled->();
#use Data::Dumper; $Data::Dumper::Indent = 1; warn Dumper $ast;

    if($to_perl)
    {   return $transl->toPerl($ast, %show, indent => $indent
          , skip_header => $args{skip_header})
    }

    if($to_xml)
    {   my $doc  = XML::LibXML::Document->new('1.1', 'UTF-8');
        my $node = $transl->toXML($doc, $ast, %show
          , indent => $indent, skip_header => $args{skip_header});
        return $node->toString(1);
    }

    # return tree