File Coverage

blib/lib/Tridion/BusinessConnector.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# Tridion::BusinessConnector
# written by Toby Corkindale (perl (at) corkindale.net)
# Copyright (c) 2004 Toby Corkindale, All rights reserved.
#
# $Id: BusinessConnector.pm 18 2005-12-21 16:38:11Z tjc $
#
# This Perl module is distributed under the terms of the LGPL:
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This license can be found at http://www.gnu.org/licenses/lgpl.html
#

# This module will help you interface Perl programs to Tridion(tm)'s
# content management system.

package Tridion::BusinessConnector;
use strict;
use warnings;

use XML::LibXML;

our $VERSION = '0.04';

# Tridion namespaces: (Current as of 2004 - may need to be updated one day?)
our $TCM_NS = 'http://www.tridion.com/ContentManager/5.0';
our $TCMAPI_NS = 'http://www.tridion.com/ContentManager/5.0/TCMAPI';


# Initialise the SOAP subsystem:
use SOAP::Lite
    on_fault => sub {
        my $soap = shift;
        my $res = shift;
        ref $res ? die(join "\n", "--- SOAP FAULT ---", $res->faultcode,
                       $res->faultstring, '')
                 : die(join "\n", "--- TRANSPORT ERROR ---",
                       $soap->transport->status, '');
    }
;


sub new {
    my $proto = shift;
    my %args = @_;
    my $class = ref($proto) || $proto;
    my $self = {};

    $self->{hostname} = $args{hostname};
    $self->{username} = $args{username};
    $self->{password} = $args{password};

    $self->{_parser} = new XML::LibXML;

    $self->{_soaplite} = new SOAP::Lite
        uri => 'http://schemas.xmlsoap.org/soap/encoding/',
        proxy => 'http://' . $self->{hostname} . '/BCListener/services/urn:bc'
        ;

    $self->{_soaplite}->transport->credentials(
                                               $self->{hostname} . ':80',
                                               $self->{hostname},
                                               $self->{username},
                                               $self->{password}
                                              );

    bless($self, $class);
    return $self;
}


sub execute
{
    my $self = shift;
    my $requestXML = shift;
    my $method = SOAP::Data->name('execute')
                           ->attr({xmlns => 'urn:bc'});

    my $obj = $self->{_soaplite}->call($method => ('default', $requestXML));
    return $obj->result;
}


sub GetItem
{
    my $self = shift;
    my $uri = shift;

    die("Invalid TCM URI: $uri\n") unless ($uri =~ /^tcm:\d+(\-\d+)*$/);

    my $requestXML =<

 version="5.0" from="SOAPMod" failOnError="true">




EOM

    my $result = $self->execute($requestXML);
    my $xml = $self->{_parser}->parse_string($result);
    if ($xml->findvalue('/tcmapi:Message/tcmapi:Response/@success') ne 'true') {
        die("---- Request Failed, Dumping output ----\n$result\n");
    }

    # get the first, and only, child of , and make that the new
    # document root
    my ($data) = $xml->documentElement()->findnodes('/tcmapi:Message/tcmapi:Response/tcmapi:Result/*');

    my $newdoc = new XML::LibXML::Document;
    $newdoc->setDocumentElement($data);

    return $newdoc;
}


sub SaveItem
{
    my $self = shift;
    my $xml = shift;
    my $uri = shift;
    my $context_uri = shift;

    die("Invalid TCM URI: $uri\n") unless ($uri =~ /^tcm:\d+(\-\d+)*$/);
    die("Invalid TCM URI: $context_uri\n") unless ($context_uri =~ /^tcm:\d+(\-\d+)*$/);

    my $requestDoc = new XML::LibXML::Document;
    my $root = $requestDoc->createElement('Message');
    $root->setNamespace($TCMAPI_NS, 'tcmapi', 1);
    $root->setAttribute('version', '5.0');
    $root->setAttribute('from', 'SOAPMod');
    $root->setAttribute('failOnError', 'true');
    $requestDoc->setDocumentElement($root);

    my $node = $requestDoc->createElement('tcmapi:Request');
    $node->setAttribute('ID', 'Request1');
    $node->setAttribute('preserve', 'false');
    $root->addChild($node);

    my $savenode = $requestDoc->createElement('tcmapi:SaveItem');
    $savenode->setAttribute('itemURI', $uri);
    $savenode->setAttribute('contextURI', $context_uri);
    $savenode->setAttribute('doneEditing', 'true');
    $node->addChild($savenode);

    # set 'itemType' attr to correct type
    my $type = $xml->documentElement->nodeName;
    $type =~ s/^\w+://;
    $savenode->setAttribute('itemType', $type);

    # And add the provided component or whatever.
    $savenode->addChild($xml->documentElement);

    my $result = $self->execute($requestDoc->toString);
    $xml = $self->{_parser}->parse_string($result);
    if ($xml->findvalue('/tcmapi:Message/tcmapi:Response/@success') ne 'true') {
        die("---- Request Failed, Dumping output ----\n$result\n");
    }

    # get the first, and only, child of , and make that the new
    # document root
    my ($data) = $xml->documentElement()->findnodes('/tcmapi:Message/tcmapi:Response/tcmapi:Result/*');

    my $newdoc = new XML::LibXML::Document;
    $newdoc->setDocumentElement($data);

    return $newdoc;
}


# In case you need to discover the proper values for realm or netloc for
# your own server, uncomment these:
#sub SOAP::Transport::HTTP::Client::get_basic_credentials
#{
#    my($self, $realm, $uri, $proxy) = @_;
#    warn "Realm[$realm]\nURI[$uri]\nproxy[$proxy]\n";
#    warn "host_port[" . $uri->host_port . "]\n";
#}

1;

__END__