Business-CAMT

 view release on metacpan or  search on metacpan

lib/Business/CAMT.pm  view on Meta::CPAN

use Scalar::Util        qw(blessed);
use List::Util          qw(first);
use XML::Compile::Util  qw(pack_type);

use Business::CAMT::Message ();

my $urnbase = 'urn:iso:std:iso:20022:tech:xsd';
my $moddir  = Path::Class::File->new(__FILE__)->dir;
my $xsddir  = $moddir->subdir('CAMT', 'xsd');
my $tagdir  = $moddir->subdir('CAMT', 'tags');
sub _rootElement($) { pack_type $_[1], 'Document' }  # $ns parameter

# The XSD filename is like camt.052.001.12.xsd.  camt.052.001.* is
# expected to be incompatible with camt.052.002.*, but *.12.xsd can
# usually parse *.11.xsd
my %xsd_files;

# Translations from abbreviated XML tags to longer names, loaded on
# demand.
my $tagtable;


sub new(%)
{	my ($class, %args) = @_;
    (bless {}, $class)->init(\%args);
}

sub init($)
{	my ($self, $args) = @_;

	# Collect the names of all CAMT schemes in this distribution
	foreach my $f (grep !$_->is_dir && $_->basename =~ /\.xsd$/, $xsddir->children)
	{	$f->basename =~ /^camt\.([0-9]{3}\.[0-9]{3})\.([0-9]+)\.xsd$/ or panic $f;
		$xsd_files{$1}{$2} = $f->stringify;
	}

	$self->{BC_rule} = delete $args->{match_schema}  || 'NEWER';
	$self->{BC_big}  = delete $args->{big_numbers}   || 0;
	$self->{BC_long} = delete $args->{long_tagnames} || 0;
	$self->{RC_schemas} = XML::Compile::Cache->new;

    $self;
}

#-------------------------

sub schemas() { $_[0]->{RC_schemas} }

#-------------------------

sub read($%)
{	my ($self, $src, %args) = @_;

	my $dom
	  = ! ref $src ? XML::LibXML->load_xml($src =~ /\<.*\>/ ? (string => $src) : (location => $src))
	  : $src->isa('IO::Handle') || $src->isa('GLOB') ? XML::LibXML->load_xml(IO => $src)
	  : $src->isa('XML::LibXML::Node') ? $src
	  : error "Unrecognized input";

	my $xml = $dom->isa('XML::LibXML::Document') ? $dom->documentElement : $dom;

lib/Business/CAMT.pm  view on Meta::CPAN

	Business::CAMT::Message->fromData(
		set     => $set,
		version => $xsd_version,
		data    => $reader->($xml),
		camt    => $self,
	);
}


sub fromHASH($%)
{	my ($self, $data, %args) = @_;
	my $type = $args{type} or panic;
	my ($set, $version) = $type =~ /^(?:camt\.)?([0-9]+\.[0-9]+)\.([0-9]+)$/
		or error __x"Unknown message type '{type}'", type => $type;

	Business::CAMT::Message->fromData(
		set     => $set,
		version => $version,
		data    => $data,
		camt    => $self,
	);
}


sub create($$%)
{	my ($self, $type, $data) = @_;
	my ($set, $version) = $type =~ /^(?:camt\.)?([0-9]+\.[0-9]+)\.([0-9]+)$/
		or error __x"Unknown message type '{type}'", type => $type;

	Business::CAMT::Message->create(
		set     => $set,
		version => $version,
		data    => $data,
		camt    => $self,
	);
}


sub write($$%)
{	my ($self, $fn, $msg, %args) = @_;

	my $set      = $msg->set;
	my $versions = $xsd_files{$set}
		or error __x"Message set '{set}' is unsupported.", set => $set;

	my @versions = sort { $a <=> $b } keys %$versions;
	my $version  = $msg->version;
	grep $version eq $_, @versions
		or error __x"Schema version {version} is not available, pick from {versions}.",

lib/Business/CAMT.pm  view on Meta::CPAN

	if(ref $fn eq 'GLOB')
         { $doc->toFH($fn, 1) }
	else { $doc->toFile($fn, 1) }

	$xml;
}

#-------------------------

sub _loadXsd($$)
{	my ($self, $set, $version) = @_;
	my $file = $xsd_files{$set}{$version};
	$self->{BC_loaded}{$file}++ or $self->schemas->importDefinitions($file);
}

my %msg_readers;
sub schemaReader($$$)
{	my ($self, $set, $version, $ns) = @_;
	my $r = $self->{BC_r} ||= {};
	return $r->{$ns} if $r->{$ns};

	$self->_loadXsd($set, $version);

	$r->{$ns} = $self->schemas->compile(
		READER        => $self->_rootElement($ns),
		sloppy_floats => !$self->{BC_big},
		key_rewrite   => $self->{BC_long} ? $self->tag2fullnameTable : undef,
	);
}


sub schemaWriter($$$)
{	my ($self, $set, $version, $ns) = @_;
	my $w = $self->{BC_w} ||= {};
	return $w->{$ns} if $w->{$ns};

	$self->_loadXsd($set, $version);
	$w->{$ns} = $self->schemas->compile(
		WRITER        => $self->_rootElement($ns),
		sloppy_floats => !$self->{BC_big},
		key_rewrite   => $self->{BC_long} ? $self->tag2fullnameTable : undef,
		ignore_unused_tags => qr/^_attrs$/,

lib/Business/CAMT.pm  view on Meta::CPAN

# called with ($set, $version, \@available_versions)
sub _exact { first { $_[1] eq $_ } @{$_[2]} }
my %rules = (
	EXACT  => \&_exact,
	NEWER  => sub { (grep $_ >= $_[1], @{$_[2]})[0] },
	NEWEST => sub { _exact(@_) || ($_[1] <= $_[2][-1] ? $_[2][-1] : undef) },
	ANY    => sub { _exact(@_) || $_[2][-1] },
);

sub matchSchema($$%)
{	my ($self, $set, $version, %args) = @_;
	my $versions = $xsd_files{$set} or panic "Unknown set $set";

	my $ruler = $args{rule} ||= $self->{BC_rule};
	my $rule  = ref $ruler eq 'CODE' ? $ruler : $rules{$ruler}
		or error __x"Unknown schema match rule '{rule}'.", rule => $ruler;
	
	$rule->($set, $version, [ sort { $a <=> $b } keys %$versions ]);
}


sub knownVersions(;$)
{	my ($self, $set) = @_;
	my @s;
	foreach my $s ($set ? $set : sort keys %xsd_files)
	{	push @s, map "camt.$s.$_", sort {$a <=> $b} keys %{$xsd_files{$s}};
	}
	@s;
}


sub fullname2tagTable()
{	my $self = shift;
	$self->{BC_toAbbr} ||= +{ reverse %{$self->tag2fullnameTable} };
}


sub tag2fullnameTable()
{	my $self = shift;
	$self->{BC_toLong} ||= +{
		map split(/,/, $_, 2), grep !/,$/, $tagdir->file('index.csv')->slurp(chomp => 1)
	};
}

#---------------

1;

lib/Business/CAMT/Message.pm  view on Meta::CPAN

use Scalar::Util  qw/weaken/;
use JSON          ();


sub new
{	my ($class, %args) = @_;
	my $data = delete $args{data} or return undef;
    (bless $data, $class)->init(\%args);
}

sub init($) {
	my ($self, $args) = @_;

	my %attrs;
	$attrs{set}     = $args->{set}     or panic;
	$attrs{version} = $args->{version} or panic;
	$attrs{camt}    = $args->{camt}    or panic;
	weaken $attrs{camt};
	$self->{_attrs} = \%attrs;

	$self;
}


sub _loadSubclass($)
{	my ($class, $set) = @_;
	$class eq __PACKAGE__ or return $class;
	my $super = 'Business::CAMT::CAMT'.($set =~ s/\..*//r);

	# Is there a special implementation for this type?  Otherwise create
	# an empty placeholder.
	no strict 'refs';
	eval "require $super" or @{"$super\::ISA"} = __PACKAGE__;
	$super;
}

sub fromData(%)
{	my ($class, %args) = @_;
	my $set = $args{set} or panic;
	$class->_loadSubclass($set)->new(%args);
}

#-------------------------

sub set     { $_[0]->{_attrs}{set} }
sub version { $_[0]->{_attrs}{version} }
sub camt    { $_[0]->{_attrs}{camt} }

#-------------------------

sub write(%)
{	my ($self, $file) = (shift, shift);
	$self->camt->write($file, $self, @_);
}


sub toPerl()
{	my $self = shift;
	my $attrs = delete $self->{_attrs};

	my $d = Data::Dumper->new([$self], 'MESSAGE');
	$d->Sortkeys(1)->Quotekeys(0)->Indent(1);
	my $text = $d->Dump;

	$self->{_attrs} = $attrs;
	$text;
}


sub toJSON(%)
{	my ($self, %args) = @_;
	my %data  = %$self;        # Shallow copy to remove blessing
	delete $data{_attrs};      # remove object attributes

	my $settings = $args{settings} || {};
	my %settings = (pretty => 1, canonical => 1, %$settings);

	# JSON parameters call methods, copied from to_json behavior
	my $json     = JSON->new;
	while(my ($method, $value) = each %settings)