File Coverage

lib/BPM/XPDL.pm

Criterion	Covered	Total	%
statement	12	12	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	16	16	100.0

# Copyrights 2009-2014 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.01.
use warnings;
use strict;

package BPM::XPDL;
use vars '$VERSION';
$VERSION = '0.92';

use base 'XML::Compile::Cache';

use XML::Compile::Util qw/type_of_node unpack_type pack_type/;
use Log::Report 'business-xpdl', syntax => 'SHORT';
use BPM::XPDL::Util;


# map namespace always to the newest implementation of the protocol
my %ns2version =
 ( &NS_XPDL_009 => '0.09'
 , &NS_XPDL_10  => '1.0'
 , &NS_XPDL_20  => '2.0'
 , &NS_XPDL_21  => '2.1'
 );

my %info =
 ( '0.01' => { }  # not usable
 , '0.09' =>
     { prefixes => { '' => NS_XPDL_009 }
     }
 , '1.0' =>
     { prefixes => { '' => NS_XPDL_10 }
     }
 , '2.0alpha-21' =>
     { prefixes => { '' => NS_XPDL_20 }
     }
 , '2.0alpha-24' =>
     { prefixes => { '' => NS_XPDL_20 }
     }
 , '2.0'         =>   # alpha namespace used for final product
     { prefixes => { '' => NS_XPDL_20 }
     }
 , '2.1' =>
     { prefixes => { '' => NS_XPDL_21 }
     }
 );

#--------


sub new($)
{   my $class = shift;
    $class->SUPER::new(direction => 'RW', @_);
}

sub init($)
{   my ($self, $args) = @_;
    $args->{allow_undeclared} = 1
        unless exists $args->{allow_undeclared};

    $self->SUPER::init($args);

    $self->anyElement('ATTEMPT');
    $self->addCompileOptions(RW => sloppy_floats => 1, sloppy_integers => 1);
    $self->addCompileOptions(READERS => mixed_elements => 'XML_NODE');

    my $version = $args->{version}
        or error __x"XPDL object requires an explicit version";

    unless(exists $info{$version})
    {   exists $ns2version{$version}
            or error __x"XPDL version {v} not recognized", v => $version;
        $version = $ns2version{$version};
    }
    $self->{version} = $version;
    my $info = $info{$version};
    $self->{namespace} = $info->{prefixes}{''};

    my $prefix_keys = $self->{prefixed} = delete $args->{prefix_keys};

    $self->addPrefixes($info->{prefixes});
    $self->addKeyRewrite('PREFIXES(xpdl)') if $prefix_keys;

    (my $xsd = __FILE__) =~ s!\.pm!/xsd!;
    my @xsds = glob "$xsd/xpdl-$version/*";

    # support deprecated versions
    if($version gt '1.0')   # $version is a version label, not number
    {   trace "loading deprecated xpdl 1.0";
        $self->addPrefixes(xpdl10 => NS_XPDL_10);
        push @xsds, glob "$xsd/xpdl-1.0/*";
        $self->addKeyRewrite('PREFIXES(xpdl10)') if $prefix_keys;

        # this trick is needed because the StartMode element became an
        # attribute in the same structure
        $self->addKeyRewrite(
          { pack_type(NS_XPDL_10, 'StartMode' ) => 'dep_StartMode'
          , pack_type(NS_XPDL_10, 'FinishMode') => 'dep_FinishMode'} );
    }

    if($version ge '2.1')
    {   trace "loading deprecated xpdl 2.0";
        $self->addPrefixes(xpdl20 => NS_XPDL_20);
        push @xsds, glob "$xsd/xpdl-2.0/*";
        $self->addKeyRewrite('PREFIXES(xpdl20)') if $prefix_keys;
    }

    $self->importDefinitions(\@xsds);
    $self;
}


sub from($@)
{   my ($thing, $source, %args) = @_;

    my $xml  = XML::Compile->dataToXML($source);
    my $top  = type_of_node $xml;
    my ($ns, $topname) = unpack_type $top;
    my $version = $ns2version{$ns}
       or error __x"unknown XPDL version with namespace {ns}", ns => $ns;

    $topname eq 'Package'
       or error __x"file does not contain a Package but {local}"
             , local => $topname;

    my ($self, $convert);
    if(ref $thing)
    {   # instance method
        $self    = $thing;

        ! $self->{prefixed}
           or error __x"cannot use prefixed_keys with version conversion";

        $convert = 1;
    }
    else
    {   # class method: can determine version myself
        $self    = $thing->new(version => $version, %args);
        $convert = 0;
    }

    my $r    = $self->reader($top, %args)
        or error __x"root node `{top}' not recognized", top => $top;

    my $data =  $r->($xml);

    if($convert)
    {   # upgrade structures.  Even when the versions match, they may
        # contain deprecated structures which can be removed.
        $self->convert10to20($data)
            if $self->version gt '1.0';

        $self->convert20to21($data)
            if $self->version gt '2.0';
    }

    (pack_type($self->namespace, 'Package'), , $data);
}

sub convert10to20($)
{   my ($self, $data) = @_;

    trace "Convert xpdl version from 1.0 to 2.0";

    # The conversions to be made are described in the XPDL specification
    # documents.  However, be aware that there are considerable additions.

    my $ns = $self->namespace;
    my $prefix
      = $ns eq NS_XPDL_20 ? 'xpdl20'
      : $ns eq NS_XPDL_21 ? 'xpdl21'
      : panic;

    # do not walk more than one HASH level at a time, to avoid creation
    # of unused HASHes.
    my $wfps = $data->{WorkflowProcesses} || {};
    foreach my $wfp (@{$wfps->{WorkflowProcess} || []})
    {
        my $acts = $wfp->{Activities} || {};
        foreach my $act (@{$acts->{Activity} || []})
        {   # Start/Finish mode from element -> attribute
            if(my $sm = delete $act->{dep_StartMode})
            {   (my $mode, undef) = %$sm; # only 1 key-value pair!
                $act->{StartMode} = $mode;
            }
            if(my $fm = delete $act->{dep_FinishMode})
            {   (my $mode, undef) = %$fm;
                $act->{dep_FinishMode} = $mode;
            }

            # BlockId -> ActivitySetId
            if(my $ba = $act->{BlockActivity})
            {   # rename option BlockId into ActivitySetId
                $ba->{ActivitySetId} = delete $ba->{BlockId}
                    if $ba->{BlockId};
            }

            # DeadlineCondition -> DeadlineDuration
            foreach my $dead (@{$act->{Deadline} || []})
            {  $dead->{DeadlineDuration} = delete $dead->{DeadlineCondition}
                   if $dead->{DeadlineCondition};
            }

            # Remove Tool attribute "Type"
            if(my $impl =  $act->{Implementation})
            {   if(my $tools = $impl->{Tool})
                {   delete $_->{Type} for @$tools;
                }
            }
        }

        # remove Index attribute to FormalParameter
        my $fps = $wfp->{FormalParameters} || {};
        foreach my $param (@{$fps->{FormalParameter} || []})
        {   delete $param->{Index};
        }

        my $appls = $wfp->{Applications} || {};
        foreach my $appl (@{$appls->{Application} || []})
        {   my $afps = $appl->{FormalParameters} || {};
            for my $param (@{$afps->{FormalParameter}||[]})
            {   delete $param->{Index};
            }
        }

        # Condition/Xpression to Condition/Expression
        my $trs = $wfp->{Transitions} || {};
        for my $trans (@{$trs->{Transition} || []})
        {   my $cond = $trans->{Condition} or next;
            foreach ($cond->getChildrenByLocalName('Xpression'))
            {   $_->setNodeName('Expression');
                $_->setNamespace($ns, $prefix, 1);
            }
        }

        my $sets = $wfp->{ActivitySets} || {};
        foreach my $set (@{$sets->{ActivitySet} || []})
        {   my $strans = $set->{Transitions} || {};
            foreach my $trans (@{$strans->{Transition} || []})
            {   my $cond = $trans->{Condition} or next;
                foreach ($cond->getChildrenByLocalName('Xpression'))
                {   $_->setNodeName('Expression');
                    $_->setNamespace($ns, $prefix, 1);
                }
            }
        }

        # Order in WorkflowProcess changed.  This is a no-op for X::C
    }

    $data->{PackageHeader}{XPDLVersion} = '2.0';
    $data;
}

sub convert20to21($)
{   my ($self, $data) = @_;

    trace "Convert xpdl version from 2.0 to 2.1";

    # Tool has been removed from the spec.  However, it can still be
    # used in the old namespace, and I do not know how to convert it
    # to 2.1 structures (yet)

    my $ns = $self->namespace;
    my $prefix
      = $ns eq NS_XPDL_21 ? 'xpdl21'
      : panic;


    # do not walk more than one HASH level at a time, to avoid creation
    # of unused HASHes.
    my $wfps = $data->{WorkflowProcesses} || {};
    foreach my $wfp (@{$wfps->{WorkflowProcess} || []})
    {
        my $acts = $wfp->{Activities} || {};
        foreach my $act (@{$acts->{Activity} || []})
        {   # Rewrite Tool to Task/TaskApplication
            if(my $impl = $act->{Implementation})
            {   foreach my $tool (@{delete $impl->{Tool} || []})
                {  my %task = %$tool;
                   delete $task{PackageRef};         # ?relocate info?
                   delete $task{ExtendedAttributes}; # ?into DataMapping?
                   delete $task{Type};   # shouldn't be there, rem in 2.0
                   $impl->{Task}{TaskApplication} = \%task;
                }
            }
        }

        # Condition/Xpression to Condition/Expression
        my $trs = $wfp->{Transitions} || {};
        for my $trans (@{$trs->{Transition} || []})
        {   my $cond = $trans->{Condition} or next;
            foreach ($cond->getChildrenByLocalName('Expression'))
            {   $_->setNamespace($ns, $prefix, 1);
            }
        }

        my $sets = $wfp->{ActivitySets} || {};
        foreach my $set (@{$sets->{ActivitySet} || []})
        {   my $strans = $set->{Transitions} || {};
            foreach my $trans (@{$strans->{Transition} || []})
            {   my $cond = $trans->{Condition} or next;
                foreach ($cond->getChildrenByLocalName('Expression'))
                {   $_->setNamespace($ns, $prefix, 1);
                }
            }
        }
    }

    $data->{PackageHeader}{XPDLVersion} = '2.1';
    $data;
}

#----------


sub version()   {shift->{version}}
sub namespace() {shift->{namespace}}

#--------


sub create($)
{   my ($self, $data) = @_;
    my $doc  = XML::LibXML::Document->new('1.0', 'UTF-8');
    my $wr   = $self->writer('Package')
        or panic "cannot find Package type";

    my $root = $wr->($doc, $data);
    $doc->setDocumentElement($root);
    $doc;
}

1;