package STAR::API2::STARXMLUTF;
# CVS version : $Id: STARXMLUTF.pm 7348 2018-04-15 16:52:58Z aw $
#
# Copyright 2004-2099 A. Warnier - Informatica Consulting Europe S.A.
#
use strict;
use warnings;
our ($VERSION);
$VERSION = substr q$Revision: 7348 $, 10;
# Note :
# A STAR::API2::STARXMLUTF object represents one active connection with one single Star server through one
# single Star XML server. Despite the capability as of Star XML 1.4.6 to handle simultaneous connections
# with multiple Star servers, this is deliberate and is explained in the pod documentation.
# Standard modules and pragmas (as of 5.8.3)
require v5.8.1;
require Exporter;
use Carp qw(cluck confess);
# use Cwd;
# use File::Spec;
use IO::Socket::INET;
# use File::Basename;
# use FileHandle; # only necessary if you explicitly set a HANDLE->autoflush(1); (sockets are, by default)
use Time::Local;
# additional CPAN modules
use XML::Simple;
use Encode qw/encode decode/;
# only for debug :
use Data::Dumper;
our @ISA = ("Exporter");
#------------------------------
#
# Globals ('class' variables)
#
#------------------------------
#$STAR::API2::STARXMLUTF::connect_via = "connect";
our $connect_via = "connect";
# check if user wants a persistent database connection ( Apache + mod_perl )
# *** Not yet implemented ***
if ($ENV{MOD_PERL} && $ENV{STARXML_PERSIST}) {
# $STAR::API2::STARXMLUTF::connect_via = "Apache::STARXMLUTF::connect";
$connect_via = "Apache::STARXMLUTF::connect";
}
our $Debug;
our $OK;
#our $ERR;
# Error messages
our $EMSGS = {
ARG_MISS_en => "argument %s missing or invalid",
ARG_MISS_fr => "argument %s manquant ou incorrect",
PAR_MISS_en => "invalid %s : %s",
PAR_MISS_fr => "%s incorrect : %s",
PAR_MISI_en => "missing or invalid %s in %s",
PAR_DUP_en => "duplicate %s : %s",
XREQ_FAIL_en => "Server XML request failed",
ERRSYS_01_en => "Could not connect to XML Server at \"%s:%s\" (%s)",
ERRSYS_02_en => "Could not create XML::Simple object",
ERRSYS_98_en => "Not implemented : %s",
ERRSYS_99_en => "System error : %s",
ERRCOM_01_en => "No connection to StarXML host : %s",
ERRCOM_02_en => "XML request failure : %s",
ERRCOM_03_en => "socket write error : %s",
ERRCOM_04_en => "socket read error : %s",
ERRCOM_05_en => "XML response : %s",
ERRCOM_06_en => "Star connection lost : %s",
ERRCOM_99_en => "Comm error : %s",
ERRXML_01_en => "XML parsing error : %s",
ERRXML_99_en => "XML error : %s",
ERRSTA_01_en => "Star connection error : %s",
ERRSTA_02_en => "Star login error (temporary) : %s", # [SSesFailLicense]
ERRSTA_11_en => "Record in use : %s",
ERRSTA_12_en => "Duplicate lock-id : %s", # e.g. 899; Star error : starapi.SSException; [AduplicateLockName] LKC201104040531257983;
ERRSTA_13_en => "Update failed, value not unique : %s",# 899; Star error : ** UpdateRecord request failed : starapi.SSException; [SUniqueFailed] UniqueFailed: <UNIQ: 1 Cannot update; value not unique.^G>;
ERRSTA_21_en => "DB temporarily unavailable %s",
ERRSTA_22_en => "Space temporarily unavailable %s",
ERRSTA_51_en => "Insufficient permissions : %s",
ERRSTA_52_en => "DB permanently unavailable %s",
ERRSTA_53_en => "Star login error (permanent) : %s",
ERRSTA_54_en => "Space permanently unavailable %s",
ERRSTA_99_en => "Star error : %s",
};
#--------------------------------------
# Constants (and other exported stuff)
#--------------------------------------
use constant CRLF => "\015\012"; # CR/LF line terminator (RFC-like)
use constant LF => "\012"; # LF line terminator (Unix-like)
use constant EOX => "\x1A"; # CHR(26) seems to be the thing
use constant EOL => "\x1F"; # Star's unfiltered end-of-line
use constant OCCLEN => 1000; # maximum length of Star occurrence
use constant SHDR => qr/^(\x13|\x0B)\x14\x01\x12/;# Star's report header (^S|^K)^T^A^R
use constant XMLHDR => "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>"; # to be compatible with old versions
use constant XMLHDRUTF => "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"; # for Star 5.0+
use constant SRV_READSIZE => 256 * 1024; # size of read from server (bumped from 64K to 256K - AW 2013/10/14)
#use constant MAXXML => 1024 * 1024 * 10; # maximum XML response we expect (10MB)
use constant MAXXML => 1024 * 1024 * 32; # changed to 32 MB (AW - 2011/12/05)
use constant ELANG_DEFAULT => "en"; # language for error messages
use constant XMLHOST_DEFAULT => "localhost"; # default XML server host
use constant XMLPORT_DEFAULT => 11100; # default port for XML server
use constant STARHOST_DEFAULT => "localhost"; # default Star server host
use constant STARPORT_DEFAULT => 11002; # default port for Star server
use constant STARUSER_DEFAULT => "starxml"; # default 'anonymous' user-id for Star server
use constant STARPW_DEFAULT => ''; # default 'anonymous' pw for Star server
# 'perms' constants
use constant PERM_NONE => 0; # no access
use constant PERM_READ => 1; # read access
use constant PERM_CREATE => 2; # create record access
use constant PERM_EDIT => 4; # edit record access
use constant PERM_DELETE => 8; # delete record access
use constant PERM_GLOBAL => 16; # Global op. access
use constant PERM_MANAGE => 32; # read access
use constant PERM_ALL => PERM_READ | PERM_CREATE | PERM_EDIT | PERM_DELETE | PERM_GLOBAL | PERM_MANAGE;
# 'wflags' constants
use constant WF_NONE => 0; # no flags
use constant WF_MO => 1; # multiple-occurrence
use constant WF_LO => 2; # long text
use constant WF_HI => 4; # hidden
use constant WF_RO => 8; # read-only (protected)
use constant WF_DT => 16; # date field
use constant WF_SF => 32; # has subfields
# 'ecats' constants : error category
use constant ECAT_SYS => 1;
use constant ECAT_COM => 2;
use constant ECAT_XML => 4;
use constant ECAT_STAR => 8;
# 'dbdefs' constants : which definitions we want
use constant DBDEFS_NONE => 0;
use constant DBDEFS_IN => 1;
use constant DBDEFS_OUT => 2;
use constant DBDEFS_SEARCH => 4;
our @EXPORT_OK = qw(
PERM_NONE PERM_READ PERM_CREATE PERM_EDIT PERM_DELETE PERM_GLOBAL PERM_MANAGE PERM_ALL
WF_NONE WF_MO WF_LO WF_HI WF_RO WF_DT WF_SF
ECAT_SYS ECAT_COM ECAT_XML ECAT_STAR
XMLHOST_DEFAULT XMLPORT_DEFAULT STARHOST_DEFAULT STARPORT_DEFAULT
);
our %EXPORT_TAGS = (
perms => [qw(PERM_NONE PERM_READ PERM_CREATE PERM_EDIT PERM_DELETE PERM_GLOBAL PERM_MANAGE PERM_ALL)],
wflags => [qw(WF_NONE WF_MO WF_LO WF_HI WF_RO WF_DT WF_SF)],
ecats => [qw(ECAT_SYS ECAT_COM ECAT_XML ECAT_STAR)],
hostports => [qw(XMLHOST_DEFAULT XMLPORT_DEFAULT STARHOST_DEFAULT STARPORT_DEFAULT)],
);
# Field table structure :
# Note : should become an object some day
# $FieldEntry = {
# 'Name' => $FldName, # internal Star field name
# 'Index' => n, # internal field number
# 'Comment' => text, # field comment (DBDEF1)
# 'Label' => text, # label for data entry (DBDEF2)
# 'clear' => 0/1, # wether field contents should be pre-cleared (7)
# 'long' => 0/1, # wether field is long text (1)(7)
# 'Type' => text, # data type for data entry (2)
# 'InLen' => nn, # max line length for data entry (3)
# 'MO' => 0/1, # wether field is multiple occ. (1)
# 'ML' => 0/1, # wether to allow multiple lines (3)
# 'HID' => 0/1, # hidden (5)
# 'PRO' => 0/1, # protected, read-only (5)
# 'DATE' => fmt, # date field + format (5)(6)
# 'WF' => WF flags, # bitmap field (10)
# 'Valid' => text, # validation rule if any
# 'OccLen' => nnnn, # maximum occurrence length (4)
# 'Subs' => [], # false, or ref. to array of subfield descriptions (9)
# 'EOccs' => nn, # nb. of extra blank occs to display (8)
# 'occs' => [ ], # ref to array of occurrence values
# };
# Note 1 : "long" and "MO" are mutually exclusive
# Note 2 : if data type is "Long text", then "long => 1" and "MO => 0"
# Note 3 : mainly relative to Classic Star, but may be useful for web form formatting
# Note 4 : for MO fields, this should be 1011 max.
# Note 5 : web-only attributes
# Note 6 : if false, not a date, else format (e.g. "yyyy/mm/dd")
# Note 7 : Star XML attributes
# Note 8 : for web data entry
# Note 9 : for web data entry, not sure how to do this yet
# Note 10 : MO, ML, HID, etc... should be replaced by a bitflag field; started with WFxxx flags.
#--------------
# Constructor
#--------------
sub connect {
###########
# called as : eval {$con = new STAR::API2::STARXMLUTF($dsn,$user,$auth[,$attribs]);}
# if ($@) { process_error($@) }
#
# where :
# - $dsn is a string of the format : "starxml:xxx@host[:port]" or "starxml2:xxx@host[:port]"
# where :
# - "starxml:" or "starxml2:" indicates the StarXML version.
# Note 2011/02/04 : for StarXML 2.0+, we do not do the "kludge" about charsets in XML_request()
# - con is either the word "new" (for a new connection),
# or the connection-id of an existing (persistent) connection (starting with "CON")
# - host[:port] : DNS name (and optionally port) of the Star XML server host
# - $user : username or undef
# - $auth : password or undef
# - $attribs (optional) : a ref. to a hash of attributes (all optional), like :
# {
# starhost => "host:[port]", # DNS name and optional port of Star host, if not localhost (see notes)
# ping => 100, # ping every 100 seconds
# New 2011/02/04 :
# star48 => 0 or 1, # set to 1
# New 2015/11/06 :
# StoreLastErr = 0 or 1 # 1 = store last StarXML error response in connection, for debugging
# }
#
# $con is undef in case of error (and in that case $@ contains the "error object" (see notes))
# else $con is a STAR::API2::STARXMLUTF object representing the open connection with Star.
#
my $invocant = shift;
my $class = ref($invocant)||$invocant; #Object or class name
my ($dsn,$user,$auth,$attribs) = @_;
$user ||= '';
$auth ||= '';
$attribs = {} unless $attribs; # make it always defined as a hash
# a minimal 'self object' to have a place for error codes
my $self = {
# error management, private
'-ErrCat' => 0,
'-ErrCode' => 0,
'-ErrMsg' => "",
'-ErrSys' => "", # last $! message
};
srand( time() ^ ($$ + ($$ << 15)) ); # seed the random generator anyway
my $parsed_dsn;
unless ($parsed_dsn = _parse_dsn($dsn)) {
die "$class connect() : invalid dsn \"$dsn\" !";
}
my $ConId = $parsed_dsn->{ConId};
my $host = $parsed_dsn->{Host};
my $port = $parsed_dsn->{Port};
#my $xmlversion = $parsed_dsn->{Version}; # ignore this
my $error;
if ($ConId) {
# dsn contained connection-id, try to reconnect to cached session
$self = _get_connect($self,$ConId,$attribs);
if ($error = _getError($self)) {
die "$class connect() : ($error->{cat}/$error->{code}) $error->{msg}";
}
} else {
# get a new session
$self = _new_connect($self,$host,$port,$user,$auth,$attribs);
if ($error = _getError($self)) {
die "$class connect() : ($error->{cat}/$error->{code}) $error->{msg}";
} else {
bless ($self, $class);
}
}
# else we should have an active connection in $self
# $Debug = $self->{'-Debug'};
return $self;
}
sub _new_connect {
################
# called as : $con = (self,host,port,user,auth,attribs)
# return a hash or undef
my ($con,$host,$port,$user,$pw,$attribs) = @_;
my $Msg;
my $XMLOBJ; # generic XML::Simple object
my $XMLSRV; # the XML server socket
my $TimeOut;
# my $ConId = XML_id("CON"); # generate new connection-id
# generate a connection-id without calling XML_id(), to avoid circular logic
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
my $ConId = 'CON' . sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec) . sprintf("%06d",int(rand 999999));
my ($StarHost,$StarPort);
my ($StarUser,$StarPw);
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
my ($UsersDb,$UsersDbName,$UsersDbPw,$UsersDbId);
my ($FieldsDb,$FieldsDbName,$FieldsDbPw,$FieldsDbId);
my ($SaveDoUserPerms,$SaveDoDbPerms);
$con = {
'SERVER' => undef, # the server socket object
'LANG' => ELANG_DEFAULT, # default language for messages
# the following are general default values for the Star connections
'XMLHost' => $host || XMLHOST_DEFAULT,
'XMLPort' => $port || XMLPORT_DEFAULT,
'XMLVersion' => 1, # default
'STARHost' => STARHOST_DEFAULT,
'STARPort' => STARPORT_DEFAULT,
'STARVersion' => '4', # default
'STARUser' => $user || STARUSER_DEFAULT,
'STARPw' => $pw || STARPW_DEFAULT,
'STARReport' => '*DUMP',
'STARPage' => 'STARXML',
'NeedPing' => 0,
'PingDelay' => 3600,
'StoreLastErr' => 0,
'OpenReport' => 'XMLOPEN',
'OpenPage' => 'XMLOPEN',
'DoStats' => 0, # flag : 0=don't do stats, 1=do
'DoDbPerms' => 0, # flag : 0=don't check db permissions, 1=do
'DoUserPerms' => 0, # flag : 0=don't check User permissions, 1=do
'UsersDbName' => "XMLUSERS", # name of "users" db to check permissions etc...
'UsersDbPw' => "", # password for that db, should be set
'UsersProps' => "XMLUSER", # name of report in "UsersDb" to provide permissions etc...
'FieldsDbName' => "APPSDBDEFS", # name of db to retrieve input fields characteristics
'FieldsDbPw' => "", # password of ditto
'FieldsProps' => "APPMANAGE", # name of report in "FieldsDb" to provide permissions etc...
# shareable (?) r/w data
'XOB' => undef, # ref to a default, re-usable, basic XML::Simple object
'ConnectionId' => $ConId, # ConnectionId of the connection with the Star host
'STARCharset' => 'iso-8859-1', # initially, later as returned by Login or GetConnectionInfo
'Company' => "", # company code for this user
'Groups' => [ ], # ref to array of group codes for this user
'Vars' => {}, # global (DV) vars for this user
'DoStats' => 0, # flag : 0=don't do GetRecords stats, 1=do
'DoDbPerms' => 0, # flag : 0=don't check db permissions, 1=do
'DoUserPerms' => 0, # flag : 0=don't check User permissions, 1=do
# definitely private
'-NonoDBs' => qr/(STARHELP|USERS)/i, # list of databases with no access allowed by anyone
'-NoAnonDBs' => qr/(STARHELP|USERS)/i, # list of databases with no access allowed by 'anonymous' user
'-RonlyDBs' => qr/(STARHELP|USERS|APPSDBDEFS|.*SERVER)/i,
# definitely private
'-NextId' => 0, # keep counter 0 - 999999 instead of using "rand()" to generate id's
'-AllUTF' => 0, # everything is UTF-8 (Star 5.0 and later = 1)
'-XMLHDR' => XMLHDR, # default XML header to send for requests
'-DBs' => {}, # main table of databases; key = "connection-id#db-id"
'-DBGroups' => {}, # main table of database groups; key = "connection-id#dbgroup-id"
'-Locks' => {}, # main table of active locks; key = "connection-id#lock-id"
'-Debug' => 0, # debug/log level
'-XMLDebug' => 0, # XML debug/log level (specifically for exchanges with StarXML daemon)
'-TimeOut' => undef, # timeout for sockets
'-StarConnectTimeOut' => undef, # timeout for initial connection to Star
'-StarConnectTimeOutRetry' => 3, # number of seconds between retries, in case of timeout
'-Databases' => {}, # databases open on this connection (Id=>name)
'-Active' => 0, # flag 1=logged in, 0=not logged in
'-LastActive' => 0, # last timestamp where connection was active
# '-LastPing' => 0, (same as LastActive ?)
'-LastOp' => '', # last attempted action
'-LastOk' => '', # last succesful action
#'-UsersDb' => undef, # (avoid, creates circular ref) ref to db entry of "Users" db for this connection
'-UsersDbId' => undef, # Id of Users db
# '-FieldsDb' => undef, # (avoid, creates circular ref) ref to db entry for "fields" database for this connection
'-FieldsDbId' => undef, # db-Id of Fields db for this connection, undef if not opened
# stats, private
'-RequestCount' => 0,
'-SearchCount' => 0,
'-SearchHitCount' => 0,
'-ReportCount' => 0,
'-ReportHitCount' => 0,
'-ReportRetrievedCount' => 0,
'-ReportItemsCount' => 0,
'-RecordsRecalledCount' => 0,
'-RecordsUpdatedCount' => 0,
'-RecordsCreatedCount' => 0,
# error management, private
'-ErrCat' => 0,
'-ErrCode' => 0,
'-ErrMsg' => "",
'-ErrSys' => "", # store last $! message
'-ErrLastResponse' => "", # buffer to store last StarXML error response
# The following 4 are used only for heavy debugging of the StarXML dialogs
'-SaveLastRequest' => 0,
'-LastRequestBuf' => '',
'-SaveLastResponse' => 0,
'-LastResponseBuf' => '',
# Initialised flag, for re-use with same hosts
'-Initialised' => 0,
};
if ($attribs->{UTF8}) {
$con->{'-AllUTF'} = 1;
$con->{XMLVersion} = 5; # we don't expect a later version to ever exist
}
if ($attribs->{debuglevel}) {
$con->{'-Debug'} = $attribs->{debuglevel};
}
$Debug = $con->{'-Debug'};
if ($attribs->{'XMLdebug'}) {
$con->{'-XMLDebug'} = 1;
}
if ($attribs->{lang}) {
$con->{'LANG'} = $attribs->{lang};
}
if ($attribs->{starhost}) {
$con->{STARHost} = $attribs->{starhost};
if ($attribs->{starhost} =~ m/^(.*?)(:(\d+))?$/) {
$con->{STARHost} = $1; $con->{STARPort} = $3 if $3;
}
}
$StarHost = $con->{STARHost};
$StarPort = $con->{STARPort};
if ($attribs->{ping}) {
$con->{'NeedPing'} = 1;
$con->{'PingDelay'} = $attribs->{ping} if $attribs->{ping};
}
if ($attribs->{timeout}) {
$con->{'-TimeOut'} = $attribs->{timeout};
}
$TimeOut = $con->{'-TimeOut'};
if ($attribs->{'StoreLastErr'}) {
$con->{'StoreLastErr'} = $attribs->{'StoreLastErr'};
}
# The following 2 are *experimental*.
# They are meant to provide a way by which a "connect" can wait for Star
# to become available after a temporary pause (like for backups).
# see connect().
if ($attribs->{starConnectTimeout}) { # exists and not null
my $val = $attribs->{starConnectTimeout};
# keep reasonable
$val = 5 if $val < 5; $val = 86400 if $val > 86400; # 5 s. to 24 h.
$con->{'-StarConnectTimeOut'} = $val;
}
if ($attribs->{starConnectTimeoutRetry}) { # exists and not null
my $val = $attribs->{starConnectTimeoutRetry};
# keep reasonable
$val = 3 if $val < 3; $val = 3600 if $val > 3600; # 3 s. to 1 h.
$con->{'-StarConnectTimeOutRetry'} = $val;
}
# Connect to XML Server
log_msg(" Connecting to XML server at $con->{XMLHost}:$con->{XMLPort}") if $Debug >1;
# Set up TCP socket channel to server
_clearError($con);
unless ($XMLSRV = IO::Socket::INET->new(Proto=>"tcp",PeerAddr=>$con->{XMLHost},PeerPort=>$con->{XMLPort})) {
# could get this :(8/99) ; Star error : starapi.SSException; [AioError] java.net.ConnectException: Connection refused;
_setError($con,ECAT_COM,1,$!,"ERRCOM_01",$con->{XMLHost},$con->{XMLPort},$!);
return $con;
}
# Note AW 2017/02/19 : do we really need to do this ?
# The socket should always be raw/binary, no ?
# It is when we write to it, or read from nit, that we should send/read the stuff
# in the correct encoding, and not really on the IO layer to do that.
# I am afraid to change it though, since it seems to work in most cases.
if ($con->{'-AllUTF'}) {
binmode($XMLSRV,':raw');
} else {
binmode($XMLSRV,':raw'); # should always be so for a socket
}
# $XMLSRV->autoflush(1); # should be by default
log_msg(" Socket connected.") if $Debug >1;
if ($TimeOut) {
$TimeOut = $XMLSRV->IO::Socket::timeout($TimeOut);
}
$con->{'-Timeout'} = $TimeOut;
$con->{'SERVER'} = $XMLSRV; # save it
# Create a default XML::Simple object for re-use by other subs
_clearError($con);
my $xml_declaration = XMLHDR;
unless ($XMLOBJ = new XML::Simple(xmldecl=>$con->{'-XMLHDR'},keeproot=>1,rootname=>'Root',
forcearray=>0,forcecontent=>1,contentkey=>'$TEXT$')) {
_setError($con,ECAT_SYS,2,$!,"ERRSYS_02");
return $con;
}
$con->{'XOB'} = $XMLOBJ; # save this one for re-use by default
# get Star XML version
# Note : this is the single place in this module where we call getXMLInfo(),
# and then only for the pre 5.0 logic. We could optimise this away.
# However, getXMLInfo() is public, and may be called directly by some application.
# Therefor, we only optinise it away in case the connection is made with the 'UTF8'=true.
my $xmlversion;
unless ($con->{'-AllUTF'}) {
unless ($xmlversion = getXMLInfo($con)) {
Carp::carp "Could not retrieve XML Server version";
return undef;
}
log_msg(" StarXML version is [$xmlversion]") if $Debug >2;
if ($xmlversion =~ m/^(\d).*/) {
$con->{XMLVersion} = $1;
log_msg(" stored XMLversion is [" . $con->{XMLVersion} . "]") if $Debug >2;
}
}
unless ($con->{XMLVersion} < 2) {
$con->{'-AllUTF'} = 1;
$con->{'-XMLHDR'} = XMLHDRUTF; # always send UTF-8 requests
}
# Login to Star host
$StarUser = $con->{STARUser};
$StarPw = $con->{STARPw};
log_msg("Star login : ConId[$ConId],Host[$StarHost],Port[$StarPort],UserId[$StarUser]") if $Debug >1;
# request
$XMLRequest = {
'Root' =>{
'Login' =>{
'Connection'=>{
'Id'=>$con->{ConnectionId},
'Host'=>$StarHost,
'Port'=>$StarPort,
'UserId'=>$StarUser,
# 'Password'=>$StarPw,
},
'-dummy'=>"x",
},
},
};
if ($StarPw ne '') {
$XMLRequest->{'Root'}->{'Login'}->{'Connection'}->{'Password'} = $StarPw;
}
# Allow retries for Star connection, limited by a timeout
# starConnectStart : the time at which we start measuring. iow, now.
# starConnectTimeOut : the duration (in s.) after which we will give up.
# This is a parameter of the connection, passed in the StarAttribs hash.
# The default is undef or 0, which means : do not retry.
# starConnectTimeOutRetry : is the time (in s.) which we sleep between retries
# This is a parameter of the connection, passed in the StarAttribs hash.
# starConnectLimit : the time at which we will give up.
my $starConnectTimeOut = $con->{'-StarConnectTimeOut'} || 0;
my $starConnectTimeOutRetry = $con->{'-StarConnectTimeOutRetry'} || 3;
my $starConnectStart = time();
my $starConnectLimit = $starConnectStart + $starConnectTimeOut;
my $StarConnected = 0; # escape valve
CONTIMEOUT: while (1) {
# send the login request
_clearError($con);
unless (defined($XMLResponse = XML_Request($con,$XMLRequest,$XMLOBJ,{'forcearray'=>0},undef))) {
# communication error with StarXML, nothing we can do about that except wait ?
_setError($con,ECAT_COM,2,'',"ERRCOM_02","Login");
last CONTIMEOUT;
# alternatively ?
#last CONTIMEOUT if (time() > $starConnectLimit);
## else we sleep for the alloted time, then loop
#sleep $starConnectTimeOutRetry;
#next CONTIMEOUT;
}
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Login' => {
# 'Connection' = {
# 'Host' = "host",
# 'Id' = "Id",
# 'Port' = "port",
# 'UserId' = "user",
# 'Password' = "pw",
# }, # /Connection
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Login
# }, # /Root
# }; # /XMLResponse
# e.g.
# emsg="starapi.SSException; [SSesFailUnavail] SesFailUnavail: <
# STAR system is not available - stand-alone program running.>; ">
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount eq "0") {
# great, we are connected and logged-in
$StarConnected = 1;
last CONTIMEOUT;
}
# else there is a problem, maybe fatal maybe not
# The message is in the "emsg" attribute of <Login>
$Emsg = $XMLResponse->{'Root'}->{'Login'}->{'emsg'};
if ($Emsg =~ /\[SSesFailLogin\]/i) {
# id or password problem, fatal, abort the attempt
_setError($con,ECAT_STAR,1,$!,"ERRSTA_53",$Emsg);
last CONTIMEOUT;
} elsif ($Emsg =~ /\[SSesFailAccess\]/i) {
# User has incorrect permissions, fatal, abort the attempt
_setError($con,ECAT_STAR,53,$!,"ERRSTA_51",$Emsg);
last CONTIMEOUT;
} elsif ($Emsg =~ /\[SSesFailUnavail\]/i) {
# presume Star is not available right now, not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} elsif ($Emsg =~ /\[SSesFailLicense]/i) {
# Running short of licenses ?, not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} elsif ($Emsg =~ /\[SSesFailReserve]/i) {
# Similar to [SSesFailLicense] (no more unreserved licenses), not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} else {
# considered as not fatal, allow retry
_setError($con,ECAT_STAR,99,$!,"ERRSTA_99",$Emsg);
}
# Determine if we should break out of the loop, regarding timeout.
# The following always jumps out if there was no timeout set
last CONTIMEOUT if (time() > $starConnectLimit);
# else we sleep for the alloted time, then loop
sleep $starConnectTimeOutRetry;
#next CONTIMEOUT;
} # end while CONTIMEOUT
unless ($StarConnected) {
log_msg("** Login request failed : $Emsg **") if $Debug;
return $con;
}
log_msg("Succesful login, ConnectionId=\"$ConId\".") if $Debug>1;
$con->{'-Active'} = 1;
$con->{'-LastActive'} = time();
# use GetConnectionInfo to find out charset of server
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'GetConnectionInfo' =>{
'ConnectionId'=>$con->{ConnectionId},
},
},
};
# send the request
unless (defined($XMLResponse = XML_Request($con,$XMLRequest,$XMLOBJ))) {
# No return hash
_setError($con,ECAT_COM,2,'',"ERRCOM_02","GetConnectionInfo");
return $con;
}
# Expected response :
# XMLResponse --> {
# 'Root' => {
# 'GetConnectionInfo' => {
# 'ConnectionId' => "id",
# 'Version' => "version",
# 'Charset' => "charset",
# 'ecount' => "errorcount",
# 'emsg' => "error message",
# }, # /GetConnectionInfo
# }, # /Root
# }; # /XMLResponse
$Ecount = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'ecount'};
if ($Ecount && ($Ecount ne "0")) {
# Connection to Star is probably lost
$Emsg = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'emsg'};
$Msg = "** Star Info request error : $Emsg **";
_setError($con,ECAT_COM,6,'',"ERRCOM_06","GetConnectionInfo");
log_msg("** GetConnectionInfo request failed : $Emsg **") if $Debug;
return $con;
}
# get charset and Star version, and set in $con object
my $Charset = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'Charset'};
$Charset = "8859-1" unless $Charset;
$Charset = "iso-${Charset}" if ($Charset =~ /^8859/);
$con->{'STARCharset'} = $Charset;
$con->{'STARVersion'} = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'Version'} || '4';
$con->{'-Initialised'} = 1;
return $con;
}
sub _get_connect {
################
# called as : $con = _get_connect($con,$ConId,$attribs)
#
# retrieves an existing (cached) connection with key = $ConId from ... ?
my $con = shift;
_setError($con,ECAT_SYS,98,$!,"ERRSYS_98","_get_connect()");
return $con; # not yet implemented
}
sub reconnect {
my $pfx = 'reconnect()';
my $con = shift;
# called as : $result = $con->reconnect();
# is entered with a connection object that has been previously initialised and used,
# so we can re-use a whole bunch of stored settings.
Carp::confess "Invalid call !" unless (ref($con) =~ /^STAR::API2::STARXMLUTF/);
Carp::confess "Not an initialised connection !" unless ($con->{'-Initialised'} == 1);
my $Debug = $con->{'-Debug'};
# Connect to XML Server
unless (_openXML($con)) {
log_msg("$pfx: ** Could open StarXML connection **") if $Debug;
return undef;
}
# Login to Star host
unless (_openStar($con)) {
log_msg("$pfx: ** Could open Star connection **") if $Debug;
return undef;
}
}
sub _openXML {
my $pfx = '_openXML()';
my $con = shift;
my $Debug = $con->{'-Debug'};
my $XMLSRV; # store socket
# Connect to XML Server
log_msg("pfx: (re-)connecting to XML server at $con->{XMLHost}:$con->{XMLPort}") if $Debug >1;
# Set up TCP socket channel to server
_clearError($con);
unless ($XMLSRV = IO::Socket::INET->new(Proto=>"tcp",PeerAddr=>$con->{XMLHost},PeerPort=>$con->{XMLPort})) {
# could get this :(8/99) ; Star error : starapi.SSException; [AioError] java.net.ConnectException: Connection refused;
_setError($con,ECAT_COM,1,$!,"ERRCOM_01",$con->{XMLHost},$con->{XMLPort},$!);
return undef;
}
# should we use binmode($XMLSRV,':utf8') ?
binmode($XMLSRV,':raw'); # should always be so for a socket
# $XMLSRV->autoflush(1); # should be by default
log_msg("$pfx: socket connected.") if $Debug >1;
if ($con->{'-TimeOut'}) {
$XMLSRV->timeout($con->{'-TimeOut'});
}
$con->{'SERVER'} = $XMLSRV; # save the socket object
return 1;
}
sub _openStar {
my $pfx = '_openStar()';
my $con = shift;
my $Debug = $con->{'-Debug'};
# Login to Star host
my $StarHost = $con->{STARHost};
my $StarPort = $con->{STARPort};
my $StarUser = $con->{STARUser};
my $StarPw = $con->{STARPw};
# my $ConId = XML_id("CON"); # generate new connection-id
# generate a connection-id without calling XML_id(), to avoid circular logic
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
my $ConId = 'CON' . sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec) . sprintf("%06d",int(rand 999999));
$con->{ConnectionId} = $ConId;
my $XMLOBJ = $con->{'XOB'}; # re-use stored XML::Simple object
log_msg("Star login : ConId=\"$ConId\",Host=\"$StarHost\",Port=\"$StarPort\",UserId=\"$StarUser\"") if $Debug >1;
my ($XMLRequest,$XMLResponse);
# request
$XMLRequest = {
'Root' =>{
'Login' =>{
'Connection'=>{
'Id'=>$ConId,
'Host'=>$StarHost,
'Port'=>$StarPort,
'UserId'=>$StarUser,
# 'Password'=>$StarPw,
},
'-dummy'=>"x",
},
},
};
if ($StarPw ne '') {
$XMLRequest->{'Root'}->{'Login'}->{'Connection'}->{'Password'} = $StarPw;
}
# Allow retries for Star connection, limited by a timeout
# starConnectStart : the time at which we start measuring. iow, now.
# starConnectTimeOut : the duration (in s.) after which we will give up.
# This is a parameter of the connection, passed in the StarAttribs hash.
# The default is undef or 0, which means : do not retry.
# starConnectTimeOutRetry : is the time (in s.) which we sleep between retries
# This is a parameter of the connection, passed in the StarAttribs hash.
# starConnectLimit : the time at which we will give up.
my $starConnectTimeOut = $con->{'-StarConnectTimeOut'} || 0;
my $starConnectTimeOutRetry = $con->{'-StarConnectTimeOutRetry'} || 3;
my $starConnectStart = time();
my $starConnectLimit = $starConnectStart + $starConnectTimeOut;
my $StarConnected = 0; # escape valve
my $Emsg = '';
my ($RootEcount,$Ecount);
CONTIMEOUT: while (1) {
# send the login request
_clearError($con);
unless (defined($XMLResponse = XML_Request($con,$XMLRequest,$XMLOBJ,{'forcearray'=>0},undef))) {
# communication error with StarXML, nothing we can do about that except wait ?
_setError($con,ECAT_COM,2,'',"ERRCOM_02","Login");
last CONTIMEOUT;
# alternatively ?
#last CONTIMEOUT if (time() > $starConnectLimit);
## else we sleep for the alloted time, then loop
#sleep $starConnectTimeOutRetry;
#next CONTIMEOUT;
}
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Login' => {
# 'Connection' = {
# 'Host' = "host",
# 'Id' = "Id",
# 'Port' = "port",
# 'UserId' = "user",
# 'Password' = "pw",
# }, # /Connection
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Login
# }, # /Root
# }; # /XMLResponse
# e.g.
# emsg="starapi.SSException; [SSesFailUnavail] SesFailUnavail: <
# STAR system is not available - stand-alone program running.>; ">
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount eq "0") {
# great, we are connected and logged-in
$StarConnected = 1;
last CONTIMEOUT;
}
# else there is a problem, maybe fatal maybe not
# The message is in the "emsg" attribute of <Login>
$Emsg = $XMLResponse->{'Root'}->{'Login'}->{'emsg'};
if ($Emsg =~ /\[SSesFailLogin\]/i) {
# id or password problem, fatal, abort the attempt
_setError($con,ECAT_STAR,1,$!,"ERRSTA_53",$Emsg);
last CONTIMEOUT;
} elsif ($Emsg =~ /\[SSesFailAccess\]/i) {
# User has incorrect permissions, fatal, abort the attempt
_setError($con,ECAT_STAR,53,$!,"ERRSTA_51",$Emsg);
last CONTIMEOUT;
} elsif ($Emsg =~ /\[SSesFailUnavail\]/i) {
# presume Star is not available right now, not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} elsif ($Emsg =~ /\[SSesFailLicense]/i) {
# Running short of licenses ?, not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} elsif ($Emsg =~ /\[SSesFailReserve]/i) {
# Similar to [SSesFailLicense] (no more unreserved licenses), not fatal, allow retry
_setError($con,ECAT_STAR,02,$!,"ERRSTA_02",$Emsg);
} else {
# considered as not fatal, allow retry
_setError($con,ECAT_STAR,99,$!,"ERRSTA_99",$Emsg);
}
# Determine if we should break out of the loop, regarding timeout.
# The following always jumps out if there was no timeout set
last CONTIMEOUT if (time() > $starConnectLimit);
# else we sleep for the alloted time, then loop
sleep $starConnectTimeOutRetry;
#next CONTIMEOUT;
} # end while CONTIMEOUT
unless ($StarConnected) {
log_msg("$pfx: ** Login request failed : $Emsg **") if $Debug;
return undef;
}
log_msg("$pfx: Succesful login, ConnectionId=\"$ConId\".") if $Debug>1;
$con->{'-Active'} = 1;
$con->{'-LastActive'} = time();
# use GetConnectionInfo to find out charset of server
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'GetConnectionInfo' =>{
'ConnectionId'=>$con->{ConnectionId},
},
},
};
# send the request
unless (defined($XMLResponse = XML_Request($con,$XMLRequest,$XMLOBJ))) {
# No return hash
_setError($con,ECAT_COM,2,'',"ERRCOM_02","GetConnectionInfo");
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' => {
# 'GetConnectionInfo' => {
# 'ConnectionId' => "id",
# 'Version' => "version",
# 'Charset' => "charset",
# 'ecount' => "errorcount",
# 'emsg' => "error message",
# }, # /GetConnectionInfo
# }, # /Root
# }; # /XMLResponse
$Ecount = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'ecount'};
if ($Ecount && ($Ecount ne "0")) {
# Connection to Star is probably lost
$Emsg = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'emsg'};
_setError($con,ECAT_COM,6,'',"ERRCOM_06","GetConnectionInfo");
log_msg("** GetConnectionInfo request failed : $Emsg **") if $Debug;
return undef;
}
# get charset and set in $con object
my $Charset = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'Charset'};
$Charset = "8859-1" unless $Charset;
$Charset = "iso-${Charset}" if ($Charset =~ /^8859/);
$con->{'STARCharset'} = $Charset;
$con->{'STARVersion'} = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'Version'} || '4';
$con->{'ErrLastResponse'} = ''; # clean this up in normal case
return 1;
}
# Note : from here on, the STARXMLUTF object itself is called "$srv", not the usual "$self". Personal choice.
sub openDB {
##########
# Open a Star database connection
# called as : $DbId = srv->openDB(DbName=>"dbname"[,Password=>"dbpassword"]);
# returns : database-id on success (& updates $Databases table)
# undef on failure (error code in $SRV)
#
# Note : if the database is one of the special Users db or Fields db, we always set the permissions
# to "read only" and do not return the list of fields.
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
# Entry for dbs table
my $ThisDb = {
'Id' => undef, # new id
'ConId' => undef, # mandatory supplied param
'DbName' => undef, # optional supplied param
'ServerRecordName' => undef, # optional supplied param
'Password' => undef, # optional supplied param
'OpenReport' => undef, # optional supplied param
'OpenPage' => undef, # optional supplied param
'-Active' => 0, # "open" flag
'-LastOp' => "open", # last operation attempted
'-Perms' => undef, # permissions bitmap for this db
'-FieldPerms' => undef, # fields permissions
'-LastOpen' => 0, # last open timestamp
'-DbDefsUp' => 0, # update timestamp of dbdefs definitions (from FieldsDb)
'-InputFieldsA' => undef, # ref to array of input field names in record order
'-InputFieldsH' => undef, # ref to hash of input field descriptions
'-SearchFieldsA' => undef, # ref to array of search field names in record order
'-SearchFieldsH' => undef, # ref to hash of search field descriptions
'-OutFieldsA' => undef, # ref to array of output field names in record order
'-OutFieldsH' => undef, # ref to hash of output field descriptions
'-OutReportsA' => undef, # ref to array of report format names in record order
'-OutReportsH' => undef, # ref to hash of report format descriptions
'-SpaceName' => undef, # space location for database
'-ViewOf' => undef, # name of base db if this is a view
# statistics
'-RequestCount' => 0,
'-SearchCount' => 0,
'-SearchHitCount' => 0,
'-ReportCount' => 0,
'-ReportHitCount' => 0,
'-ReportRetrievedCount' => 0,
'-ReportItemsCount' => 0,
'-RecordsRecalledCount' => 0,
'-RecordsUpdatedCount' => 0,
'-RecordsCreatedCount' => 0,
@_, # overwrite with call parameters
};
$ThisDb->{Password} = '' unless $ThisDb->{Password}; # change undef to ''
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $Databases = $srv->{'-Databases'}; # database names table for this Star connection
my $dbname = '';
my $serverrecordname = '';
if($ThisDb->{DbName}) {
$dbname = $ThisDb->{DbName};
} elsif($ThisDb->{ServerRecordName}) {
$serverrecordname = $ThisDb->{ServerRecordName};
}
my $dbpw = $ThisDb->{Password}; # can be empty
my $ConId = $srv->{ConnectionId};
my $ThisDbId;
my $result;
my ($UsersDbName,$FieldsDbName);
my $Perms; # permissions to this database
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
if($dbname) {
log_msg("==>openDB(DbName=>\"$dbname\")") if $Debug > 1;
} elsif($serverrecordname) {
log_msg("==>openDB(ServerRecordName=>\"$serverrecordname\")") if $Debug > 1;
} else {
Carp::croak "** Invalid or missing database name or server record name **"
}
$ThisDbId = _XML_id($srv,"DB"); # get new id
$ThisDb->{Id} = $ThisDbId; # store in table
$ThisDb->{OpenReport} ||= $srv->{'-OpenReport'};
$ThisDb->{OpenPage} ||= $srv->{'-OpenPage'};
# preset this db ref into main db tables (inactive)
$DBs->{$ThisDbId} = $ThisDb; # main key => db structure
$UsersDbName = $srv->{'UsersDbName'};
$FieldsDbName = $srv->{'FieldsDbName'};
if (($dbname eq $UsersDbName) || ($dbname eq $FieldsDbName)) {
# Special case for 'Users' and 'Fields' databases
$ThisDb->{'-Perms'} = PERM_READ;
} else {
# All other db's
# If database permissions are active, check that first
if ($srv->{'DoDbPerms'}) {
# ** Note : the following is not implemented yet **
$Perms = $srv->SetDbInfo(DBId=>$ThisDbId);
unless ($Perms) {
# 0 or undef : we don't have access at all
$srv->_setError(ECAT_STAR,51,'',"ERRSTA_51","openDB()");
return undef;
}
} else {
$Perms = PERM_ALL;
}
$ThisDb->{'-Perms'} = $Perms;
}
# Else we have at least some access to it
log_msg("Permissions for db are : " . $ThisDb->{'-Perms'} ) if $Debug >1;
# Prepare the OpenDatabase request
# mandatory args
if($dbname) {
$XMLRequest = {
'Root' =>{
'Database' =>{
'Id'=>$ThisDbId,
'ConnectionId'=>$ConId,
'DatabaseName'=>$dbname,
},
'-dummy'=>"x",
},
};
} elsif($serverrecordname) {
$XMLRequest = {
'Root' =>{
'Database' =>{
'Id'=>$ThisDbId,
'ConnectionId'=>$ConId,
'ServerRecordName'=>$serverrecordname,
},
'-dummy'=>"x",
},
};
}
# add optional args
if ($dbpw) {
$XMLRequest->{'Root'}->{'Database'}->{'Password'} = $dbpw;
}
# # get our own XML::Simple object, to specify some options
# # (can we use the global one ?)
# $XMLObj = new XML::Simple(
# xmldecl => XMLHDR,
# keeproot => 1,
# rootname => 'Root',
# forcearray => 0,
# );
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","openDB()");
return undef;
}
# Expected response
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Database' = {
# 'Id' = "Id",
# 'DatabaseName' = "name",
# 'Password' = "pw",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'Database'}->{'emsg'};
if ($Emsg =~ /\[SDBNotFound\]/i) {
_setError($srv,ECAT_STAR,52,'',"ERRSTA_52","openDB($dbname) : ",$Emsg);
} elsif ($Emsg =~ /\[yyyy\]/i) {
_setError($srv,ECAT_STAR,12,'',"ERRSTA_12","openDB($dbname) : ",$Emsg);
} else {
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
}
# remove database entry
$DBs->{$ThisDbId} = undef; # main key => db structure
delete $DBs->{$ThisDbId};
return undef;
}
if($serverrecordname) {
$dbname = $XMLResponse->{'Root'}->{'Database'}->{'ActualDatabaseName'};
$ThisDb->{'DbName'} = $dbname;
}
log_msg("Database $dbname opened, id=\"$ThisDbId\".") if $Debug>1;
$ThisDb->{'-Active'} = 1;
$ThisDb->{'-LastOpen'} = time();
$srv->{'-LastActive'} = time();
$Databases->{$ThisDbId} = $dbname; # add it to db table in connection
# special case if it's the FieldsDb
if ($dbname eq $FieldsDbName) {
$srv->{'-FieldsDbId'} = $ThisDbId;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==openDB(ok)") if $Debug > 1;
return $ThisDbId;
}
#
# Group multiple Databases
#
sub databaseGroup {
# Group multiple Databases into one group for combined searching
# called as : srv->databaseGroup(DbGid => $dbgid, DbIds => \@DbIds);
# where :
# - DbGid is the group id to be used
# - DbIds is a array of database IDs
# returns : - true on success, undef on failure
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Debug = $srv->{'-Debug'};
my %args = @_;
#my $dbgid = $args{'DbGid'} or Carp::croak "**DbGid argument missing or invalide **";
my $dbgid = _XML_id($srv,'DBG');
log_msg("==>databaseGroup($dbgid)") if $Debug > 1;
my $dbids = $args{'DbIds'} or Carp::croak "** DbIds argument missing or ivalid **";
my $XMLObj;
my $XMLRequest;
my $XMLResponse;
my $RootEcount;
my ($Ecount, $Emsg);
$srv->{'-DBGroups'}->{$dbgid} = $dbids;
# Prepare GroupDatabase request
$XMLRequest = {
'Root' => {
'DatabaseGroup' => {
'Id' => $dbgid,
'Add' => [],
},
},
};
my $add = $XMLRequest->{'Root'}->{'DatabaseGroup'}->{'Add'};
for my $dbid(@{ $dbids }) {
next unless $dbid;
my $addxml = {
'DatabaseId' => $dbid,
};
push @$add, $addxml;
}
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
unless (defined($XMLResponse = XML_Request($srv, $XMLRequest, $XMLObj))) {
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","databaseGroup()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' = "0\n", # always
# 'emsg' = "error message", #only if errors
# 'DatabaseGroup' = {
# 'Id' = dbgid,
# 'ecount' = "ecount",
# 'emsg' = "error message,
# 'Add' = {
# 'DatabaseId = "dbid",
# },
# },
# },
# };
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
$Emsg = $XMLResponse->{'Root'}->{'emsg'};
my $Msg = "**databaseGroup request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,"ERRSTA_99", $Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
return $dbgid;
}
sub openServerDB {
################
my $pfx = 'openServerDB()';
# Warning : use only with Star 5.0+
# Open a Star database connection (for searching) using a SERVER record
# called as : $DbId = srv->openServerDB(ServerRecordName=>"name"[,Password=>"dbpassword"]);
# returns : database-id on success (& updates $Databases table)
# undef on failure (error code in $SRV)
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
# Entry for dbs table
my $ThisDb = {
'Id' => undef, # new id
'ConId' => undef, # mandatory supplied param
'DbName' => undef, # optional supplied param
'ServerRecordName' => undef, # optional supplied param
'Password' => undef, # optional supplied param
'OpenReport' => undef, # optional supplied param
'OpenPage' => undef, # optional supplied param
'-Active' => 0, # "open" flag
'-LastOp' => "open", # last operation attempted
'-Perms' => undef, # permissions bitmap for this db
'-FieldPerms' => undef, # fields permissions
'-LastOpen' => 0, # last open timestamp
'-DbDefsUp' => 0, # update timestamp of dbdefs definitions (from FieldsDb)
'-InputFieldsA' => undef, # ref to array of input field names in record order
'-InputFieldsH' => undef, # ref to hash of input field descriptions
'-SearchFieldsA' => undef, # ref to array of search field names in record order
'-SearchFieldsH' => undef, # ref to hash of search field descriptions
'-OutFieldsA' => undef, # ref to array of output field names in record order
'-OutFieldsH' => undef, # ref to hash of output field descriptions
'-OutReportsA' => undef, # ref to array of report format names in record order
'-OutReportsH' => undef, # ref to hash of report format descriptions
'-SpaceName' => undef, # space location for database
'-ViewOf' => undef, # name of base db if this is a view
# statistics
'-RequestCount' => 0,
'-SearchCount' => 0,
'-SearchHitCount' => 0,
'-ReportCount' => 0,
'-ReportHitCount' => 0,
'-ReportRetrievedCount' => 0,
'-ReportItemsCount' => 0,
'-RecordsRecalledCount' => 0,
'-RecordsUpdatedCount' => 0,
'-RecordsCreatedCount' => 0,
@_, # overwrite with call parameters
};
$ThisDb->{Password} = '' unless $ThisDb->{Password}; # change undef to ''
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $Databases = $srv->{'-Databases'}; # database names table for this Star connection
my $dbname = '';
my $serverrecordname = $ThisDb->{ServerRecordName} or Carp::croak "** Invalid or missing database name or server record name **";
log_msg("==>$pfx(ServerRecordName=>\"$serverrecordname\")") if $Debug > 1;
my $dbpw = $ThisDb->{Password}; # can be empty
my $ConId = $srv->{ConnectionId};
my $ThisDbId;
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
$ThisDbId = _XML_id($srv,"DB"); # get new id
$ThisDb->{Id} = $ThisDbId; # store in table
$ThisDb->{OpenReport} ||= $srv->{'-OpenReport'};
$ThisDb->{OpenPage} ||= $srv->{'-OpenPage'};
# preset this db ref into main db tables (inactive)
$DBs->{$ThisDbId} = $ThisDb; # main key => db structure
my $Perms = PERM_ALL;
$ThisDb->{'-Perms'} = $Perms;
# Else we have at least some access to it
#log_msg("Permissions for db are : " . $ThisDb->{'-Perms'} ) if $Debug >1;
# Prepare the OpenDatabase request
# mandatory args
$XMLRequest = {
'Root' =>{
'Database' =>{
'Id'=>$ThisDbId,
'ConnectionId'=>$ConId,
'ServerRecordName'=>$serverrecordname,
},
'-dummy'=>"x",
},
};
# add optional args
if ($dbpw) {
$XMLRequest->{'Root'}->{'Database'}->{'Password'} = $dbpw;
}
# send the request
unless (defined($XMLResponse = XML_RequestUTF($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","openDB()");
return undef;
}
# Expected response
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Database' = {
# 'Id' = "Id",
# 'ActualDatabaseName' = "name",
# 'Password' = "pw",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'Database'}->{'emsg'};
if ($Emsg =~ /\[SDBNotFound\]/i) {
_setError($srv,ECAT_STAR,52,'',"ERRSTA_52","openDB($dbname) : ",$Emsg);
} elsif ($Emsg =~ /\[yyyy\]/i) {
_setError($srv,ECAT_STAR,12,'',"ERRSTA_12","openDB($dbname) : ",$Emsg);
} else {
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
}
# remove database entry
$DBs->{$ThisDbId} = undef; # main key => db structure
delete $DBs->{$ThisDbId};
return undef;
}
$dbname = $XMLResponse->{'Root'}->{'Database'}->{'ActualDatabaseName'};
log_msg("Database $dbname opened, id=\"$ThisDbId\".") if $Debug>1;
$ThisDb->{'-Active'} = 1;
$ThisDb->{'-LastOpen'} = time();
$srv->{'-LastActive'} = time();
$Databases->{$ThisDbId} = $dbname; # add it to db table in connection
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==$pfx(ok)") if $Debug > 1;
return $ThisDbId;
}
#
# Retrieving info about database fields
#
sub getDbDefs {
#############
# Get DB definition data for an (open) database.
# Depends on the APPSDBDEFS db / APPMANAGE report remaining as per 3.9.8
# Gets definitions of Input fields, Search fields, Output fields, Reports
# and fills in the appropriate tables in the DB table.
# called as : result = srv->getDbDefs(DbId=>$DbId);
# where :
# - ConId is the Star connection-id
# - DbId is the database-id of the db of which we want the Defs
# (the database must have been previously opened on this connection)
# returns : - true on success, undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
log_msg("==>getDbDefs($dbid)") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
my $SaveDoDbPerms;
my ($FieldsDbId,$FieldsDb,$FieldsDbName,$FieldsDbPw);
my ($InFieldsTblA,$InFieldsTblH);
my ($SearchFieldsTblA,$SearchFieldsTblH);
my ($OutFieldsTblA,$OutFieldsTblH);
my ($ReportsTblA,$ReportsTblH);
my ($SearchClear,$SearchNb,$SearchExpr);
my ($PermsMask,$DbPerms);
my ($StarRpt,$StarRptId,$StarPage,$OutFldList,$SortFldList);
my ($RetCode,$RecCount,$ItemsCount,$LinesCount);
my ($TotItems,$FirstItem,$NumItems);
my $Records;
my ($ThisRec,$ThisFld);
my ($FldName,$FldVal);
my ($InFldName,$InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid);
my ($SFldName,$SFldIdx,$SFldRule,$SFldOpt,$SFldSub,$SFldProx,$SFldBase);
my ($OFldName,$OFldLab,$OFldRep,$OFldSpecs);
my ($ORptName,$ORptPage,$ORptSpecs,$ORptSort);
my ($AdoName,$AdoSpace,$AdoView,$AdoUp);
my ($UpUser,$UpDate,$UpYy,$UpMm,$UpDd,$UpTime,$UpH,$UpM,$UpS);
my $rest;
my $FieldData;
# Verify that we have permission to access that database.
# We need at least one of the Edit/Create/Delete/Global/Manage permissions.
$PermsMask = PERM_EDIT | PERM_CREATE | PERM_DELETE | PERM_GLOBAL | PERM_MANAGE;
$DbPerms = $ThisDb->{'-Perms'};
unless ($DbPerms & $PermsMask) {
# returns undef if error
$srv->_setError(ECAT_STAR,51,'',"ERRSTA_51","getDbDefs($ThisDbName)");
return undef;
}
# Retrieve the dbdefs for this database, from the FieldsDb
$FieldsDbName = $srv->{'FieldsDbName'};
$FieldsDbPw = $srv->{'FieldsDbPw'};
$FieldsDbId = $srv->{'-FieldsDbId'};
# Open the FieldsDB only if necessary
unless ($FieldsDbId && $DBs->{$FieldsDbId} && $DBs->{$FieldsDbId}->{'-Active'}) {
warn "FieldsDb ($FieldsDbId) not open, opening it" if $Debug>1;
$FieldsDbId = $srv->openDB(DbName=>$FieldsDbName,Password=>$FieldsDbPw);
unless (defined($FieldsDbId)) {
# append error msg
$Msg = "getDbDefs() : Could not open Fields database \"$FieldsDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
}
$SearchClear = 1;
$SearchNb = "1";
$SearchExpr = "NAME=$ThisDbName";
$RecCount = $srv->singleDbSearch(DbId=>$FieldsDbId,SearchNumber=>$SearchNb,Search=>$SearchExpr);
unless (defined($RecCount)) {
# append error msg
$Msg = "getDbDefs() : Error in search, db=\"$FieldsDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'-LastActive'} = time();
unless ($RecCount == 1) {
$Msg = "getDbDefs() : $RecCount dbdefs record found for \"$ThisDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$StarRpt = "APPMANAGE";
$StarPage = "STARXML";
# $OutFldList = [qw(DATAF/N VALID/N SERCH/N OUTPT/N REPRT/N SPNAM/N UP/N)];
$OutFldList = [qw(DATAF/N VALID/N SERCH/N OUTPT/N REPRT/N ADO/N)];
#$SortFldList = [qw(DBNOP)];
$SortFldList = [];
$StarRptId= _XML_id($srv,"RPT"); # unique report-id
$RetCode = $srv->singleDbReport(DbId=>$FieldsDbId,RptId=>$StarRptId
,Report=>$StarRpt,Page=>$StarPage,Search=>"S1"
,OutFields=>$OutFldList,SortFields=>$SortFldList);
unless (defined($RetCode)) {
$Msg = "getDbDefs() : Report \"$StarRpt\" could not be generated";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
($ItemsCount,$LinesCount) = split(",",$RetCode);
# Note : this should get us exactly 1 item
log_msg("Report generated, $ItemsCount items, $LinesCount lines.") if $Debug>1;
if ($ItemsCount != 1) {
$Msg = "getDbDefs() : Report \"$StarRpt\" has more than 1 item";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$TotItems = "1";
$FirstItem = "0";
$NumItems = 1;
unless (defined($Records = $srv->getReportRecords(RptId=>$StarRptId,FirstItem=>$FirstItem,Items=>$NumItems))) {
$Msg = "** Could not retrieve records, error : \"";
$Msg = "getDbDefs() : Could not retrieve records";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'-LastActive'} = time();
# output example :
# <Field OutputFieldName="DATAF">RTYPE |n 37 |c Record
# type (SINGle / MULTiple) |2 Record type |3 1 |4 No
# |5 No |6 15 |7 1 |8 No |9 Uppercase |v RTYPE</Field>
# <Field OutputFieldName="DATAF">AN |n 35 |c Accession
# Number |2 Accession # |3 1 |4 No |5 No |6 15 |7 1 |8
# No |9 Coded</Field>
# <Field OutputFieldName="VALID">RTYPE |r Values s*=SINGLE;c*=COLLECTION</Field>
# <Field OutputFieldName="VALID">|r</Field>
# Process the fields
$InFieldsTblA = [];
$InFieldsTblH = {};
$SearchFieldsTblA = [];
$SearchFieldsTblH = {};
$OutFieldsTblA = [];
$OutFieldsTblH = {};
$ReportsTblA = [];
$ReportsTblH = {};
$ThisRec = $Records->[0];
LINES: foreach $ThisFld (@{$ThisRec->{'Field'}}) {
$FldName = $ThisFld->{'OutputFieldName'};
# the following fields are normally absent from XMLOPEN records, but just in case
next LINES if ($FldName =~ /^(Sort|Next|Prev)/);
$FldVal = $ThisFld->{'$TEXT$'};
$FldVal = "" unless defined $FldVal;
#$FldVal =~ s/\015\012|\012//g; # eliminate embedded CRLF's
#$FldVal =~ s/\s\s+/ /g; # eliminate duplicate consecutive spaces
# Note : shouldn't have indentation anymore since v 1.6.4
$FldVal =~ s/(\x0D)?\x0A\s{19}//gs; # eliminate indentation
log_msg(" processing ($FldName) line : $FldVal") if $Debug >1;
# Process line types, most frequent ones first
OUTPT: {
last OUTPT unless ($FldName eq "OUTPT");
# output example :
#
#OUTPT WDATE |n WDATE |r Yes |s/WDATE
#OUTPT WPLOK1 |n Lookup Personal |r No |s[.userid o]
#OUTPT XGA1 |n |r No |s"<script language='"javascript'">"^L~!" var
# f=document.forms[''form''];"^L~!"f.method='"get'";"^L~!"f.action='"/scripts/EditPicInfo.pl'";"^L
# For output fields, we split on vertical bars but leave the last field as is,
# as the output specs can have basically anything in it (like embedded vertical bars)
($OFldName,$OFldLab,$OFldRep,$OFldSpecs) = split(/\|/,$FldVal,4); # max 4 fields
# Field name has no leading subfield label
$OFldName =~ s/^\s*//; # strip leading spaces
$OFldName =~ s/\s+$//; # strip trailing spaces
# The next two have leading subfield-id and spaces
foreach ($OFldLab,$OFldRep) {
$_ =~ s/^.\s*//;
$_ =~ s/\s+$//;
}
# Output specs has a leading "s", but not necessarily spaces after it
$OFldSpecs =~ s/^s\s*//;
$OFldSpecs =~ s/\s+$//;
$OFldSpecs =~ s/\~\!/ /gs; # replace "~!" by single space ?? (or should we by CR/LF ?)
$FieldData = {
'Name' => $OFldName, # Output field name
'Label' => $OFldLab, # Label/description
'Repeat' => $OFldRep, # Repeat factor
'Specs' => $OFldSpecs, # Specifications
};
log_msg(" storing description data for output field \"$OFldName\"") if $Debug >1;
push(@$OutFieldsTblA,$OFldName); # store name in array (to keep order of fields)
$OutFieldsTblH->{$OFldName} = $FieldData; # but data in hash (for easier access)
} # end OUTPT block
DATAF: {
last DATAF unless ($FldName eq "DATAF");
# process input field description
# ignore if it doesn' have a field name first (DBDEF1 comment line)
next LINES unless ($FldVal =~ /^(\w+)\s*\|n/);
# skip if we find no field name (like " |n 0 ")
next LINES if ($FldVal =~ /^\s*\|/);
# For input fields, we can split on vertical bars
($InFldName,$InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid) = split(/\|/,$FldVal);
$InFldValid = "" unless $InFldValid; # may not have been there
# Field name has no leading subfield label
$InFldName =~ s/^\s*//; # strip leading spaces
$InFldName =~ s/\s+$//; # strip trailing spaces
# The others have leading subfield-id and spaces
foreach ($InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid) {
$_ =~ s/^.\s*//;
$_ =~ s/\s+$//;
}
# Input field table structure :
# Note : should become an object some day
$FieldData = {
'Name' => $InFldName, # internal Star field name
'Index' => $InFldIdx, # internal field number
'Comment' => $InFldCom, # field comment (DBDEF1)
'Label' => $InFldLab, # label for data entry (DBDEF2)
'clear' => 0, # wether field contents should be pre-cleared
'long' => 0, # is field is long text ?
'Type' => $InFldDType, # data type for data entry (2)
'InLen' => $InFldDchar, # max line length for data entry (3)
'MO' => $InFldVocc eq "No" ? 0 : 1, # wether field is multiple occ. (1)
'ML' => $InFldVlines eq "No" ? 0 : 1, # wether to allow multiple lines (3)
'HID' => 0, # hidden (5)
'PRO' => 0, # protected, read-only (5)
'DATE' => 0, # date field + format (5)(6)
'NUM' => 0, # numeric
'IDX' => 0, # is it indexed ?
'UNIQ' => 0, # does it have a "unique" indexing rule ?
'WF' => WF_NONE, # bitmap field (10)
'Valid' => $InFldValid, # validation rule if any
'OccLen' => OCCLEN, # maximum occurrence length (4)
'Subs' => undef, # false, or ref. to array of subfield descriptions (9)
'EOccs' => 0, # nb. of extra blank occs to display (8)
'occs' => undef, # ref to array of occurrence values
};
# Note : try to set some of the above values depending on collected data
# Note : some of these are approximations
$FieldData->{long} = 1 if $InFldDType =~ /^Long text/i;
$FieldData->{HID} = 1 if $InFldName =~ /^ZZ/i;
$FieldData->{PRO} = 1 if $InFldDType =~ /^Protected/i;
$FieldData->{DATE} = 1 if ($InFldValid && ($InFldValid =~ /^Date /i));
log_msg(" storing description data for input field \"$InFldName\"") if $Debug >1;
push(@$InFieldsTblA,$InFldName); # store name in array (to keep order of fields)
$InFieldsTblH->{$InFldName} = $FieldData; # but data in hash (for easier access)
next LINES;
} # end DATAF block
VALID: {
# Note : we know that in the APPSDBDEFS report, they come after the input fields
last VALID unless ($FldName eq "VALID");
# process input field validation rule
# ignore if it doesn't have the right format, like a field name first (no validation)
next unless ($FldVal =~ /^(\w+)\s*\|r\s+(.*)$/);
$InFldName = $1; # save real field name
$InFldValid = $2;
unless ($FieldData = $InFieldsTblH->{$InFldName}) {
$Msg = "getDbDefs() : Error processing validation for \"$InFldName\" : no previous hash entry !";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
log_msg(" storing validation data for field \"$InFldName\"") if $Debug >1;
# Note : analyse validation and fill-in input field table entry
$FieldData->{Valid} = $InFldValid;
next LINES;
} # end VALID block
SERCH: {
last SERCH unless ($FldName eq "SERCH");
# output example :
# <Field OutputFieldName="SERCH">OFILE |n 1 |r Fields |o |s _ |p O |f OFILE</Field>
# split on vertical bars
($SFldName,$SFldIdx,$SFldRule,$SFldOpt,$SFldSub,$SFldProx,$SFldBase) = split(/\|/,$FldVal);
# Search Field name has no leading subfield label
$SFldName =~ s/^\s*//; # strip leading spaces
$SFldName =~ s/\s+$//; # strip trailing spaces
# The others have leading subfield-id and spaces
foreach ($SFldIdx,$SFldRule,$SFldOpt,$SFldSub,$SFldProx,$SFldBase) {
$_ =~ s/^.\s*//;
$_ =~ s/\s+$//;
}
next LINES unless $SFldRule; # skip if has no rule (not indexed)
$FieldData = {
'Name' => $SFldName, # Search field name
'Index' => $SFldIdx, # internal index number
'Rule' => $SFldRule, # indexing rule (Pseudo, Fields, Words, ..)
'Opt' => $SFldOpt, # indexing options
'Sub' => $SFldSub, # subfields of base field
'Prox' => $SFldProx, # proximity operators
'Base' => $SFldBase, # Base of index value (data or search field name)
};
log_msg(" storing description data for search field \"$SFldName\"") if $Debug >1;
push(@$SearchFieldsTblA,$SFldName); # store name in array (to keep order of fields)
$SearchFieldsTblH->{$SFldName} = $FieldData; # but data in hash (for easier access)
} # end SERCH block
REPRT: {
last REPRT unless ($FldName eq "REPRT");
# output example :
#
#REPRT DEFAULT |g ONLINE |o /*INPUT
#REPRT EDITINFO |g WEBRAW |o KATLK1 GBLK1 GA* GZ* |s
#REPRT XML1 |g DUMPXMLSTAR |o LOADN/N OFILE/N IFSOB/N MVER1/N MVER2/N
# MVER3/N MVER4/N MVER5/N MVER6/N ORES/N QUELL/N BELEG/N MQUAL/N OTYP/N OFORM/N
# OETYP/N SCOP/N SCNR/N GKOP/N TDB/N TVOL/N DATE/N BEAR/N BDATE/N RTYPE/N AN/N
# AU/N AU2/N TO/N CC/N BCC/N TI/N TIE/N DE/N SYN/N SUB/N DESC/N DESCE/N TEXT/N
# GB/N COLL/N KATEG/N TYP/N PROJ/N FORM/N SSTUF/N CUST/N OWND/N ADAT/N GRAF/N
# NR/N RIGHT/N GKOM/N MORIG/N MVID/N MA6/N MTHUM/N FDATE/N FFDAT/N VERS/N COLIT/N
# WDATE/N DDATE/N EDAT/N UDAT/N STAMP/N OFIL2/N URVAL/N FILER/N ZZ1/N ZZ2/N ZZ3/N
# ZZ4/N ZZ5/N ZZ6/N ZZ7/N ZZ8/N ZZ9/N ZZ10/N ZZ11/N ZZ12/N ZZ13/N ZZEXC/N ZZINI/N
# ZZREQ/N ZZFRE/N ZZFIN/N ZZFI1/N ZZGLO/N ZZGL1/N |s
#REPRT XMLOPEN |g XMLOPEN |o /*INPUT/R/N
#REPRT *ALL |g ONLINE |o LOADN OFILE IFSOB MVER1 MVER2 MVER3 MVER4
# For reports, split on vertical bars
($ORptName,$ORptPage,$ORptSpecs,$ORptSort) = split(/\|/,$FldVal,4); # max 4 fields
# Field name has no leading subfield label
$ORptName =~ s/^\s*//; # strip leading spaces
$ORptName =~ s/\s+$//; # strip trailing spaces
# Sort specs may not be there
$ORptSort = '' unless $ORptSort;
# The others have leading subfield-id and spaces
foreach ($ORptPage,$ORptSpecs,$ORptSort) {
$_ =~ s/^.\s*//;
$_ =~ s/\s+$//;
}
$FieldData = {
'Name' => $ORptName, # Report name
'PgFormat' => $ORptPage, # Page format
'Specs' => $ORptSpecs, # Output fields pecifications
'Sort' => $ORptSort, # Sort fields specifications
};
log_msg(" storing description data for report \"$ORptName\"") if $Debug >1;
push(@$ReportsTblA,$ORptName); # store name in array (to keep order)
$ReportsTblH->{$ORptName} = $FieldData; # but data in hash (for easier access)
} # end REPRT block
ADO: {
last ADO unless ($FldName eq "ADO");
# output example :
# ADO XMLTST#MISCDEVELOP##STAR |D 2004 04 19 |T 18:02:58#STAR |D 2001 08 07 |T 18:02:58 #
# seems to contain : dbname # space # view of # Update stamp # Creation stamp #
($AdoName,$AdoSpace,$AdoView,$AdoUp,$rest) = split(/\#/,$FldVal,5); # max 5 fields
foreach ($AdoName,$AdoSpace,$AdoView,$AdoUp) {
$_ =~ s/^\s+//; # strip leading/trailing spaces
$_ =~ s/\s+$//;
}
$ThisDb->{'-SpaceName'} = $AdoSpace;
$ThisDb->{'-ViewOf'} = $AdoView;
($UpUser,$UpYy,$UpMm,$UpDd,$UpH,$UpM,$UpS) =
($AdoUp =~ m/^(.*)\|D\s+(\d\d\d\d)\s(\d\d)\s(\d\d)\s*\|T\s+(\d\d):(\d\d):(\d\d)/g);
$ThisDb->{'-DbDefsUp'} = timelocal($UpS,$UpM,$UpH,$UpDd,$UpMm-1,$UpYy-1900);
} # end ADO block
# SPNAM: {
#
# last SPNAM unless ($FldName eq "SPNAM");
#
# $ThisDb->{'-SpaceName'} = $FldVal;
#
#
# } # end SPNAM block
# UP: {
#
# last UP unless ($FldName eq "UP");
#
## output example :
## UP STAR |D 2004 04 19 |T 18:02:58
#
# ($UpUser,$UpYy,$UpMm,$UpDd,$UpH,$UpM,$UpS) =
# ($FldVal =~ m/^(.*)\|D\s+(\d\d\d\d)\s(\d\d)\s(\d\d)\s*\|T\s+(\d\d):(\d\d):(\d\d)/g);
# $ThisDb->{'-DbDefsUp'} = timelocal($UpS,$UpM,$UpH,$UpDd,$UpMm,$UpYy);
#
# } # end UP block
} # end LINES foreach
# Post-processing : cross-reference some information between various tables
# Process search field table, to mark corresponding input fields as "indexed" and maybe "unique"
foreach $SFldName (@$SearchFieldsTblA) {
# log_msg(" post-processing $SFldName") if $Debug;
$FieldData = $SearchFieldsTblH->{$SFldName};
next unless ($FieldData->{Index} && $FieldData->{Rule}); # skip if not really indexed
my $tag = (split(' ',$FieldData->{Base}))[0]; # only keep first label
next unless $tag; # sanity
next unless defined( my $InData = $InFieldsTblH->{$tag} ); # skip if can' find input field
$InData->{IDX} = 1; # mark indexed anyway
my @opts = split(' ',$FieldData->{Opt}); # get Indexing Options
if (grep(/^U|I$/,@opts)) { # is there a Unique or Immediate option ?
$InData->{UNIQ} = 1; # then mark field as "unique"
}
}
$ThisDb->{'-InputFieldsA'} = $InFieldsTblA;
$ThisDb->{'-InputFieldsH'} = $InFieldsTblH;
$ThisDb->{'-SearchFieldsA'} = $SearchFieldsTblA;
$ThisDb->{'-SearchFieldsH'} = $SearchFieldsTblH;
$ThisDb->{'-OutFieldsA'} = $OutFieldsTblA;
$ThisDb->{'-OutFieldsH'} = $OutFieldsTblH;
$ThisDb->{'-OutReportsA'} = $ReportsTblA;
$ThisDb->{'-OutReportsH'} = $ReportsTblH;
log_msg("<==getDbDefs(ok)") if $Debug > 1;
return 1;
}
sub getDbInputFields {
####################
my $pfx = 'getDbInputFields()';
# Get DB Input (data) fields definition data for an (open) database.
# Depends on the APPSDBDEFS db / APPMANAGE report remaining as per 3.9.8
# Gets definitions of Input fields only, and returns a ref to a hash indexed by the field name.
# and fills in the appropriate tables in the DB table.
# called as : result = srv->getDbInputFields(DbId=>$DbId);
# where :
# - srv is the StarXML connection object
# - DbId is the database-id of the db of which we want the Defs
# (the database must have been previously opened on this connection)
# returns : - hashref on success, undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
log_msg("==>$pfx($dbid)") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($FieldsDbId,$FieldsDb,$FieldsDbName,$FieldsDbPw);
my ($InFieldsTblA,$InFieldsTblH);
my ($SearchClear,$SearchNb,$SearchExpr);
my ($StarRpt,$StarRptId,$StarPage,$OutFldList,$SortFldList);
my ($RetCode,$RecCount,$ItemsCount,$LinesCount);
my ($TotItems,$FirstItem,$NumItems);
my $Records;
my ($ThisRec,$ThisFld);
my ($FldName,$FldVal);
my ($InFldName,$InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid);
my $rest;
my $FieldData;
# Retrieve the dbdefs for this database, from the FieldsDb
$FieldsDbName = $srv->{'FieldsDbName'};
$FieldsDbPw = $srv->{'FieldsDbPw'};
$FieldsDbId = $srv->{'-FieldsDbId'};
# Open the FieldsDB only if necessary
unless ($FieldsDbId && $DBs->{$FieldsDbId} && $DBs->{$FieldsDbId}->{'-Active'}) {
warn "$pfx: FieldsDb not open, opening it" if $Debug>1;
$FieldsDbId = $srv->openDB(DbName=>$FieldsDbName,Password=>$FieldsDbPw);
unless (defined($FieldsDbId)) {
# append error msg
$Msg = "$pfx: Could not open Fields database \"$FieldsDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'-FieldsDbId'} = $FieldsDbId;
}
$SearchClear = 1;
$SearchNb = "1";
$SearchExpr = "NAME=$ThisDbName";
$RecCount = $srv->singleDbSearch(DbId=>$FieldsDbId,SearchNumber=>$SearchNb,Search=>$SearchExpr);
unless (defined($RecCount)) {
# append error msg
$Msg = "$pfx: Error in search, db=\"$FieldsDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'-LastActive'} = time();
unless ($RecCount == 1) {
$Msg = "$pfx: $RecCount dbdefs record found for \"$ThisDbName\"";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$StarRpt = "APPMANAGE";
$StarPage = "STARXML";
$OutFldList = [qw(DATAF/N VALID/N)];
$SortFldList = [];
$StarRptId= _XML_id($srv,"RPT"); # unique report-id
$RetCode = $srv->singleDbReport(DbId=>$FieldsDbId,RptId=>$StarRptId
,Report=>$StarRpt,Page=>$StarPage,Search=>"S1"
,OutFields=>$OutFldList,SortFields=>$SortFldList);
unless (defined($RetCode)) {
$Msg = "$pfx: Report \"$StarRpt\" could not be generated";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
($ItemsCount,$LinesCount) = split(",",$RetCode);
# Note : this should get us exactly 1 item
log_msg("$pfx: Report generated, $ItemsCount items, $LinesCount lines.") if $Debug>1;
if ($ItemsCount != 1) {
$Msg = "$pfx: Report \"$StarRpt\" has more than 1 item";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$TotItems = "1";
$FirstItem = "0";
$NumItems = 1;
unless (defined($Records = $srv->getReportRecords(RptId=>$StarRptId,FirstItem=>$FirstItem,Items=>$NumItems))) {
$Msg = "** Could not retrieve records, error : \"";
$Msg = "$pfx: Could not retrieve records";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'-LastActive'} = time();
# output example :
# <Field OutputFieldName="DATAF">RTYPE |n 37 |c Record
# type (SINGle / MULTiple) |2 Record type |3 1 |4 No
# |5 No |6 15 |7 1 |8 No |9 Uppercase |v RTYPE</Field>
# <Field OutputFieldName="DATAF">AN |n 35 |c Accession
# Number |2 Accession # |3 1 |4 No |5 No |6 15 |7 1 |8
# No |9 Coded</Field>
# <Field OutputFieldName="VALID">RTYPE |r Values s*=SINGLE;c*=COLLECTION</Field>
# <Field OutputFieldName="VALID">|r</Field>
# Process the fields
$InFieldsTblA = [];
$InFieldsTblH = {};
$ThisRec = $Records->[0];
LINES: foreach $ThisFld (@{$ThisRec->{'Field'}}) {
$FldName = $ThisFld->{'OutputFieldName'};
# the following fields are normally absent from XMLOPEN records, but just in case
next LINES if ($FldName =~ /^(Sort|Next|Prev)/);
$FldVal = $ThisFld->{'$TEXT$'};
$FldVal = "" unless defined $FldVal;
$FldVal =~ s/(\x0D)?\x0A\s{19}//gs; # eliminate indentation
log_msg("$pfx: processing ($FldName) line : $FldVal") if $Debug >1;
# Process line types, most frequent ones first
DATAF: {
last DATAF unless ($FldName eq "DATAF");
# process input field description
# ignore if it doesn' have a field name first (DBDEF1 comment line)
next LINES unless ($FldVal =~ /^(\w+)\s*\|n/);
# skip if we find no field name (like " |n 0 ")
next LINES if ($FldVal =~ /^\s*\|/);
# For input fields, we can split on vertical bars
($InFldName,$InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid) = split(/\|/,$FldVal);
$InFldValid = "" unless $InFldValid; # may not have been there
# Field name has no leading subfield label
$InFldName =~ s/^\s*//; # strip leading spaces
$InFldName =~ s/\s+$//; # strip trailing spaces
# The others have leading subfield-id and spaces
foreach ($InFldIdx,$InFldCom,$InFldLab,$InFldDocc,$InFldVocc,$InFldBocc,
$InFldDchar,$InFldDlines,$InFldVlines,$InFldDType,$InFldValid) {
$_ =~ s/^.\s*//;
$_ =~ s/\s+$//;
}
# Input field table structure :
# Note : should become an object some day
$FieldData = {
'Name' => $InFldName, # internal Star field name
'Index' => $InFldIdx, # internal field number
'Comment' => $InFldCom, # field comment (DBDEF1)
'Label' => $InFldLab, # label for data entry (DBDEF2)
'clear' => 0, # wether field contents should be pre-cleared
'long' => 0, # is field is long text ?
'Type' => $InFldDType, # data type for data entry (2)
'InLen' => $InFldDchar, # max line length for data entry (3)
'MO' => $InFldVocc eq "No" ? 0 : 1, # wether field is multiple occ. (1)
'ML' => $InFldVlines eq "No" ? 0 : 1, # wether to allow multiple lines (3)
'HID' => 0, # hidden (5)
'PRO' => 0, # protected, read-only (5)
'DATE' => 0, # date field + format (5)(6)
'NUM' => 0, # numeric
'IDX' => 0, # is it indexed ?
'UNIQ' => 0, # does it have a "unique" indexing rule ?
'WF' => WF_NONE, # bitmap field (10)
'Valid' => $InFldValid, # validation rule if any
'OccLen' => OCCLEN, # maximum occurrence length (4)
'Subs' => undef, # false, or ref. to array of subfield descriptions (9)
'EOccs' => 0, # nb. of extra blank occs to display (8)
'occs' => undef, # ref to array of occurrence values
};
# Note : try to set some of the above values depending on collected data
# Note : some of these are approximations
$FieldData->{long} = 1 if $InFldDType =~ /^Long text/i;
$FieldData->{HID} = 1 if $InFldName =~ /^ZZ/i;
$FieldData->{PRO} = 1 if $InFldDType =~ /^Protected/i;
$FieldData->{DATE} = 1 if ($InFldValid && ($InFldValid =~ /^Date /i));
log_msg("$pfx: storing description data for input field \"$InFldName\"") if $Debug >1;
push(@$InFieldsTblA,$InFldName); # store name in array (to keep order of fields)
$InFieldsTblH->{$InFldName} = $FieldData; # but data in hash (for easier access)
next LINES;
} # end DATAF block
VALID: {
# Note : we know that in the APPSDBDEFS report, they come after the input fields
last VALID unless ($FldName eq "VALID");
# process input field validation rule
# ignore if it doesn't have the right format, like a field name first (no validation)
next unless ($FldVal =~ /^(\w+)\s*\|r\s+(.*)$/);
$InFldName = $1; # save real field name
$InFldValid = $2;
unless ($FieldData = $InFieldsTblH->{$InFldName}) {
$Msg = "$pfx: Error processing validation for \"$InFldName\" : no previous hash entry !";
$srv->_setError(ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
log_msg(" storing validation data for field \"$InFldName\"") if $Debug >1;
# Note : analyse validation and fill-in input field table entry
$FieldData->{Valid} = $InFldValid;
next LINES;
} # end VALID block
} # end LINES foreach
log_msg("<==$pfx:(ok)") if $Debug > 1;
return $InFieldsTblH;
}
#
# Searching and Retrieving data
#
sub singleDbSearch {
##################
# Perform a single search on a single database and report hit count
# called as : HitCount = srv->singleDbSearch(DbId=>$DbId,SearchNumber=>"S1",Search="Search Expr",[,Clear=>0]);
# returns : Record count on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $searchnb = $args{SearchNumber} or Carp::croak "** SearchNumber argument missing or invalid **";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $clear = exists($args{Clear}) ? $args{Clear} : 1;
log_msg("==>singleDbSearch(DbId=\"$dbid\", $searchnb=\"$search\")") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $HitCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
# Update stats
$ThisDb->{'-RequestCount'}++;
$ThisDb->{'-SearchCount'}++;
$srv->{'-RequestCount'}++;
$srv->{'-SearchCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseId'=>$dbid,
'SearchStatement'=> {
'SearchStatementNumber' => $searchnb,
'$TEXT$' => $search,
}, # /SearchStatement
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# add optional args
unless ($clear) { # Clear="True" is the default, so we need to set only if false
$XMLRequest->{'Root'}->{'Search'}->{'Clear'} = "False";
}
# get our own XML::Simple object, to specify some options
# (can we use the global one ?)
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","singleDbSearch()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# The message is in the "emsg" attribute of <Search>
$Emsg = $XMLResponse->{'Root'}->{'Search'}->{'emsg'};
$Msg = "** singleDbSearch request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
#log_msg("Search \"$searchnb\" performed.") if $Debug>1;
$HitCount = $XMLResponse->{'Root'}->{'Search'}->{'RecordCount'};
$ThisDb->{'-SearchHitCount'} += $HitCount;
$srv->{'-SearchHitCount'} += $HitCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
#log_msg("<==singleDbSearch(ok)") if $Debug > 1;
return $HitCount;
}
sub multiDbSearch {
##################
# Perform a single search on a database group and report hit count
# called as : HitCount = srv->multiDbSearch(DbId=>$DbId,SearchNumber=>"S1",Search="Search Expr",[,Clear=>0]);
# returns : Record count on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my %args = @_;
my $dbgid = $args{DbGid} or Carp::croak "** DbGid argument missing or invalid **";
my $searchnb = $args{SearchNumber} or Carp::croak "** SearchNumber argument missing or invalid **";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $clear = exists($args{Clear}) ? $args{Clear} : 1;
log_msg("==>multiDbSearch(DbGid=\"$dbgid\", $searchnb=\"$search\")") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
#my $ThisDb = $DBs->{$dbgid} or Carp::croak "** Invalid database-id : $dbgid **";
#my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $HitCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
# Update stats
#$ThisDb->{'-RequestCount'}++;
#$ThisDb->{'-SearchCount'}++;
$srv->{'-RequestCount'}++;
$srv->{'-SearchCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseGroupId'=>$dbgid,
'SearchStatement'=> {
'SearchStatementNumber' => $searchnb,
'$TEXT$' => $search,
}, # /SearchStatement
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# add optional args
unless ($clear) { # Clear="True" is the default, so we need to set only if false
$XMLRequest->{'Root'}->{'Search'}->{'Clear'} = "False";
}
# get our own XML::Simple object, to specify some options
# (can we use the global one ?)
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","multiDbSearch()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# The message is in the "emsg" attribute of <Search>
$Emsg = $XMLResponse->{'Root'}->{'Search'}->{'emsg'};
$Msg = "** multiDbSearch request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
#log_msg("Search \"$searchnb\" performed.") if $Debug>1;
$HitCount = $XMLResponse->{'Root'}->{'Search'}->{'RecordCount'};
#$ThisDb->{'-SearchHitCount'} += $HitCount;
$srv->{'-SearchHitCount'} += $HitCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
#log_msg("<==singleDbSearch(ok)") if $Debug > 1;
return $HitCount;
}
sub singleDbMultiSearch {
##################
# Perform a single search on a single database and report hit count
# called as : HitCount = srv->singleDbSearch(DbId=>$DbId,SearchNumber=>"S1",Search="Search Expr",[,Clear=>0]);
# returns : Record count on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $clear = exists($args{Clear}) ? $args{Clear} : 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $HitCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
# Update stats
$ThisDb->{'-RequestCount'}++;
$ThisDb->{'-SearchCount'}++;
$srv->{'-RequestCount'}++;
$srv->{'-SearchCount'}++;
# Prepare the request table
# mandatory args
if(!$ThisDb->{'ServerRecordName'}) {
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseId'=>$dbid,
'SearchStatement'=> [],
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# Add search lines.
my $searchstatement = $XMLRequest->{'Root'}{'Search'}{'SearchStatement'};
for (keys %$search) {
next unless $search->{$_};
my $searchxml = {
'SearchStatementNumber' => $_,
'$TEXT$' => $search->{$_},
};
push @$searchstatement, $searchxml;
}
} else {
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseId'=>$dbid,
'SearchLine'=> [],
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# Add search lines.
my $searchline = $XMLRequest->{'Root'}{'Search'}{'SearchLine'};
for (keys %$search) {
next unless $search->{$_};
my $searchxml = {
'SearchLineNumber' => $_,
'$TEXT$' => $search->{$_},
};
push @$searchline, $searchxml;
}
}
# add optional args
unless ($clear) { # Clear="True" is the default, so we need to set only if false
$XMLRequest->{'Root'}->{'Search'}->{'Clear'} = "False";
}
# get our own XML::Simple object, to specify some options
# (can we use the global one ?)
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","singleDbSearch()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# The message is in the "emsg" attribute of <Search>
$Emsg = $XMLResponse->{'Root'}->{'Search'}->{'emsg'};
$Msg = "** singleDbSearch request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
#log_msg("Search \"$searchnb\" performed.") if $Debug>1;
$HitCount = $XMLResponse->{'Root'}->{'Search'}->{'RecordCount'};
$ThisDb->{'-SearchHitCount'} += $HitCount;
$srv->{'-SearchHitCount'} += $HitCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
#log_msg("<==singleDbSearch(ok)") if $Debug > 1;
return $HitCount;
}
sub multiDbMultiSearch {
##################
# Perform multiple searches on a database group and report hit count
# called as : HitCount = srv->multiDbMultiSearch(DbGid=>$DbGId,SearchNumber=>"S1",Search="Search Expr",[,Clear=>0]);
# returns : Record count on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my %args = @_;
my $dbgid = $args{DbGid} or Carp::croak "** DbGid argument missing or invalid **";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $clear = exists($args{Clear}) ? $args{Clear} : 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $dbids = $srv->{'-DBGroups'}->{$dbgid};
my $ThisDb = $DBs->{$dbids->[0]} or Carp::croak "**Invalid database-di **";
#my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $HitCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
# Update stats
#$ThisDb->{'-RequestCount'}++;
#$ThisDb->{'-SearchCount'}++;
$srv->{'-RequestCount'}++;
$srv->{'-SearchCount'}++;
# Prepare the request table
# mandatory args
if(!$ThisDb->{'ServerRecordName'}) {
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseGroupId'=>$dbgid,
'SearchStatement'=> [],
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# Add search lines.
my $searchstatement = $XMLRequest->{'Root'}{'Search'}{'SearchStatement'};
for (keys %$search) {
next unless $search->{$_};
my $searchxml = {
'SearchStatementNumber' => $_,
'$TEXT$' => $search->{$_},
};
push @$searchstatement, $searchxml;
}
} else {
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseGroupId'=>$dbgid,
'SearchLine'=> [],
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# Add search lines.
my $searchline = $XMLRequest->{'Root'}{'Search'}{'SearchLine'};
for (keys %$search) {
next unless $search->{$_};
my $searchxml = {
'SearchLineNumber' => $_,
'$TEXT$' => $search->{$_},
};
push @$searchline, $searchxml;
}
}
# add optional args
unless ($clear) { # Clear="True" is the default, so we need to set only if false
$XMLRequest->{'Root'}->{'Search'}->{'Clear'} = "False";
}
# get our own XML::Simple object, to specify some options
# (can we use the global one ?)
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","singleDbSearch()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# The message is in the "emsg" attribute of <Search>
$Emsg = $XMLResponse->{'Root'}->{'Search'}->{'emsg'};
$Msg = "** singleDbSearch request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
#log_msg("Search \"$searchnb\" performed.") if $Debug>1;
$HitCount = $XMLResponse->{'Root'}->{'Search'}->{'RecordCount'};
$ThisDb->{'-SearchHitCount'} += $HitCount;
$srv->{'-SearchHitCount'} += $HitCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
#log_msg("<==singleDbSearch(ok)") if $Debug > 1;
return $HitCount;
}
sub singleDbAssistedSearch {
##########################
my $pfx = 'singleDbAssistedSearch()';
# Warning : use only with Star 5.0+, and with a DB opened via openServerDB.
# Perform a search on a single database, using a SERVER record, and report hit count
# called as : HitCount = srv->singleDbAssistedSearch(DbId=>$DbId,SearchNumber=>"S1",Search="Search Expr",[,Clear=>0]);
# returns : Record count on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $clear = exists($args{Clear}) ? $args{Clear} : 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
Carp::croak "** database-id [$dbid] not open via SERVER record **" unless ($ThisDb->{'ServerRecordName'});
my $HitCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
# Update stats
$ThisDb->{'-RequestCount'}++;
$ThisDb->{'-SearchCount'}++;
$srv->{'-RequestCount'}++;
$srv->{'-SearchCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Search' =>{
'DatabaseId'=>$dbid,
'SearchLine'=> [],
'-dummy' =>{ 'x'=>'y' },
}, # /Search
'-dummy'=>"x",
}, #/Root
};
# Add search lines.
my $searchline = $XMLRequest->{'Root'}{'Search'}{'SearchLine'};
for (keys %$search) {
next unless $search->{$_};
my $searchxml = {
'SearchLineNumber' => $_,
'$TEXT$' => $search->{$_},
};
push @$searchline, $searchxml;
}
# add optional args
unless ($clear) { # Clear="True" is the default, so we need to set only if false
$XMLRequest->{'Root'}->{'Search'}->{'Clear'} = "False";
}
# get our own XML::Simple object, to specify some options
# (can we use the global one ?)
$XMLObj = new XML::Simple(
xmldecl => "<?xml version=\"1.0\" encoding=\"UTF-8\"?>",
keeproot => 1,
rootname => 'Root',
forcearray => 0,
contentkey => '$TEXT$',
);
# send the request
unless (defined($XMLResponse = XML_RequestUTF($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02",$pfx);
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# The message is in the "emsg" attribute of <Search>
$Emsg = $XMLResponse->{'Root'}->{'Search'}->{'emsg'};
$Msg = "$pfx: ** request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
#log_msg("Search \"$searchnb\" performed.") if $Debug>1;
$HitCount = $XMLResponse->{'Root'}->{'Search'}->{'RecordCount'};
$ThisDb->{'-SearchHitCount'} += $HitCount;
$srv->{'-SearchHitCount'} += $HitCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
#log_msg("<==$pfx(ok)") if $Debug > 1;
return $HitCount;
}
sub singleDbReport {
##################
# get a Star report
# called as : $RetCode = srv->singleDbReport(DbId=>$DbId,RptId=>$RptId
# ,Report=>"report name",Page=>"page format name",Search=>"search expr."
# ,OutFields=>\(output fields list),SortFields=>\(sort fields list);
# where
# returns : on success : a string composed of "record-count,line-count" (easy to split())
# on failure : undef
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $rptid = $args{RptId} or Carp::croak "** RptId argument missing or invalid **";
my $report = $args{Report} or Carp::croak "** Report name argument missing or invalid **";
my $page = $args{Page} || "STARXML";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $outfields = $args{OutFields};
# ignore output fields if not an array ref or is a ref. to empty array
if (defined($outfields)) {
unless ((ref($outfields) =~ /^ARRAY/i) && scalar(@$outfields)) {
$outfields = undef;
}
}
my $sortfields = $args{SortFields};
# ignore sort fields if not an array ref or is a ref. to empty array
if (defined($sortfields)) {
unless ((ref($sortfields) =~ /^ARRAY/i) && scalar(@$sortfields)) {
$sortfields = undef;
}
}
log_msg("==>singleDbreport()") if $Debug > 1;
log_msg(" params : DbId=\"$dbid\", RptId=\"$rptid\", Report=\"$report\"") if $Debug >1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RecCount,$LinesCount);
my ($RootEcount,$Ecount,$Emsg);
my $Options;
$ThisDb->{'-ReportCount'}++;
$srv->{'-ReportCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Report' =>{
'Id'=>$rptid,
'DatabaseId'=>$dbid,
'ReportName'=>$report,
'PageLayout'=>$page,
# 'SortKey=>"Sort",
'SearchText'=> {
'$TEXT$' => $search,
}, # /SearchText
}, # /Report
'-dummy'=>"x",
}, #/Root
};
# add optional args
if ($outfields || $sortfields) {
# If either one of those non-undef, need <FieldOptions>
$Options = {
'OutputFieldNameList' => "",
'SortList' => "",
};
if ($outfields) {
$Options->{'OutputFieldNameList'} = join(" ",@$outfields);
} else {
$Options->{'OutputFieldNameList'} = "";
}
if ($sortfields) {
$Options->{'SortList'} = join(" ",@$sortfields);
} else {
# Apparently, leaving the SortList blank results in sorting
# per descending record number. To get ascending record number,
# one should specify "R"
$Options->{'SortList'} = "";
}
$XMLRequest->{'Root'}->{'Report'}->{'FieldOptions'} = $Options;
}
# get our own XML::Simple object, to specify some options
# $XMLObj = new XML::Simple(
# xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
# keeproot => 1,
# rootname => 'Root',
# forcearray => 0,
# contentkey => '$TEXT$',
# );
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","singleDbReport()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Report>
$Emsg = $XMLResponse->{'Root'}->{'Report'}->{'emsg'};
$Msg = "** Search request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
log_msg("Report \"$rptid\" ready.") if $Debug>1;
$RecCount = $XMLResponse->{'Root'}->{'Report'}->{'RecordCount'};
$LinesCount = $XMLResponse->{'Root'}->{'Report'}->{'LineCount'};
$result = "${RecCount},${LinesCount}";
$ThisDb->{'-ReportHitCount'} += $RecCount;
$srv->{'-ReportHitCount'} += $RecCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==singleDbReport(ok)") if $Debug > 1;
return $result;
}
sub multiDbReport {
##################
# get a Star report
# called as : $RetCode = srv->multiDbReport(DbGid=>$DbGid,RptId=>$RptId
# ,Report=>"report name",Page=>"page format name",Search=>"search expr."
# ,OutFields=>\(output fields list),SortFields=>\(sort fields list);
# where
# returns : on success : a string composed of "record-count,line-count" (easy to split())
# on failure : undef
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbgid = $args{DbGid} or Carp::croak "** DbGid argument missing or invalid **";
my $rptid = $args{RptId} or Carp::croak "** RptId argument missing or invalid **";
my $report = $args{Report} or Carp::croak "** Report name argument missing or invalid **";
my $page = $args{Page} || "STARXML";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $outfields = $args{OutFields};
# ignore output fields if not an array ref or is a ref. to empty array
if (defined($outfields)) {
unless ((ref($outfields) =~ /^ARRAY/i) && scalar(@$outfields)) {
$outfields = undef;
}
}
my $sortfields = $args{SortFields};
# ignore sort fields if not an array ref or is a ref. to empty array
if (defined($sortfields)) {
unless ((ref($sortfields) =~ /^ARRAY/i) && scalar(@$sortfields)) {
$sortfields = undef;
}
}
log_msg("==>multiDbReport()") if $Debug > 1;
log_msg(" params : DbGid=\"$dbgid\", RptId=\"$rptid\", Report=\"$report\"") if $Debug >1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
#my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
#my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RecCount,$LinesCount);
my ($RootEcount,$Ecount,$Emsg);
my $Options;
#$ThisDb->{'-ReportCount'}++;
$srv->{'-ReportCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Report' =>{
'Id'=>$rptid,
'DatabaseGroupId'=>$dbgid,
'ReportName'=>$report,
'PageLayout'=>$page,
# 'SortKey=>"Sort",
'SearchText'=> {
'$TEXT$' => $search,
}, # /SearchText
}, # /Report
'-dummy'=>"x",
}, #/Root
};
# add optional args
if ($outfields || $sortfields) {
# If either one of those non-undef, need <FieldOptions>
$Options = {
'OutputFieldNameList' => "",
'SortList' => "",
};
if ($outfields) {
$Options->{'OutputFieldNameList'} = join(" ",@$outfields);
} else {
$Options->{'OutputFieldNameList'} = "";
}
if ($sortfields) {
$Options->{'SortList'} = join(" ",@$sortfields);
} else {
# Apparently, leaving the SortList blank results in sorting
# per descending record number. To get ascending record number,
# one should specify "R"
$Options->{'SortList'} = "";
}
$XMLRequest->{'Root'}->{'Report'}->{'FieldOptions'} = $Options;
}
# get our own XML::Simple object, to specify some options
# $XMLObj = new XML::Simple(
# xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
# keeproot => 1,
# rootname => 'Root',
# forcearray => 0,
# contentkey => '$TEXT$',
# );
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","multiDbReport()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Report>
$Emsg = $XMLResponse->{'Root'}->{'Report'}->{'emsg'};
$Msg = "** Search request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
log_msg("Report \"$rptid\" ready.") if $Debug>1;
$RecCount = $XMLResponse->{'Root'}->{'Report'}->{'RecordCount'};
$LinesCount = $XMLResponse->{'Root'}->{'Report'}->{'LineCount'};
$result = "${RecCount},${LinesCount}";
#$ThisDb->{'-ReportHitCount'} += $RecCount;
$srv->{'-ReportHitCount'} += $RecCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==multiDbReport(ok)") if $Debug > 1;
return $result;
}
sub singleDbReportUTF {
#####################
my $pfx = 'singleDbReportUTF()';
# Warning : use only with Star 5.0+
# get a Star report
# called as : $RetCode = srv->singleDbReportUTF(DbId=>$DbId,RptId=>$RptId
# ,Report=>"report name",Page=>"page format name",Search=>"search expr."
# ,OutFields=>\(output fields list),SortFields=>\(sort fields list);
# where
# returns : on success : a string composed of "record-count,line-count" (easy to split())
# on failure : undef
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $rptid = $args{RptId} or Carp::croak "** RptId argument missing or invalid **";
my $report = $args{Report} or Carp::croak "** Report name argument missing or invalid **";
my $page = $args{Page} || "STARXML";
my $search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $outfields = $args{OutFields};
# ignore output fields if not an array ref or is a ref. to empty array
if (defined($outfields)) {
unless ((ref($outfields) =~ /^ARRAY/i) && scalar(@$outfields)) {
$outfields = undef;
}
}
my $sortfields = $args{SortFields};
# ignore sort fields if not an array ref or is a ref. to empty array
if (defined($sortfields)) {
unless ((ref($sortfields) =~ /^ARRAY/i) && scalar(@$sortfields)) {
$sortfields = undef;
}
}
log_msg("==>$pfx") if $Debug > 1;
log_msg("$pfx: params : DbId[$dbid], RptId=[$rptid], Report=[$report]") if $Debug >1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $Databases = $srv->{'-Databases'}; # ref to databases table
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RecCount,$LinesCount);
my ($RootEcount,$Ecount,$Emsg);
my $Options;
$ThisDb->{'-ReportCount'}++;
$srv->{'-ReportCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'Report' =>{
'Id'=>$rptid,
'DatabaseId'=>$dbid,
'ReportName'=>$report,
'PageLayout'=>$page,
# 'SortKey=>"Sort",
'SearchText'=> {
'$TEXT$' => $search,
}, # /SearchText
}, # /Report
'-dummy'=>"x",
}, #/Root
};
# add optional args
if ($outfields || $sortfields) {
# If either one of those non-undef, need <FieldOptions>
$Options = {
'OutputFieldNameList' => "",
'SortList' => "",
};
if ($outfields) {
$Options->{'OutputFieldNameList'} = join(" ",@$outfields);
} else {
$Options->{'OutputFieldNameList'} = "";
}
if ($sortfields) {
$Options->{'SortList'} = join(" ",@$sortfields);
} else {
# Apparently, leaving the SortList blank results in sorting
# per descending record number. To get ascending record number,
# one should specify "R"
$Options->{'SortList'} = "";
}
$XMLRequest->{'Root'}->{'Report'}->{'FieldOptions'} = $Options;
}
# get our own XML::Simple object, to specify some options
# $XMLObj = new XML::Simple(
# xmldecl => "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>",
# keeproot => 1,
# rootname => 'Root',
# forcearray => 0,
# contentkey => '$TEXT$',
# );
# send the request
unless (defined($XMLResponse = XML_RequestUTF($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","singleDbReport()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Report>
$Emsg = $XMLResponse->{'Root'}->{'Report'}->{'emsg'};
$Msg = "$pfx: ** Search request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
log_msg("$pfx: Report \"$rptid\" ready.") if $Debug>1;
$RecCount = $XMLResponse->{'Root'}->{'Report'}->{'RecordCount'};
$LinesCount = $XMLResponse->{'Root'}->{'Report'}->{'LineCount'};
$result = "${RecCount},${LinesCount}";
$ThisDb->{'-ReportHitCount'} += $RecCount;
$srv->{'-ReportHitCount'} += $RecCount;
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==$pfx(ok)") if $Debug > 1;
return $result;
}
# Note AW 2015/05/05 :
# There is another optimisation potential in the following sub getRecordsList :
# If all we want is the record numbers, then we should take into account that
# StarXML always returns the Star record number in a report (see the STARXML Page Format).
# By giving only a "dummy" output field as parameter, Star does not retrieve or return the
# content of any db output field (which probably already saves time), but in addition we
# do not have to parse the resulting records output fields, we can just collect the
# "RecordNumber" key of the record hash, which contains the Star record number, and then
# skip the rest of the record.
sub getRecordsList {
####################
# Get a list of records from a database. This method will perform
# multiple searches and extract the record fields from the reports.
# The list of the collected reports will be returned.
# called as : my $records = $srv->getRecordsList(
# DbId => $dbId,
# Searches => \@searches
# ) or die $srv->{'-ErrMsg'};
# parameter : Searches : An array of searches to perform to collect the
# records. If a record was already hit by a
# previous result, then it will not be added a
# second time to the list.
# OutFields : An array of output fields to get for each
# record.
# returns : on success : a ref to an array of hashes, with each
# hash = 1 record.
# Each hash has the key recn. This holds the
# record number.
# Each hash has also the output fields as keys.
# Each of them contains an array with the
# occurrences.
# on failure : undef (and error msg in $srv->{'-ErrMsg'})
#
# diagnostics
#
# Missing parameter [%s].
# A parameter was missing during the method call. Check your code.
#
# Bad data in parameter [%s].
# A parameters value has some unexpected content. Check your code.
my $self = shift;
my %args = @_;
my @records;
# Clear previous errors.
$self->_clearError();
# Check required parameters.
for my $arg (
{name => 'Searches', type => 'ARRAY'},
{name => 'DbId', type => ''}
) {
unless (defined $args{$arg->{'name'}}) {
$self->{'-ErrMsg'} = "Missing parameter [$arg->{'name'}].";
return;
}
if (
ref $args{$arg->{'name'}} ne $arg->{'type'} ||
$args{$arg->{'name'}} eq ''
) {
$self->{'-ErrMsg'} = "Bad data in parameter " .
"[$arg->{'name'}].";
return;
}
}
# Check optional parameters.
for my $arg (
{name => 'OutFields', type => 'ARRAY'}
) {
if (defined $args{$arg->{'name'}}) {
if (
ref $args{$arg->{'name'}} ne $arg->{'type'} ||
$args{$arg->{'name'}} eq ''
) {
$self->{'-ErrMsg'} = "Bad data in parameter " .
"[$arg->{'name'}].";
return;
}
}
}
# Do each search and collect the records.
# Optimization potential by performing up to 32 searches at
# once.
for my $i (0 .. scalar @{$args{'Searches'}} - 1) {
my ($hits, $repId, $repRes);
# Do the search.
$hits = $self->singleDbSearch(
'DbId' => $args{'DbId'},
'SearchNumber' => 1,
'Search' => $args{'Searches'}[$i]
);
unless (defined $hits) {
return;
}
unless ($hits) {
next;
}
# Generate report.
$repId = _XML_id($self,"RCL$i");
$self->singleDbReport(
'DbId' => $args{'DbId'},
'RptId' => $repId,
'Report' => '*DUMP',
'Page' => 'STARXML',
'Search' => $args{'Searches'}[$i],
'OutFields' => $args{'OutFields'} || []
) or return;
# Get report content.
$repRes = $self->getReportRecords(
'RptId' => $repId,
'FirstItem' => 0,
'Items' => 0
) or return;
# Add new records to the result list.
REPREC: for my $repRec (@$repRes) {
my %record = (recn => $repRec->{'RecordNumber'});
# Next if record already exists.
for my $rec (@records) {
if ($rec->{'recn'} == $record{'recn'}) {
next REPREC;
}
}
# Add fields to record from report.
for my $repFl (@{$repRec->{'Field'}}) {
push @{$record{$repFl->{'OutputFieldName'}}},
$repFl->{'$TEXT$'}
}
# Add record to result list.
push @records, \%record;
}
}
# Return result.
return \@records;
}
sub getReportRecords {
####################
# Get records from a previously executed <Report>
# called as : $Records = $srv->getReportRecords(RptId=>$StarRptId,FirstItem=>$FirstItem,Items=>$NumItems);
# returns : on success : a ref to an array of hashes, with each hash = 1 record
# on failure : undef (and error msg in $Server)
#
# Note 1 : "$FirstItem" is the number of the item at which to start the output.
# This number starts at 0, not 1.
# Note 2 : "$NumItems" is the maximum number of items to retrieve this time (segmented report).
# It is an optional parameter for Star XML, so that omitting it will use "1" as default.
# A kludge is built-in to this routine, such that a value of "" (empty), "0" (zero),
# or "99999999" all mean the same and result in the parameter being "99999999" in the
# XML <GetRecords> request.
#
# Note 3 : because a report can span several databases, each returned record contains a "database-id".
# To update the statistics, we're thus having to do some analysis right here.
# Because this may be time-consuming, it can be turned off by setting the parameter
# 'DoStats' to false in the connection table.
#
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my $Params = { @_ };
my $rptid = $Params->{RptId} or Carp::croak "** RptId argument missing or invalid **";
my $firstrec = $Params->{FirstItem} || 0;
my $maxrecs = $Params->{Items} || 99999999;
log_msg("==>getReportRecords()") if $Debug > 1;
log_msg(" params : ReportId=\"$rptid\", firstitem=$firstrec, numitems=$maxrecs") if $Debug >1;
my $OutRecords; # return value
my $Conns = $srv->{'-Connections'}; # ref to connections table
my $DBs = $srv->{'-DBs'}; # ref to general db table
my ($ThisConId,$ThisCon);
my ($ThisDbId,$ThisDb);
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
my $InRecords;
my $Rec;
my $DbStats;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'GetRecords' =>{
'ReportId'=>$rptid,
'FirstRecord'=>$firstrec,
}, # /GetRecords
'-dummy'=>"x",
}, #/Root
};
# add optional args
$XMLRequest->{'Root'}->{'GetRecords'}->{'RecordCount'} = $maxrecs;
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getReportRecords()");
return undef;
}
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = $XMLResponse->{'Root'}->{'GetRecords'}->{'emsg'};
$Msg = "** GetRecords request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
log_msg("getReportRecords() : $Msg") if $Debug > 1;
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("Records retrieved, starting analysis/conversion.") if $Debug>1;
# Expected response :
# 'Root' => {
# 'GetRecords' => {
# 'FirstRecord' => "0",
# 'RecordCount' => "9999",
# 'ReportId' => "xyz",
# 'Response' => {
# 'Record' => [
# [0] => {
# 'DatabaseId' => "xyz",
# 'RecordNumber' => "rec",
# 'Field' => [
# [0] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ
# [1] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ or field
# ......
# [n] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ
#
# ], #/Field
# }, #/rec 0 hash
# ], #/item 0 of 'Record'
#
# [1] => {
# 'DatabaseId' => "xyz",
# 'RecordNumber' => "rec",
# 'Field' => [
# [0] => {
# 'OutputFieldName' => "name",
# '$TEXT$ = "text",
# }, #/occ
# ......
# ], #/Field
# }, #/rec 0 hash
# ], #/item 1 of 'Record'
# ......
# [n] => {
# ....
# }, #/item n of 'Record'
# }, #/Response
# }, #/GetRecords
# } #/Root
#
# We cannot transform the data very much, because we don't know what the caller
# wants to do with it. We must leave the records as an array, and the fields/occurrences as
# an array, to preserve the ordering.
# So we just simplify the structure.
# Also, we don't "forcearray" in XMLin(). This means that if there is
# only 1 record, XMLin() returns 'Record' as a ref. to a hash of a single record's data,
# instead of an array of records. (On the other hand, if we "forcearray", then everything
# comes back as an array (Root, GetRecords, Response, ...) even though there's only one
# each of those.)
# We test on the type of reference returned, and make sure that
# what we return is always a ref. to an array of records (maybe with a single element).
$InRecords = $XMLResponse->{'Root'}->{'GetRecords'}->{'Response'}->{'Record'}; # ref to record array/hash
unless (defined $InRecords) {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = 'Root->GetRecords->Response->Record is undefined';
$Msg = "** GetRecords request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
log_msg("getReportRecords() : $Msg") if $Debug > 1;
return undef;
}
if (ref($InRecords) =~ /^HASH/) {
$OutRecords = [ $InRecords ]; # if a single hash, force into an array ref
} else {
$OutRecords = $InRecords; # leave alone if already an array ref
}
# If we need to do stats, we have to go through the structure for the
# "record" items, and pick up the DatabaseId's (there could be more than one),
# and from there the corresponding connection id's, to update the statistics.
# This is "expensive", so we try to optimise by building a cache of db's who
# need it and others who don't.
if ($GenDoStats) { # if at least one connection wants stats
$DbStats = {}; # init cache
foreach $Rec (@$OutRecords) {
$ThisDbId = $Rec->{'DatabaseId'};
# The following is safe, because to get a report from a database, it must
# have been opened before.
$ThisDb = $DBs->{$ThisDbId};
unless (exists($DbStats->{ThisDbId})) {
# if the cache entry doesn't exist yet, create it
if ($srv->{DoStats}) { # does the connection want stats ?
$DbStats->{$ThisDbId} = 1; # "do stats for this db"
} else {
$DbStats->{$ThisDbId} = 0; # means "don't"
}
}
# here the entry always exists
if ($DbStats->{$ThisDbId}) {
# if "true", we want stats
$ThisDb->{'-ReportItemsCount'}++; # count 1 item for db
$srv->{'-ReportItemsCount'}++; # count 1 item for connection
}
} # end foreach $Rec
} # endif GenDoStats
log_msg("<==getReportRecords(ok)") if $Debug > 1;
return $OutRecords;
}
sub getReportRecordsSAPI {
#########################
# Created for SAPI
# Get records from a previously executed <Report>
# called as : $Records = $srv->getReportRecords(RptId=>$StarRptId,FirstItem=>$FirstItem,Items=>$NumItems);
# returns : on success : a ref to an array of hashes, with each hash = 1 record
# on failure : undef (and error msg in $Server)
#
# Note 1 : "$FirstItem" is the number of the item at which to start the output.
# This number starts at 0, not 1.
# Note 2 : "$NumItems" is the maximum number of items to retrieve this time (segmented report).
# It is an optional parameter for Star XML, so that omitting it will use "1" as default.
# A kludge is built-in to this routine, such that a value of "" (empty), "0" (zero),
# or "99999999" all mean the same and result in the parameter being "99999999" in the
# XML <GetRecords> request.
#
# Note 3 : because a report can span several databases, each returned record contains a "database-id".
# To update the statistics, we're thus having to do some analysis right here.
# Because this may be time-consuming, it can be turned off by setting the parameter
# 'DoStats' to false in the connection table.
#
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my $Params = { @_ };
my $rptid = $Params->{RptId} or Carp::croak "** RptId argument missing or invalid **";
my $firstrec = $Params->{FirstItem} || 0;
my $maxrecs = $Params->{Items} || 99999999;
log_msg("==>getReportRecordsSAPI()") if $Debug > 1;
log_msg(" params : ReportId=\"$rptid\", firstitem=$firstrec, numitems=$maxrecs") if $Debug >1;
my $OutRecords; # return value
my $Conns = $srv->{'-Connections'}; # ref to connections table
my $DBs = $srv->{'-DBs'}; # ref to general db table
my ($ThisConId,$ThisCon);
my ($ThisDbId,$ThisDb);
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
my $InRecords;
my $Rec;
my $DbStats;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'GetRecords' =>{
'ReportId'=>$rptid,
'FirstRecord'=>$firstrec,
}, # /GetRecords
'-dummy'=>"x",
}, #/Root
};
# add optional args
$XMLRequest->{'Root'}->{'GetRecords'}->{'RecordCount'} = $maxrecs;
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getReportRecords()");
return undef;
}
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = $XMLResponse->{'Root'}->{'GetRecords'}->{'emsg'};
$Msg = "** GetRecords request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("Records retrieved, starting analysis/conversion.") if $Debug>1;
$InRecords = $XMLResponse->{'Root'}->{'GetRecords'}->{'Response'}->{'Record'}; # ref to record array/hash
# Force ref. to an array of records (maybe with a single element).
if (ref($InRecords) =~ /^HASH/) {
$OutRecords = [ $InRecords ]; # if a single hash, force into an array ref
} else {
$OutRecords = $InRecords; # leave alone if already an array ref
}
# If we need to do stats, we have to go through the structure for the
# "record" items, and pick up the DatabaseId's (there could be more than one),
# and from there the corresponding connection id's, to update the statistics.
# This is "expensive", so we try to optimise by building a cache of db's who
# need it and others who don't.
if ($GenDoStats) { # if at least one connection wants stats
$DbStats = {}; # init cache
foreach $Rec (@$OutRecords) {
$ThisDbId = $Rec->{'DatabaseId'};
# The following is safe, because to get a report from a database, it must
# have been opened before.
$ThisDb = $DBs->{$ThisDbId};
unless (exists($DbStats->{ThisDbId})) {
# if the cache entry doesn't exist yet, create it
if ($srv->{DoStats}) { # does the connection want stats ?
$DbStats->{$ThisDbId} = 1; # "do stats for this db"
} else {
$DbStats->{$ThisDbId} = 0; # means "don't"
}
}
# here the entry always exists
if ($DbStats->{$ThisDbId}) {
# if "true", we want stats
$ThisDb->{'-ReportItemsCount'}++; # count 1 item for db
$srv->{'-ReportItemsCount'}++; # count 1 item for connection
}
} # end foreach $Rec
} # endif GenDoStats
# Build a special response for SAPI
# We don't care about the order of the fields in a record,
# but we want to preserve the order of the records (in case they are sorted),
# and the order of occurrences in each field (ditto).
# In addition, we want the fields to be a hash (key = field name),
# and the occurrences to be an array of values therein.
my $FinalRecords = [];
foreach $Rec (@$OutRecords) {
my $fRecFields = {};
foreach my $f (@{$Rec->{Field}}) {
my $fName = $f->{'OutputFieldName'};
if (exists($fRecFields->{$fName})) {
push(@{$fRecFields->{$fName}},$f->{'$TEXT$'});
} else {
$fRecFields->{$fName} = [ $f->{'$TEXT$'} ];
}
}
my $fRec = {
'RecordNumber' => $Rec->{'RecordNumber'},
'Fields' => $fRecFields,
};
push(@$FinalRecords,$fRec);
}
log_msg("<==getReportRecordsSAPI(ok)") if $Debug > 1;
return $FinalRecords;
}
sub getSingleDbIndex {
####################
# Implements the ShowIndex function, for a single DB index
# called as : $IndexTerms = $srv->getSingleDbIndex(DbId=>$StarDbId,Items=>$NumItems,FirstItem=>$FirstItem
# ,Case=>$Case,Direction=>$Direction,Prefix=>$Prefix,Search=>$Search,Limit=>$Limit);
# returns : on success : a ref to an array of arrays, with each array element containing
# the following items : [hitcount,index field name,index term]
# on failure : undef (and error msg in $Server)
#
# args :
# $Search is the term at which to start the index retrieval (usually "A"). It can also contain
# wilcards, in which case only those terms that match the wildcard will be returned.
# $Prefix can be a list of fields to which to limit the index retrieval, like "/AU,TI".
# $Limit can be a search expression, to limit the terms retrieved to those appearing in records
# matching the expression.
#
# examples :
# - $Search='A' : start the index retrieval at term "A"
# - $Search='AB*' : retrieve only the terms terms matching "AB*"
# - $Limit="DPT=SALES" : only retrieve terms from records where DPT=SALES.
# - $Prefix="/AU,TI" : only retrieve index terms from the AU and TI index fields.
#
# $NumItems is the maximum number of items to retrieve this time (segmented report).
# It is an optional parameter for Star XML, so that omitting it yields "no limit".
# A kludge is built-in to this routine, such that a value of "" (empty), "0" (zero),
# or "99999999" all mean the same and result in the parameter being omitted in the
# XML <GetRecords> request.
#
# $FirstItem" is the number of the item at which to start the output, default 0 (starts at 0, not 1)
# This not a standard Star XML parameter. If used this sub will get the index terms according
# to the other arguments, but then "skip" FirstItem-1 terms and only return the rest to the caller.
#
# Note : 2005/08/03
# The "searchterm" creates problems if it happens to contain a search expression (like "A AND B"), if this
# search expression turns out to be invalid (like "A AND"). Somehow it seems that Star is "doing something"
# if it recogmises a search expression or part of it, although what it does is not clear.
# To avoid the problem, we unilaterally decide to quote anything "funny" in the expression, and quote
# the whole string also (this still allows * and ? to go through).
#
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my $Params = { @_ };
my $ThisDbId = $Params->{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $firstitem = $Params->{FirstItem} || 0;
my $maxitems = $Params->{Items} || 99999999;
my $case = $Params->{Case} || 'upper';
my $direction = $Params->{Direction} || 'Ascending';
my $prefix = $Params->{Prefix} || '';
my $search = $Params->{Search} || 'A';
my $limit = $Params->{Limit} || '';
log_msg("==>getSingleDbIndex()") if $Debug > 1;
log_msg(" params : DbId=\"$ThisDbId\", search=\"$search\", prefix=\"$prefix\", limit=\"$limit\", firstitem=\"$firstitem\", numitems=\"$maxitems\"") if $Debug >1;
my $InTerms; # as returned from ShowIndex
my $OutTerms; # return value
my $Conns = $srv->{'-Connections'}; # ref to connections table
my $DBs = $srv->{'-DBs'}; # ref to general db table
my ($ThisConId,$ThisCon);
my ($ThisDb);
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
my ($Count,$Fld,$Term);
my $Rec;
my $DbStats;
$search =~ s/('|")/'$1/g; # quote the quotes
# Prepare the request table
# mandatory args
$maxitems = "99999999" unless $maxitems;
$XMLRequest = {
'Root' =>{
'ShowIndex' =>{
'DatabaseId'=>$ThisDbId,
'Direction'=>$direction,
'Case'=>$case,
'LineCount'=>$maxitems,
'SearchText'=>{
# '$TEXT$' => $search, # modif 2005/08/03
'$TEXT$' => "\"$search\"",
}, # /SearchText
'-dummy' =>{ 'x'=>'y' }, # force SearchText to be it's own element
}, # /ShowIndex
'-dummy'=>"x",
}, #/Root
};
# add optional args
if ($prefix) {
$XMLRequest->{'Root'}->{'ShowIndex'}->{'SearchPrefix'} = $prefix;
}
# new syntax for Star XML 4.4.2
if ($limit) {
$XMLRequest->{'Root'}->{'ShowIndex'}->{'IndexLimitSearch'} = $limit;
}
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getSingleDbIndex()");
return undef;
}
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = $XMLResponse->{'Root'}->{'ShowIndex'}->{'emsg'};
$Msg = "** ShowIndex request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("Index terms retrieved, starting analysis/conversion.") if $Debug>1;
# Expected response :
# 'Root' => {
# 'ShowIndex' => {
# 'DatabaseId' => "0",
# 'LineCount' => "9999",
# 'Direction' => "dir",
# 'Case' => "case",
# 'SearchText' => 'expr',
# 'Response' => {
# 'Term' => [
# [0] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# [1] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# ......
# [n] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# }, #/Term
# }, #/Response
# } #/Root
#
# Note : In the following call, 'Response' can come back totally empty,
# so we force the result to be an empty array ref. in that case.
unless (defined($InTerms = $XMLResponse->{'Root'}->{'ShowIndex'}->{'Response'}->{'Term'})) {
$InTerms = [];
}
if (ref($InTerms) =~ /^HASH/) {
$InTerms = [ $InTerms ]; # if a single hash, force into an array ref
}
ITEMS: {
$OutTerms = [];
last ITEMS unless @$InTerms; # if empty, return so
my $numterms = @$InTerms;
last ITEMS if ($firstitem > $numterms-1); # also return empty array if firstitem is past end
# else build output array from selected elements of XML response
for (my $idx = $firstitem; $idx < $numterms; $idx++) {
my $elem = $InTerms->[$idx];
$Count = $elem->{Count};
$Fld = $elem->{SearchFieldName};
$Term = $elem->{'$TEXT$'};
push(@$OutTerms,[$Count,$Fld,$Term]);
}
} # end ITEMS
log_msg("<==getSingleDbIndex(ok)") if $Debug > 1;
return $OutTerms;
}
sub getSingleDbIndexOld {
#######################
# Implements the ShowIndex function, for a single DB index
# called as : $IndexTerms = $srv->getSingleDbIndex(DbId=>$StarDbId,Items=>$NumItems,FirstItem=>$FirstItem
# ,Case=>$Case,Direction=>$Direction,Prefix=>$Prefix,Search=>$Search,Limit=>$Limit);
# returns : on success : a ref to an array of arrays, with each array element containing
# the following items : [hitcount,index field name,index term]
# on failure : undef (and error msg in $Server)
#
# args :
# $Search is the term at which to start the index retrieval (usually "A"). It can also contain
# wilcards, in which case only those terms that match the wildcard will be returned.
# $Prefix can be a list of fields to which to limit the index retrieval, like "/AU,TI".
# $Limit can be a search expression, to limit the terms retrieved to those appearing in records
# matching the expression.
#
# examples :
# - $Search='A' : start the index retrieval at term "A"
# - $Search='AB*' : retrieve only the terms terms matching "AB*"
# - $Limit="DPT=SALES" : only retrieve terms from records where DPT=SALES.
# - $Prefix="/AU,TI" : only retrieve index terms from the AU and TI index fields.
#
# $NumItems is the maximum number of items to retrieve this time (segmented report).
# It is an optional parameter for Star XML, so that omitting it yields "no limit".
# A kludge is built-in to this routine, such that a value of "" (empty), "0" (zero),
# or "99999999" all mean the same and result in the parameter being omitted in the
# XML <GetRecords> request.
#
# $FirstItem" is the number of the item at which to start the output, default 0 (starts at 0, not 1)
# This not a standard Star XML parameter. If used this sub will get the index terms according
# to the other arguments, but then "skip" FirstItem-1 terms and only return the rest to the caller.
#
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $GenDoStats = $srv->{'-DoStats'};
my $Params = { @_ };
my $ThisDbId = $Params->{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $firstitem = $Params->{FirstItem} || 0;
my $maxitems = $Params->{Items} || 99999999;
my $case = $Params->{Case} || 'upper';
my $direction = $Params->{Direction} || 'Ascending';
my $prefix = $Params->{Prefix} || '';
my $search = $Params->{Search} || 'A';
my $limit = $Params->{Limit} || '';
log_msg("==>getSingleDbIndex()") if $Debug > 1;
log_msg(" params : DbId=\"$ThisDbId\", search=\"$search\", prefix=\"$prefix\", limit=\"$limit\", firstitem=\"$firstitem\", numitems=\"$maxitems\"") if $Debug >1;
my $InTerms; # as returned from ShowIndex
my $OutTerms; # return value
my $Conns = $srv->{'-Connections'}; # ref to connections table
my $DBs = $srv->{'-DBs'}; # ref to general db table
my ($ThisConId,$ThisCon);
my ($ThisDb);
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
my ($Count,$Fld,$Term);
my $Rec;
my $DbStats;
# Prepare the request table
# mandatory args
$maxitems = "99999999" unless $maxitems;
$XMLRequest = {
'Root' =>{
'ShowIndex' =>{
'DatabaseId'=>$ThisDbId,
'Direction'=>$direction,
'Case'=>$case,
'LineCount'=>$maxitems,
'SearchText'=>{
'$TEXT$' => $search,
}, # /SearchText
'-dummy' =>{ 'x'=>'y' }, # force SearchText to be it's own element
}, # /ShowIndex
'-dummy'=>"x",
}, #/Root
};
# add optional args
if ($prefix) {
$XMLRequest->{'Root'}->{'ShowIndex'}->{'SearchPrefix'} = $prefix;
}
# old syntax for Star XML 1.6.5 ?
# if ($limit) {
# $XMLRequest->{'Root'}->{'ShowIndex'}->{'SearchText'}->{'$TEXT$'} .= "!${limit}";
# }
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getSingleDbIndex()");
return undef;
}
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = $XMLResponse->{'Root'}->{'ShowIndex'}->{'emsg'};
$Msg = "** ShowIndex request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
log_msg("Index terms retrieved, starting analysis/conversion.") if $Debug>1;
# Expected response :
# 'Root' => {
# 'ShowIndex' => {
# 'DatabaseId' => "0",
# 'LineCount' => "9999",
# 'Direction' => "dir",
# 'Case' => "case",
# 'SearchText' => 'expr',
# 'Response' => {
# 'Term' => [
# [0] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# [1] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# ......
# [n] => {
# 'Count' => "999",
# 'SearchFieldName' => "AU",
# '$TEXT$' => "term",
# },
# }, #/Term
# }, #/Response
# } #/Root
#
# Note : In the following call, 'Response' can come back totally empty,
# so we force the result to be an empty array ref. in that case.
unless (defined($InTerms = $XMLResponse->{'Root'}->{'ShowIndex'}->{'Response'}->{'Term'})) {
$InTerms = [];
}
if (ref($InTerms) =~ /^HASH/) {
$InTerms = [ $InTerms ]; # if a single hash, force into an array ref
}
ITEMS: {
$OutTerms = [];
last ITEMS unless @$InTerms; # if empty, return so
my $numterms = @$InTerms;
last ITEMS if ($firstitem > $numterms-1); # also return empty array if firstitem is past end
# else build output array from selected elements of XML response
for (my $idx = $firstitem; $idx < $numterms; $idx++) {
my $elem = $InTerms->[$idx];
$Count = $elem->{Count};
$Fld = $elem->{SearchFieldName};
$Term = $elem->{'$TEXT$'};
push(@$OutTerms,[$Count,$Fld,$Term]);
}
} # end ITEMS
log_msg("<==getSingleDbIndex(ok)") if $Debug > 1;
return $OutTerms;
}
#
# Create, Update, Delete records
#
sub getRecordLocked {
###################
# Returns the data of a single record, which is also locked ready for update.
# called as : $result = $srv->getRecordLocked(DbId=>database-id,Search=>search[,Fields=>listref]);
# where :
# - "search" should be a string containing a search expression which must retrieve
# exactly one record.
# - "Fields=>listref" (optional) :
# - if the 'Fields' parameter is omitted, then all input fields will be returned
# (except 'ZZ' fields)
# - if the 'Fields' parameter is provided, with an undefined value, then no
# input field contents will be returned by the call.
# - if the 'Fields' parameter is provided, with a reference to a list of
# field labels, then only those fields listed will be returned (including
# possibly 'ZZ' fields). An empty list results in no fields at all being
# returned (similar to providing 'Fields' with an undefined value).
#
# - $result is undef in case of error, else a ref. to a structure like :
# {
# 'LockId' => lock_id or undef,
# 'LockError' => 0 or errorcode (see below),
# 'Data' => { # ('fields' structure as in Appendix A)
# 'fieldname1' => {
# 'clear' => 0/1,
# 'long' => 0/1,
# 'occs' => [ value1, value2, value3, .. ]
# },
# 'fieldname2' => {
# 'clear' => 0/1,
# 'long' => 0/1,
# 'occs' => [ value1, value2, value3, .. ]
# },
# ' ... fieldnamex ' => {
# },
# },
# };
#
# The 'LockError' code is :
# 0 = no error, record is locked & data follows
# 1 = record could not be locked (already locked)
# 2 = record does not exist
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Debug = $srv->{'-Debug'};
my %args = @_;
log_msg("==>getRecordLocked()") if $Debug > 1;
my $ThisDbId = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $Search = $args{Search} or Carp::croak "** Search argument missing or invalid **";
my $FieldsList;
# Handle this pesky Fields arg.
# Preset as if absent -> we want all normal input fields
my $wantAll = 1; # want all fields
my $wantNoZZ = 1; # want no ZZ's
my $InFldList = ["*INPUT/R/N"]; # all input fields
my $InFldStr = ""; # string joining all wanted field labels
my $InFldReg = ''; # for corresponding regexp
# If it exists however, dig some more
if (exists($args{Fields})) {
$wantAll = 0;
$InFldList = undef; # pre-set for no fields at all
# then only if 'Fields' references an non-empty array, we take the listed fields
if (defined($FieldsList = $args{Fields}) && (ref($FieldsList) =~ /^ARRAY/) && scalar(@$FieldsList)) {
$wantNoZZ = 0; # disable filtering then
@$InFldList = map("$_/R/N",@$FieldsList); # copy list over, adding modifiers for Star output specs
$InFldStr = join("|",@$FieldsList); # create string "field1|field2|field3|.." for matching later
$InFldReg = qr/^($InFldStr)$/;
}
}
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$ThisDbId} or Carp::croak "** Invalid database-id : $ThisDbId **";
my $Conns = $srv->{'-Connections'}; # ref to general connections table
my $ThisConId = $srv->{ConnectionId};
my $Msg;
my ($XMLObj,$XMLRequest,$XMLResponse);
my ($RootEcount,$Ecount,$Emsg);
my $Hits;
my ($RetCode,$ItemsCount,$LinesCount);
my ($StarRpt,$StarRptId,$StarPage,$OutFldList,$SortFldList);
my ($Records,$RecNb);
my ($RecordNumber,$Fields);
my ($ThisFld,$FldName,$FldVal);
my $LockId;
my $Result;
my ($FieldsTbl,$FldClear,$FldLong,$FldOccs);
my $InFieldsTblH = $ThisDb->{'-InputFieldsH'};
# prepare normal result structure
$FieldsTbl = {};
$Result = {
'LockId' => undef,
'LockError' => 0,
'Data' => $FieldsTbl,
};
# # Search database for a single record. Bomb out if 0 or multiple results.
# unless ($Hits = $srv->singleDbSearch(DbId=>$ThisDbId,SearchNumber=>"S1",Search=$Search) {
# # returned 0 or undef -> failed
# log_msg("** Search \"$Search\" failed ! **") if $Debug;
# return undef;
# }
# if ($Hits > 1) {
# # returned > 1 : problem also
# log_msg("** Search \"$Search\" retrieved $Hits hits ! **") if $Debug;
# $Result->{LockError} = 2;
# return $Result;
# }
#
# # Now we would get a report for "S1".
# To reduce communications overhead, we generate a report immediately,
# assuming the user knows what she's doing. In the worst case, this could result
# in generating a large report, so we'll try to filter out some possibilities.
# If it turns out this doesn't work, we'll have to revert to the above commented-out logic.
# Try to eliminate searches that would probably retrieve multiple records
if ($Search =~ /[\[\]*?:]/) { # wildcards
log_msg("** Invalid search \"$Search\" **") if $Debug;
$Result->{LockError} = 2;
return $Result;
}
$StarRptId = _XML_id($srv,'RPT'); # don' think we need Con prefix here (?)
# We use a dubious feature here : a non-existent output field.
# The reason is to shorten the report to the strict minimum, because at this stage
# we only want the Star record number back.
unless ($RetCode = $srv->singleDbReport(DbId=>$ThisDbId,RptId=>$StarRptId
,Report=>'*DUMP',Page=>'STARXML',Search=>$Search
,OutFields=>["DUMMY/R/N"])) {
$Msg = "getRecordLocked() : Report for \"$Search\" failed";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
($ItemsCount,$LinesCount) = split(/,/,$RetCode);
unless ($ItemsCount == 1) {
$Msg = "getRecordLocked() : Retrieved $ItemsCount records (should be 1)";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
# retrieve the report
unless ($Records = $srv->getReportRecords(RptId=>$StarRptId,FirstItem=>0,Items=>1)) {
$Msg = "getRecordLocked() : Retrieve of record data failed";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
# Note : $Records is a ref. to an array, even if only 1 element
$RecNb = $Records->[0]->{RecordNumber} or Carp::croak "Inconsistent data in report";
# Now we can try to lock the record
unless ($RetCode = $srv->updateRecordLock(DbId=>$ThisDbId,RecNb=>$RecNb)) {
$Msg = "getRecordLocked() : could not get update lock";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
# Even if we get a response, it may still be that the record is busy or doesn't exist
($LockId,$RecNb) = split(/,/,$RetCode);
if ($LockId =~ /^\d$/) { # a single-digit return is some error
$Result->{LockId} = undef; # mark problem
$Result->{LockError} = $LockId;
if ($LockId eq "1") {
log_msg("Record $RecNb is busy !") if $Debug>1;
return $Result;
# } elsif ($LockId eq "2") {
# log_msg("Record $RecNb des not exist !") if $Debug>1;
# return $Result;
} else {
$Msg = "getRecordLocked() : unknown status $LockId returned by updateRecordLock() for record # $RecNb";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
}
$Result->{LockId} = $LockId;
# Otherwise, we can retrieve the record data as required.
# Optimise : if we didn't want any record data, then we can just return as is.
return $Result unless $InFldList;
# Do the report again, this time with all requested fields
# Can we re-use the report-id ??
unless ($RetCode = $srv->singleDbReport(DbId=>$ThisDbId,RptId=>$StarRptId
,Report=>'*DUMP',Page=>'STARXML',Search=>"R=$RecNb"
,OutFields=>$InFldList)) {
$Msg = "** Report failed **";
$Msg = "getRecordLocked() : data report failed";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
# We do our own thing here, rather than using getReportRecords(), because we know
# there is only one record, and because we want to return a specific field structure.
# request
$XMLRequest = {
'Root' =>{
'GetRecords' =>{
'ReportId'=>$StarRptId,
'FirstRecord'=>0,
}, # /GetRecords
'-dummy'=>"x",
}, #/Root
};
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getRecordLocked()");
return undef;
}
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <GetRecords>
$Emsg = $XMLResponse->{'Root'}->{'GetRecords'}->{'emsg'};
$Msg = "** GetRecords request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("Records retrieved, starting analysis/conversion.") if $Debug>1;
# Expected response :
# 'Root' => {
# 'GetRecords' => {
# 'FirstRecord' => "0",
# 'RecordCount' => "9999",
# 'ReportId' => "xyz",
# 'Response' => {
# 'Record' => [
# [0] => {
# 'DatabaseId' => "xyz",
# 'RecordNumber' => "rec",
# 'Field' => [
# [0] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ
# [1] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ or field
# ......
# [n] => {
# 'OutputFieldName' => "name",
# '$TEXT$' => "text",
# }, #/occ
#
# ], #/Field
# }, #/rec 0 hash
# ], #/item 0 of 'Record'
#
# }, #/Response
# }, #/GetRecords
# } #/Root
#
$Records = $XMLResponse->{'Root'}->{'GetRecords'}->{'Response'}->{'Record'}; # ref to record array/hash
unless (ref($Records) =~ /^HASH/) {
$Msg = "Fishy response type from <GetRecords>";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
LINES: foreach $ThisFld (@{$Records->{'Field'}}) {
$FldName = $ThisFld->{'OutputFieldName'};
# do we want this field ?
next LINES if ($FldName =~ /^(Sort|Next|Prev)/); # eliminate Star artefact
if ($wantAll) {
# In principle, we want them all.
# But if we want no ZZ fields, and this is one, skip it
next LINES if ($wantNoZZ && ($FldName =~ /^ZZ/i));
} else {
# We only want the ones in the list
# Skip it unless label matches the compound expr. we built before
next LINES unless $FldName =~ /^($InFldStr)/i;
# more efficient like this ?
# next LINES unless $FldName =~ /$InFldReg/i;
}
# So we want it.
# Retrieve value, and add it to the fields table
$FldVal = $ThisFld->{'$TEXT$'};
$FldVal = "" unless defined $FldVal;
# $FldVal =~ s/\015\012|\012//g; # eliminate embedded CRLF's
# $FldVal =~ s/\s\s+/ /g; # eliminate duplicate consecutive spaces
# Note : shouldn't have indentation anymore since v 1.6.4
# $FldVal =~ s/(\x0D)?\x0A\s{19}//gs; # eliminate indentation
log_msg(" processing ($FldName) line : $FldVal") if $Debug >1;
# Note : $FieldsTbl is a ref. into the 'Data' sub-structure in $Result
# Create field subtable if not there yet
unless (exists($FieldsTbl->{$FldName})) {
$FieldsTbl->{$FldName} = {
'clear'=> 0,
'long' => 0,
'occs' => [],
};
}
$FldOccs = $FieldsTbl->{$FldName}->{occs}; # index occurrences array
push(@$FldOccs,$FldVal); # add value as occurrence
} # end LINES
# If we have field definitions available, pick out some additional info per field
if ($InFieldsTblH) {
foreach $FldName (keys %$FieldsTbl) {
$FieldsTbl->{$FldName}->{long} = $InFieldsTblH->{$FldName}->{long};
# and maybe other data, as needed ..
}
}
return $Result;
}
sub createRecord {
################
# Create a record for which we earlier created a lock with createRecordLock().
# called as : $RetCode = $srv->createRecord(LockId=>$LockId,Fields=>$FieldsTbl);
# returns : True on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
my $Params = { @_ };
my $lockid = $Params->{LockId} or Carp::croak "** LockId argument missing or invalid **";
my $FieldsTbl = $Params->{Fields} or Carp::croak "** Fields argument missing or invalid **";
log_msg("==>createRecord($lockid)") if $Debug > 1;
my $Locks = $srv->{'-Locks'}; # general locks table
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $Conns = $srv->{'-Connections'}; # ref to general connections table
my $ThisLock = $Locks->{$lockid} or Carp::croak "** Invalid lock-id : $lockid **";
my $ThisDbId = $ThisLock->{DbId} or Carp::croak "** Invalid DbId in lock table **";
my $ThisDb = $DBs->{$ThisDbId} or Carp::croak "** Invalid database-id in lock table : $ThisDbId **";
my $ThisDbName = $ThisDb->{DbName};
my $ThisConId = $srv->{ConnectionId};
my $LockEntry;
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($RecordClear,$FieldsClear,$IgnoreUnknown);
my $ThisFld;
my $Fields = [];
# Fields table
my ($FldName,$FldClear,$FldLong,$FldOccs);
my $FldEntry;
# Structure :
# $FieldsTbl->{
# 'fieldname1' => {
# 'clear' => 0/1,
# 'long' => 0/1,
# 'occs' => [ value1, value2, value3, .. ]
# },
# 'fieldname2' => {
# 'clear' => 0/1,
# 'long' => 0/1,
# 'occs' => [ value1, value2, value3, .. ]
# },
# ' ... '
# } /InFldTbl
my $FldHasData;
my $FldXML;
my $OccXML;
my $OccValue;
my ($Ecount,$Emsg);
unless ($ThisDb->{'-Active'}) {
$Msg = "** DbId \"$ThisDbId\" is not open ! **";
Carp::cluck $Msg;
$srv->{ComErr} = 12;
$srv->{ComMsg} = $Msg;
return undef;
}
# Should we also check that we have the right lock type ? (Star XML will do that, no ?)
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# Since this is a "record create" operation, there's no need to
# specify the "Clear" attribute in <UpdateRecord> and <Field> tags.
$RecordClear = "False"; # pre-set to false
$FieldsClear = "False"; # pre-set to false
# And we know for a fact that our fields list is correct, so set this
# one also.
$IgnoreUnknown = "False"; # pre-set to False. Bizarre but as per the Star XML Reference manual :
# ignore?
# the keyword True or the keyword False. The default is False.
# Specifies what will happen if a field name specified in the Field subelements that follow does not exist in the database.
# Specify True to generate an error message for each such field and prevent the record from being updated.
# Specify False to generate a warning message for each such field but allow the record to be updated.
# Prepare a skeleton request table
$Fields = []; # ref. to empty array
$XMLRequest = {
'Root' =>{
'UpdateRecord' =>{
'LockId'=>$lockid,
'Clear'=> $RecordClear,
'IgnoreUnknownFields' => "True",
'Field' => $Fields, # array ref., see below
# [
# {
# 'InputFieldName' => "FIELD1",
# 'Clear' => "True"/"False",
# 'Long' => "True"/"False",
# 'Occ' => [ # array ref, to array of occurrences
# value1,
# value2,
# value3,
# ],
# },
# {
# 'InputFieldName' => "FIELD2",
# 'Clear' => "True"/"False",
# 'Long' => "True"/"False",
# 'Occ' => [
# value1,
# ...,
# ],
# },
# ] /Field
}, # /UpdateRecord
'-dummy'=>"x", # not output, but forces XMLout() to consider "UpdateRecord" as content of Root, not attribute
}, #/Root
};
# Fill in the request
# Build Fields table (array)
FLD: foreach $FldName (keys(%$FieldsTbl)) {
# new logic 2006/01/31
$FldEntry = $FieldsTbl->{$FldName};
$FldOccs = $FldEntry->{'occs'};
my @occs = ();
foreach (@$FldOccs) {
next unless defined $_;
next if $_ eq ''; # skip empty occurrences
push(@occs,$_); # Add the occurrence
}
# don't create a field unless there is at least one non-empty occurrence
next FLD unless scalar(@occs);
$FldXML = { 'Occ' => [ @occs ] };
$FldXML->{'InputFieldName'} = $FldName;
$FldXML->{'Clear'} = ($FldEntry->{'clear'} ? "True" : "False");
$FldXML->{'Long'} = ($FldEntry->{'long'} ? "True" : "False");
push(@$Fields,$FldXML); # Add field to the Fields array
} # end foreach FLD
# use the standard object
$XMLObj = $srv->{'XOB'};
# send the request
# use "command" argument to indicate that we want to optimise the response processing
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj,undef,undef,'UpdateRecord'))) {
# No return hash
$Emsg = "createRecord(): no response from XMLRequest !";
log_msg(" $Emsg") if $Debug > 1;
_setError($srv,ECAT_COM,2,'',"ERRCOM_02",$Emsg);
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'Search' = {
# 'Id' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <UpdateRecord>
$Emsg = $XMLResponse->{'Root'}->{'UpdateRecord'}->{'emsg'};
# delete the general lock entry
delete($Locks->{$lockid});
if ($Emsg =~ /\[SUniqueFailed\]/i) {
# could not update record because some key is not unique
_setError($srv,ECAT_STAR,13,'',"ERRSTA_13",$Emsg);
return undef;
} else {
# other errors for now in one big pot
$Msg = "** UpdateRecord request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$srv->{'-LastActive'} = time();
$ThisDb->{'-RecordsCreatedCount'}++;
$srv->{'-RecordsCreatedCount'}++;
# delete the general lock entry
delete($Locks->{$lockid});
log_msg("<==createRecord(ok)") if $Debug > 1;
return 1;
}
sub updateRecord {
################
# Create a record for which we earlier created a lock with getRecordLocked().
# called as : $RetCode = $srv->updateRecord(LockId=>$LockId,Fields=>$FieldsTbl[,ClearRec=>0/1]);
# returns : True on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
my %args = @_;
my $LockId = $args{LockId} or Carp::croak "** LockId argument missing or invalid **";
my $FieldsTbl = $args{Fields} or Carp::croak "** Fields argument missing or invalid **";
my $RecordClear = $args{ClearRec}; # can be undef
my $IgnoreUnknown = $args{Forgive}; # can be undef
log_msg("==>updateRecord($LockId)") if $Debug > 1;
my $Locks = $srv->{'-Locks'}; # general locks table
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisLock = $Locks->{$LockId} or Carp::croak "** Invalid lock-id : $LockId **";
my $ThisDbId = $ThisLock->{DbId} or Carp::croak "** Invalid DbId in lock table **";
my $ThisDb = $DBs->{$ThisDbId} or Carp::croak "** Invalid database-id in lock table : $ThisDbId **";
my $ThisDbName = $ThisDb->{DbName};
my $LockEntry;
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
my ($Fields,$FldName,$FldEntry,$FldOccs);
my $FldXML;
# Should we check that we have the right lock type ? (Star XML will do that, no ?)
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# We know for a fact that our fields list is correct
$IgnoreUnknown = "True"; # pre-set to true
# Prepare a skeleton request table
$Fields = []; # ref. to empty array
$XMLRequest = {
'Root' =>{
'UpdateRecord' =>{
'LockId'=>$LockId,
'IgnoreUnknownFields' => "True",
'Field' => $Fields, # array ref., see below
# [
# {
# 'InputFieldName' => "FIELD1",
# 'Clear' => "True"/"False",
# 'Long' => "True"/"False",
# 'Occ' => [ # array ref, to array of occurrences
# value1,
# value2,
# value3,
# ],
# },
# {
# 'InputFieldName' => "FIELD2",
# 'Clear' => "True"/"False",
# 'Long' => "True"/"False",
# 'Occ' => [
# value1,
# ...,
# ],
# },
# ] /Field
}, # /UpdateRecord
'-dummy'=>"x", # not output, but forces XMLout() to consider "UpdateRecord" as content of Root, not attribute
}, #/Root
};
# optional :
# if ($IgnoreUnknown) {
# $XMLRequest->{Root}->{UpdateRecord}->{IgnoreUnknownFields} = "True";
# }
if ($RecordClear) {
$XMLRequest->{Root}->{UpdateRecord}->{Clear} = "True";
}
# Fill in the request
# Build Fields table (array)
FLD: foreach $FldName (keys(%$FieldsTbl)) {
# warn " X: processing field $FldName" if $Debug>2;
$FldEntry = $FieldsTbl->{$FldName};
$FldOccs = $FldEntry->{'occs'};
my @occs = ();
foreach (@$FldOccs) {
next if (($_ eq '') && (@$FldOccs > 1)); # skip empty occurrences, unless one explicitly wants to empty a field
push(@occs,$_); # Add the occurrence
}
# don't create a field unless there is at least one non-empty occurrence
next FLD unless scalar(@occs);
$FldXML = { 'Occ' => [ @occs ] };
$FldXML->{'InputFieldName'} = $FldName;
$FldXML->{'Clear'} = ($FldEntry->{'clear'} ? "True" : "False");
$FldXML->{'Long'} = ($FldEntry->{'long'} ? "True" : "False");
push(@$Fields,$FldXML); # Add field to the Fields array
} # end foreach FLD
# dump_Tbl($Fields," ++ updateRecord : fields table ") if $Debug>2;
# send the request
# Pass the special "command" parameter at end, to allow XML_request to optimise the
# processing of the response.
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'},undef,undef,'UpdateRecord'))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","updateRecord()");
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'UpdateRecord' = {
# 'LockId' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <UpdateRecord>
$Emsg = $XMLResponse->{'Root'}->{'UpdateRecord'}->{'emsg'};
if ($Emsg =~ /\[SUniqueFailed\]/i) {
# could not update record because some key is not unique
_setError($srv,ECAT_STAR,13,'',"ERRSTA_13",$Emsg);
return undef;
} else {
# other errors for now in one big pot
$Msg = "** UpdateRecord request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$srv->{'-LastActive'} = time();
$ThisDb->{'-RecordsCreatedCount'}++;
$srv->{'-RecordsCreatedCount'}++;
# delete the general lock entry
delete($Locks->{$LockId});
log_msg("<==updateRecord(ok)") if $Debug > 1;
return 1;
}
sub updateRecordForced {
######################
# *** Note *** : this function is *unsafe*
# *** Note *** : this function is *unsafe*, use beware !
# *** Note *** : this function is *unsafe*, your mileage may vary.
# This function takes a database name, a record number, and a list of fields.
# If the database has not been opened before, it is done here.
# Then the record with the given record number is locked, and updated with the contents
# of the fields given (if the ClearRec flag is true, the record is first cleared).
# this function is unsafe because there is (at the moment) no provision to check if
# the record had been locked before. If the ClearLock parameter is provided though, any
# existing record lock in our global lock table will be cleared after the update.
# called as : $RetCode = $srv->updateRecordForced(DbName=>"dbname"[,Password=>"dbpassword"],RecNb=>$RecNb
# ,Fields=>$FieldsTbl[,ClearRec=>0/1][,ClearLock=>0/1][,Forgive=>0/1]);
# returns : True on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
my %args = @_;
my $ThisDbName = $args{DbName} or Carp::croak "** Missing database name **";
my $ThisDbPw = $args{Password}; # can be empty
my $ThisRecNb = $args{RecNb} or Carp::croak "** Missing record number **";
unless ($ThisRecNb =~ m/^\d+$/) { Carp::croak "** Inavlid record number : $ThisRecNb **"; }
log_msg("==>updateRecordForced($ThisDbName,$ThisRecNb)") if $Debug > 1;
my $FieldsTbl = $args{Fields} or Carp::croak "** Fields argument missing or invalid **";
my $RecordClear = $args{ClearRec}; # can be undef
my $IgnoreUnknown = $args{Forgive}; # can be undef
my $ClearLock = $args{ClearLock}; # can be undef
my $ConId = $srv->{ConnectionId};
my $Locks = $srv->{'-Locks'}; # general locks table
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $Databases = $srv->{'-Databases'}; # database names table for this Star connection
my $ThisDbId;
my $LockId;
my $LockEntry;
my $ThisDb;
my $LockedRecNb;
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
my ($Fields,$FldName,$FldEntry,$FldOccs);
my $FldXML;
# Check the Databases table to see if this db is already opened. It is faster than
# re-opening it again.
$ThisDbId = '';
foreach (keys(%$Databases)) {
if ($Databases->{$_} eq $ThisDbName) {
$ThisDbId = $_;
last;
}
}
# if it was not found above, open it now
unless ($ThisDbId) {
if ($ThisDbPw) {
$ThisDbId = openDB($srv,DbName=>$ThisDbName,Password=>$ThisDbPw);
} else {
$ThisDbId = openDB($srv,DbName=>$ThisDbName);
}
}
# fail if the open doesn't work
unless ($ThisDbId) {
return undef;
}
$ThisDb = $DBs->{$ThisDbId};
# don't count this request individually, the other sub-calls do it
#$ThisDb->{'-RequestCount'}++;
#$srv->{'-RequestCount'}++;
# Now we can try to lock the record
unless ($RetCode = $srv->updateRecordLock(DbId=>$ThisDbId,RecNb=>$ThisRecNb)) {
$Msg = "updateRecordForced() : could not get update lock";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
# Even if we get a response, it may still be that the record is busy or doesn't exist
($LockId,$LockedRecNb) = split(/,/,$RetCode);
if ($LockId =~ /^\d$/) { # a single-digit return is some error
if ($LockId eq "1") {
log_msg("Record $ThisRecNb is busy !") if $Debug>1;
return undef;
} else {
$Msg = "updateRecordForced() : unknown status $LockId returned by updateRecordLock() for record # $ThisRecNb";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
}
# Prepare a skeleton request table
$Fields = []; # ref. to empty array
$XMLRequest = {
'Root' =>{
'UpdateRecord' =>{
'LockId'=>$LockId,
'IgnoreUnknownFields' => "True",
'Field' => $Fields, # array ref., see below
}, # /UpdateRecord
'-dummy'=>"x", # not output, but forces XMLout() to consider "UpdateRecord" as content of Root, not attribute
}, #/Root
};
# optional :
# if ($IgnoreUnknown) {
# $XMLRequest->{Root}->{UpdateRecord}->{IgnoreUnknownFields} = "True";
# }
if ($RecordClear) {
$XMLRequest->{Root}->{UpdateRecord}->{Clear} = "True";
}
# Fill in the request
# Build Fields table (array)
FLD: foreach $FldName (keys(%$FieldsTbl)) {
# warn " X: processing field $FldName" if $Debug>2;
$FldEntry = $FieldsTbl->{$FldName};
$FldOccs = $FldEntry->{'occs'};
my @occs = ();
foreach (@$FldOccs) {
next if $_ eq ''; # skip empty occurrences
push(@occs,$_); # Add the occurrence
}
# don't create a field unless there is at least one non-empty occurrence
next FLD unless scalar(@occs);
$FldXML = { 'Occ' => [ @occs ] };
$FldXML->{'InputFieldName'} = $FldName;
$FldXML->{'Clear'} = ($FldEntry->{'clear'} ? "True" : "False");
$FldXML->{'Long'} = ($FldEntry->{'long'} ? "True" : "False");
push(@$Fields,$FldXML); # Add field to the Fields array
} # end foreach FLD
# dump_Tbl($Fields," ++ updateRecord : fields table ") if $Debug>2;
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","updateRecord()");
return undef;
}
# Expected response : see updateRecord()
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# But the message is in the "emsg" attribute of <UpdateRecord>
$Emsg = $XMLResponse->{'Root'}->{'UpdateRecord'}->{'emsg'};
$Msg = "** UpdateRecord request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$srv->{'-LastActive'} = time();
#$ThisDb->{'-RecordsCreatedCount'}++;
#$srv->{'-RecordsCreatedCount'}++;
# delete the general lock entry
delete($Locks->{$LockId});
log_msg("<==updateRecordForced(ok)") if $Debug > 1;
return 1;
}
sub deleteRecord {
################
# delete a record
# called as : result = $srv->deleteRecord(DbId=>$DbId,RecNb=>$RecNb[,Password=>$Pass]);
# returns : RecNb on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $recnb = $args{RecNb} or Carp::croak "** RecNb argument missing or invalid **";
log_msg("==>deleteRecord($dbid,$recnb)") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId};
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'DeleteRecord' =>{
'DatabaseId'=>$dbid,
'RecordNumber'=>$recnb,
}, # /RecordLock
'-dummy'=>"x",
}, #/Root
};
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","deleteRecord()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'DeleteRecord' = {
# 'DatabaseId' = "xx",
# 'RecordNumber' = "yyy",
# 'Password' = "xyz",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /DeleteRecord
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'CreateLock'}->{'emsg'};
$Msg = "** CreateLock request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==deleteRecord(ok)") if $Debug > 1;
return $recnb;
}
#
# Lock-related subs
#
sub createRecordLock {
####################
# Get a new empty record and set a lock on it prior to createRecord()
# called as : $LockId = $srv->createRecordLock(DbId=>$DbId{,LockId=>some-id});
# returns : "LockId,RecNb" on success
# undef on failure
#
# Changed AW 2011/04/06 : if a LockId call parameter is supplied, the sub will use it
# instead of generating its own.
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $LockId = $args{LockId} || ''; # optional
my $Retries = $args{Retries} || 0; # optional, default 0
my $Delay = 1; # arbitrary 1s delay between retries
log_msg("==>createRecordLock(d=$dbid,i=$LockId,r=$Retries)") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId} or Carp::croak "** Invalid ConId in db table **";
my $Locks = $srv->{'-Locks'}; # general locks table
my $LockEntry;
my $RecNb;
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
unless ($ThisDb->{'-Active'}) {
# Database must be open
$Msg = "** Database \"$dbid\" is not open ! **";
Carp::cluck $Msg;
$srv->{ComErr} = 12;
$srv->{ComMsg} = $Msg;
return undef;
}
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# if a LockId was supplied, use it; otherwise generate our own unique one, LOADN-like
unless ($LockId) {
$LockId = _XML_id($srv,"LKC");
}
# use the default object
$XMLObj = $srv->{'XOB'};
my $maxLoops = $Retries + 1; # so that we do this at least once
my $gotLock = 0; # success flag
# Prepare the request table
$XMLRequest = {
'Root' =>{
'CreateLock' =>{
'Id'=>$LockId,
'DatabaseId'=>$dbid,
}, # /CreateLock
'-dummy'=>"x",
}, #/Root
};
LOCKLOOP: for (my $i = 1; $i <= $maxLoops; $i++) {
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash, fatal
$Emsg = "createRecordLock(): no response from XMLRequest ($i)!";
log_msg(" $Emsg") if $Debug > 1;
_setError($srv,ECAT_COM,2,'',"ERRCOM_02",$Emsg);
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'CreateLock' = {
# 'Id' = "Id",
# 'DatabaseId' = "xx",
# 'RecordNumber' = "yyy",
# 'Password' = "xyz",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /CreateLock
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
log_msg(" createRecordLock(), ecount : $RootEcount") if $Debug > 1;
if ($RootEcount eq "0") {
$gotLock = 1;
last LOCKLOOP;
} else {
$Emsg = $XMLResponse->{'Root'}->{'CreateLock'}->{'emsg'};
# analyse error message
if ($Emsg =~ /\[AduplicateLockName\]/i) {
# lock-id still in use (in CASIM queue ?), sleep and loop if retries requested,
# else abort right away
$Emsg .= " (attempt $i)";
_setError($srv,ECAT_STAR,12,'',"ERRSTA_12",$Emsg);
last LOCKLOOP unless $Retries;
sleep $Delay;
next LOCKLOOP;
} else {
# at the moment, other errors are fatal
$Emsg = "** CreateLock request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
last LOCKLOOP;
}
}
} # end LOCKLOOP
unless ($gotLock) {
log_msg("<==createRecordLock(error)" . $Emsg) if $Debug > 1;
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$RecNb = $XMLResponse->{'Root'}->{'CreateLock'}->{'RecordNumber'};
# Should we test that Rec # is a valid value ?
$result = "${LockId},${RecNb}";
# Create an entry in the global locks table (what was this for ?)
$LockEntry = {
Id => $LockId,
DbId => $dbid,
ConId => $conid,
Type => "Create",
RecNb => $RecNb,
};
$Locks->{$LockId} = $LockEntry;
log_msg("<==createRecordLock(ok)") if $Debug > 1;
return $result;
}
sub updateRecordLock {
####################
# Lock a record (normally prior to updating it)
# called as : $LockId = $srv->updateRecordLock(DbId=>$DbId,RecNb=>$RecNb[,Password=>$Pass]);
# returns : "LockId,RecNb" on success
# "1,RecNb" if the record exists but cannot be locked (already locked ?)
# "2,RecNb" if the record does not exist
# undef in case of a more severe error
#
# Note AW 2014/10/07 : we should probably change the return value to be :
# "0,error-code"
# in case of error. 0 would be easier to test by the calling program, since normally
# any valid lock-id would not be 0.
# Before making this change though, we want to make sure of which programs already use this function.
# (current list : MiraIndexer, ...) (not : MiraLoader, MiraSDI*, )
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $dbid = $args{DbId} or Carp::croak "** DbId argument missing or invalid **";
my $recnb = $args{RecNb} or Carp::croak "** RecNb argument missing or invalid **";
my $LockId = $args{LockId}; # can be undef if not supplied
my $Retries = $args{Retries} || 0; # optional, default 0
my $Delay = 1; # arbitrary 1s delay between retries
log_msg("==>updateRecordLock($dbid,$recnb)") if $Debug > 1;
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $ThisDb = $DBs->{$dbid} or Carp::croak "** Invalid database-id : $dbid **";
my $ThisDbName = $ThisDb->{DbName};
my $conid = $srv->{ConnectionId} or Carp::croak "** Invalid ConId in db table **";
my $Locks = $srv->{'-Locks'}; # general locks table
my $LockEntry;
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# if a LockId was supplied, use it; otherwise generate our own unique one, LOADN-like
unless ($LockId) {
$LockId = _XML_id($srv,"LKU");
}
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'RecordLock' =>{
'Id'=>$LockId,
'DatabaseId'=>$dbid,
'RecordNumber'=>$recnb,
}, # /RecordLock
'-dummy'=>"x",
}, #/Root
};
# add optional args
# use the default object
$XMLObj = $srv->{'XOB'};
my $maxLoops = $Retries + 1; # so that we do this at least once
my $gotLock = 0; # success flag
LOCKLOOP: for (my $i = 1; $i <= $maxLoops; $i++) {
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","updateRecordLock()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'RecordLock' = {
# 'Id' = "Id",
# 'DatabaseId' = "xx",
# 'RecordNumber' = "yyy",
# 'Password' = "xyz",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /CreateLock
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount eq "0") {
$gotLock = 1;
last LOCKLOOP;
} else {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'RecordLock'}->{'emsg'};
if ($Emsg =~ /\[AduplicateLockName\]/i) {
# lock-id still in use (in CASIM queue ?), sleep and loop if retries requested,
# else abort right away
_setError($srv,ECAT_STAR,12,'',"ERRSTA_12",$Emsg);
last LOCKLOOP unless $Retries;
sleep $Delay;
next LOCKLOOP;
} elsif ($Emsg =~ /\[SRecordInUse\]/) {
# should we also loop here ? (watch for incompatible changes)
$Msg = "RecordLock failed (busy) : $Emsg";
_setError($srv,ECAT_STAR,11,'',"ERRSTA_11",$Msg);
# But do not return undef
$result = "1,$recnb";
return $result;
} else {
# other errors abort the request
$Msg = "** RecordLock request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
last LOCKLOOP;
}
return undef;
}
} # end LOCKLOOP
unless ($gotLock) {
log_msg("<==updateRecordLock(error)") if $Debug > 1;
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$result = "${LockId},${recnb}";
# Create an entry in the global locks table
$LockEntry = {
Id => $LockId,
DbId => $dbid,
ConId => $conid,
Type => "Update",
RecNb => $recnb,
};
$Locks->{$LockId} = $LockEntry;
log_msg("<==updateRecordLock(ok)") if $Debug > 1;
return $result;
}
sub freeRecordLock {
##################
# unlock a record
# called as : result = $srv->freeRecordLock(LockId=>$LockId);
# returns : "LockId,RecNb" on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $Params = { @_ };
my $LockId = $Params->{LockId} or Carp::croak "** LockId argument missing or invalid **";
log_msg("==>freeRecordLock($LockId)") if $Debug > 1;
my $Locks = $srv->{'-Locks'}; # general locks table
my $DBs = $srv->{'-DBs'}; # ref to general databases table
my $Conns = $srv->{'-Connections'}; # ref to general connections table
my $ThisLock = $Locks->{$LockId};
unless (defined($ThisLock)) {
log_msg("freeRecordLock(): LockId [$LockId] not found in table, ignored") if $Debug;
return undef;
}
my $ThisDbId = $ThisLock->{DbId} or Carp::croak "** Invalid DbId in lock table **";
my $ThisDb = $DBs->{$ThisDbId} or Carp::croak "** Invalid database-id in lock table : $ThisDbId **";
my $ThisDbName = $ThisDb->{DbName};
my $ThisConId = $srv->{ConnectionId};
my $RecNb = $ThisLock->{RecNb};
my $result;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
$ThisDb->{'-RequestCount'}++;
$srv->{'-RequestCount'}++;
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'FreeLock' =>{
'LockId'=>$LockId,
}, # /RecordLock
'-dummy'=>"x",
}, #/Root
};
# add optional args
# we can do this with the default object
$XMLObj = $srv->{'XOB'};
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$XMLObj))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","freeRecordLock()");
return undef;
}
$srv->{'-LastActive'} = time();
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'FreeLock' = {
# 'LockId' = "Id",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /CreateLock
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'FreeLock'}->{'emsg'};
$Msg = "** FreeLock request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$result = "$LockId,$RecNb";
# delete the general lock entry
delete($Locks->{$LockId});
log_msg("<==freeRecordLock(ok)") if $Debug > 1;
return $result;
}
sub submitGlobal {
################
# Note : at the moment, we only support submittal of Global Load subfunction, and only with
# a pre-existing Global.
# We do support changing the Target Database name, the Report File, the Options, and
# the Source data file (at the risk of a Star error).
# In the future, we may clone this function into separate one for each Global type, for
# execution efficiency. (like submitGlobalLoad(), submitGlobalCross, ..)
# Note : the Report File is a dangerous option, as we might be running on a separate system
# and cannot verify in any case that the file name would overwrite something very essential.
# For that reason, the filename cannot be absolute, and will be prefixed with "~star/log/XML_"
# Note : similarly or not, the Load File is a path on the Star server. It is the responsibility
# of the application to see to it that there is really a data file there, readable by Star.
# Note : any password required for either the Source or Target databases must have been provided
# previously (for example by calling the Database function).
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
my %args = @_;
log_msg("==>submitGlobal()") if $Debug > 1;
my $GlobalName = $args{GlobalName} || '';
my $ReportFile = $args{ReportFile} || ''; # RFILE
my $SubFunction = $args{Type} or Carp::croak "** Type argument missing **"; # SUBF
$SubFunction = '' unless $SubFunction;
unless ($SubFunction =~ /^(Load|Cross Load|Change Values|Delete Records)$/) {
Carp::croak "** Type argument is invalid : $SubFunction **";
}
my $Options = $args{Options} || ''; # OPTS
my $SearchSet = $args{SearchSet} || ''; # SETSP
my $LoadFile = $args{LoadFile} || ''; # SFILE
my $LabelLength = $args{LabelLength} || '0'; # LABLN
my $SourceDB = $args{SourceDB} || ''; # SDB
my $TargetDB = $args{TargetDB} || ''; # UPDB
my $FldOps = []; # init to empty array ref
if (exists($args{FieldOps})) {
$FldOps = $args{FieldOps};
unless (ref($FldOps) =~ /^ARRAY/) {
Carp::croak "** FieldOps argument must be an Array ref. **";
}
}
# Temporary restrictions :
unless ($SubFunction =~ /^(Load)$/) {
Carp::croak "** Type argument : only \'Load\' supported at this time **";
}
unless ($GlobalName) {
Carp::croak "** GlobalName argument must be supplied at this time **";
}
unless ($LoadFile) {
Carp::croak "** LoadFile argument must be supplied at this time **";
}
my $conid = $srv->{ConnectionId};
my $DBs = $srv->{'-DBs'}; # ref to general databases table
#my $ThisDbId = $ThisLock->{DbId} or Carp::croak "** Invalid DbId in lock table **";
#my $ThisDb = $DBs->{$ThisDbId} or Carp::croak "** Invalid database-id in lock table : $ThisDbId **";
#my $ThisDbName = $ThisDb->{DbName};
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my ($Ecount,$Emsg);
my ($Fields,$FldName,$FldEntry,$FldOccs);
my $FldXML;
$srv->{'-RequestCount'}++;
# Prepare a skeleton request table
$Fields = []; # ref. to empty array
$XMLRequest = {
'Root' =>{
'SubmitGlobal' =>{
'ConnectionId'=>$conid,
'Field' => $Fields, # array ref., see below
}, # /SubmitGlobal
'-dummy'=>"x", # not output, but forces XMLout() to consider "UpdateRecord" as content of Root, not attribute
}, #/Root
};
# Fill in the request
my $SubGlo = $XMLRequest->{Root}->{SubmitGlobal};
# For now, always recall existing Global
if ($GlobalName) {
$SubGlo->{GlobalRecordName} = $GlobalName;
}
sub bldfld {
my $fname = shift;
my $fval = shift || '';
my $clear = shift; $clear = $clear ? 'True' : 'False';
my $fldentry = {
InputFieldName => $fname,
Clear => $clear,
Occ => $fval,
};
return $fldentry;
}
# First the 'standard' options.
# For these, we pre-clear anything that's there in the stored Global
if ($Options) {
push(@$Fields,bldfld('OPTS',$Options,1));
}
if ($LoadFile) {
push(@$Fields,bldfld('SFILE',$LoadFile,1));
}
if ($LabelLength) {
push(@$Fields,bldfld('LABLN',$LabelLength,1));
}
if ($TargetDB) {
push(@$Fields,bldfld('UPDB',$TargetDB,1));
}
if ($ReportFile) {
# sanitize a bit
$ReportFile =~ s!^(/|\\)!!; # force relative
$ReportFile =~ s/\.{2}//g; # remove any attempt at dot-dot
$ReportFile =~ s/[<|>&;*]//g; # strip meta chars
$ReportFile = '~star/log/XML_' . $ReportFile; # force prefix
push(@$Fields,bldfld('RFILE',$ReportFile,1));
}
# then field options, if any.
# This is just an array of strings.
# At the moment, these FLDOP occurrences just add on to the ones pre-defined
# in the stored Global.
FLDOP: foreach (@$FldOps) {
push(@$Fields,bldfld('FLDOP',$_,0));
}
# dump_Tbl($Fields," ++ submitGlobal : fields table ") if $Debug>2;
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","submitGlobal()");
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' = {
# 'ecount' => "0/n", # always
# 'emsg' => "error message", # only if errors
# 'SubmitGlobal' = {
# 'ConnectionId' = "Id",
# 'GlobalRecordNsme = "Name",
# 'ecount' = "ecount",
# 'emsg' = "error message",
# }, # /Database
# }, # /Root
# }; # /XMLResponse
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# Then there's an error
# But the message is in the "emsg" attribute of <SubmitGlobal>
$Emsg = $XMLResponse->{'Root'}->{'SubmitGlobal'}->{'emsg'};
$Msg = "** SubmitGlobal request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Msg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
$srv->{'-LastActive'} = time();
#$ThisDb->{'-RecordsCreatedCount'}++;
#$srv->{'-RecordsCreatedCount'}++;
log_msg("<==submitGlobal(ok)") if $Debug > 1;
return 1;
}
#
# special functions for MIRACGIDB or equivalent
#
sub getCgiInfo {
# retrieve CGI parameters via KEY (Company + CGI name) or CUNI (unique CGI app. number 100-999)
# do it all it one go for speed
# called as : $res = $srv->getCgiInfo(DbName=>'MIRACGIDB',RecId=>(KEY or UNI),
# [DollarUid=>UserId],[ReUse=>1])
# returns undef if failure (error in $srv->error())
# else a ref to a 'cgiinfo' structure :
# ref = {
# 'KEY' => KEY, # unique cgi application key (company.cgi-name e.g. ETH.MIRACO))
# 'CUNI' => CUNI, # unique numerical id (100-999)
# 'CPY' => company code (e.g. ETH)
# 'CGI' => cgi-name (e.g. MIRACO)
# 'FXHOS' => StarXML host:port (e.g. othersystem:11200)
# 'FSHOS' => Star/server host:port (e.g. yetanother:11003)
# 'FUID' => mandatory user-id (e.g. "star")
# 'FPW' => password of FUID
# 'FIFSH' => mandatory IFS host:port (e.g. myifs.mycompany.com:11010)
# 'EFSD' => local EFS dir. path (e.g. /home/EFS)
# 'EFSVD' => Local Path of Volumes root (e.g. /home/EFSVOL1)
# 'VOLS' => [ '0000000','0000001',... ] array ref to array of allowed volumes
# 'DOCDB' => Documents database name (e.g. ETHDOCS)
# 'FOBJ' => in docs db, name of field containing object-id if subfield "n"
# 'FCO' => check-out flag field name (default = CO)
# 'FCOH' => check-out history field name (default = COH)
# 'FCOUP' => stamp field name (default = COUP)
# 'HDOCS' => [ '/AS/html_doc1.html','/AS/html_doc2.html',... ]
# 'UDVS' => {
# 'WEB' => value of $WEB,
# 'LANG' => value of $LANG,
# ...
# },
#
my $srv = shift;
my $Debug = $srv->{'-Debug'};
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my %args = @_;
my ($dbName,$recKey);
Carp::confess "Invalid parameters !" unless (($dbName = $args{DbName}) && ($recKey = $args{RecId}));
my $dollarUid = $args{DollarUid} || '';
my $reUse = $args{ReUse} || 0;
my $search;
my $CDBO = [ qw(
KEY CPY CGI CUNI FXHOS FSHOS FUID FPW FIFSH
VOLS DOCDB FOBJ FCO FCOH FCOUP EFSD EFSVD
HDOC1 HDOC2 HDOC3 HDOC4 HDOC5 HDOC6 HDOC7 HDOC8 HDOC9
ZZUID ZZDVS ZZEML ZZLAN XLOOK1 XLOUT1
)
];
my $Databases = $srv->{'-Databases'}; # database names table for this Star connection
my $XMLResponse;
my $cgiInfo = {}; # response structure
# In any case, we check if we already have this database open, because it probably
# saves time and memory to re-use the open structure rather than re-opening it.
# If we do not have it open, then what happens depends on the "ReUse" parameter :
# - if ReUse is true, we do a regular openDb() first, which will open the db
# and fill-in all our structures, at the expense of time. We would do this
# if we intend to re-use the same MIRACGIDB database several times (as in
# MiraASci.pl), and this was the first such call.
# - if ReUse is false, we dont use a regular openDb(), but we include the open
# in the XML request we do later. This is probably orders of magnitude faster
# for a single call (as in a cgi-bin script), but does not help if we re-use
# the same db later.
my $conId = $srv->{'ConnectionId'};
my $dbId;
foreach (keys(%$Databases)) {
if ($Databases->{$_} = $dbName) {
$dbId = $_;
last;
}
}
unless ($dbId) {
if ($reUse) {
# then use the standard method to open the db
unless ($dbId = $srv->openDB(DbName => $dbName)) {
return undef;
}
}
}
# thus now, if we have a dbId, the db is open, and else not yet
my $XMLRequest = '<Root>' . CRLF;
unless ($dbId) {
$dbId = 'cgidb'; # force it to something, for re-use
$XMLRequest .= "<Database Id=\"${dbId}\" ConnectionId=\"${conId}\" DatabaseName=\"${dbName}\"/>" . CRLF;
}
$dollarUid = 'nobody' unless $dollarUid;
$XMLRequest .= "<SetVariable ConnectionId=\"${conId}\" Name=\"CGIUID\" Value=\"${dollarUid}\"/>" . CRLF;
$XMLRequest .= "<Report Id=\"rcgidb\" DatabaseId=\"${dbId}\""
. " PageLayout=\"STARXML\" ReportName=\"*DUMP\" PrettyPrint=\"False\">" . CRLF;
if ($recKey =~ /^\d+$/) {
$search = 'CUNI=' . $recKey;
} else {
$search = 'KEY=' . $recKey;
}
$XMLRequest .= "<SearchText>${search}</SearchText>" . CRLF;
$XMLRequest .= "<FieldOptions OutputFieldsNameList=\"";
foreach (@$CDBO) {
$XMLRequest .= $_ . '/N ';
}
$XMLRequest .= "\"/>" . CRLF;
$XMLRequest .= "</Report>" . CRLF;
$XMLRequest .= "<GetRecords ReportId=\"rcgidb\" FirstRecord=\"0\" />" . CRLF;
$XMLRequest .= "</Root>";
warn("Request about to be sent :\n",$XMLRequest,"\n") if $Debug;
unless (defined($XMLResponse = XML_Request_String($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getCgiInfo()");
return undef;
}
$srv->{'-LastActive'} = time();
# Analyse the return document.
my $RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute somewhere
return undef;
}
my ($InRecords,$OutRecords);
my $cgiRecord = $XMLResponse->{'Root'}->{'GetRecords'}->{'Response'}->{'Record'}; # ref to record array/hash
unless (ref($cgiRecord) =~ /^HASH/) {
# means we have an error, we expect only one
return undef;
}
# Pick out the fields and insert them in the return hash.
# Multiple occs fields are ignored (except for 1st occ)
my $FldList = $cgiRecord->{Field};
foreach (@{$FldList}) {
my $name = $_->{'OutputFieldName'};
next if $name =~ m/^(Next|Prev|Sort)$/; # skip these
my $val = $_->{'$TEXT$'};
next unless (defined($val)); # bypass empty values
$val =~ s/^\s+//; $val =~ s/\s+$//;
next if $val eq ''; # bypass empty values
if ($name eq 'XLOUT1') {
my ($uid,$dvs) = ($val =~ m/^([^:]+)\:\:(.*)$/);
my @vars = split(/;;/,$dvs);
foreach (@vars) {
$_ =~ s/^\s+//;
# Dollar vars start with $ sign
my ($vname,$vval) = ($_ =~ /^\$(\S+)\s+(.*)$/);
next unless $vname; # skip if not recognised
next unless (defined($vval) and ($vval ne '')); # skip if no value
$vval =~ s/^\s+//; $vval =~ s/\s+$//;
# take them all and give them a distinct prefix in the global SETUP table
$cgiInfo->{UDVS}->{uc($vname)} = $vval;
}
next;
}
if ($name eq 'VOLS') {
$cgiInfo->{VOLS} = [] unless $cgiInfo->{VOLS};
my @vals = split(/,/,$val);
push(@{$cgiInfo->{VOLS}},@vals);
next;
}
if (exists($cgiInfo->{$name})) {
log_msg(1," additional occ. for field [$name], ignored !");
next;
}
$cgiInfo->{$name} = $val;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
return $cgiInfo;
# ref = {
# 'KEY' => KEY, # unique cgi application key (company.cgi-name e.g. ETH.MIRACO))
# 'CUNI' => CUNI, # unique numerical id (100-999)
# 'CPY' => company code (e.g. ETH)
# 'CGI' => cgi-name (e.g. MIRACO)
# 'FXHOS' => StarXML host:port (e.g. othersystem:11200)
# 'FSHOS' => Star/server host:port (e.g. yetanother:11003)
# 'FUID' => mandatory user-id (e.g. "star")
# 'FPW' => password of FUID
# 'FIFSH' => mandatory IFS host:port (e.g. myifs.mycompany.com:11010)
# 'EFSD' => local EFS dir. path (e.g. /home/EFS)
# 'EFSVD' => Local Path of Volumes root (e.g. /home/EFSVOL1)
# 'VOLS' => [ '0000000','0000001',... ] array ref to array of allowed volumes
# 'DOCDB' => Documents database name (e.g. ETHDOCS)
# 'FOBJ' => in docs db, name of field containing object-id if subfield "n"
# 'FCO' => check-out flag field name (default = CO)
# 'FCOH' => check-out history field name (default = COH)
# 'FCOUP' => stamp field name (default = COUP)
# 'HDOCS' => [ '/AS/html_doc1.html','/AS/html_doc2.html',... ]
# 'UDVS' => {
# 'WEB' => value of $WEB,
# 'LANG' => value of $LANG,
# ...
# },
}
#
# Miscellaneous functions
#
sub setVariable {
###############
# Set a global variable for this connection (Dollar Variable)
# called as : result = $srv->setVariable(Name=>$name,Value=>$value);
# returns : true on success
# undef on failure
# Note : variable name is case-sensitive
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $name = $args{Name} or Carp::croak "** Name argument missing or invalid **";
my $value = $args{Value}; # can be undef (to unset the variable)
my $StarValue = $value || ''; # but this one to empty string if undef
my $conid = $srv->{ConnectionId};
my $ConVars = $srv->{'-Vars'};
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
log_msg("==>setVariable()") if $Debug > 1;
$srv->{'-RequestCount'}++;
# Prepare the request table
# <SetVariable ConnectionId="conid" Name="name" Value="value"/>
# mandatory args
$XMLRequest = {
'Root' =>{
'SetVariable' =>{
'ConnectionId'=>$srv->{ConnectionId},
'Name'=>$name,
'Value'=>$StarValue, # XML doesn' like undefs
}, #/SetVariable
}, #/Root
};
# we can do this with the default object
# send the SetVariable request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","setVariable()");
return undef;
}
$srv->{'-LastActive'} = time();
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <Database>
$Emsg = $XMLResponse->{'Root'}->{'SetVariable'}->{'emsg'};
$Msg = "** SetVariable Request failed : $Emsg **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
# if the argument value was undef, we delete the variable;
# if it was the empty string or else, we set it to that
if ($value) {
$ConVars->{$name} = $value;
} else {
delete $ConVars->{$name};
}
log_msg("==>setVariable(ok)") if $Debug > 1;
return 1;
}
sub setVariables {
################
# Set one or more global variables for this connection (Dollar Variable)
# called as : result = $srv->setVariables(\{VarName1=>"Value1"[,VarName2=>"Value2",...VarNameN=>"ValueN"]});
# In other words : arg1 must be a ref. to a Hash of names/values
# (else we expect a single var definition, in "named arguments" form ?)
# returns : true on success, false (undef) on failure
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $vars = shift;
Carp::confess "Invalid call, arg1 must be Hash ref !" unless (ref($vars) eq 'HASH');
my $conid = $srv->{ConnectionId};
my $ConVars = $srv->{'-Vars'};
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($RootEcount,$Ecount,$Emsg);
log_msg("==>setVariable()") if $Debug > 1;
$srv->{'-RequestCount'}++;
my $SetVarTable = [];
foreach my $k (keys(%$vars)) {
my $v = $vars->{$k} || '';
my $SetVariable = {
'ConnectionId'=>$conid,
'Name'=>$k,
'Value'=>$v,
};
push(@$SetVarTable,$SetVariable);
if ($v eq '') {
delete $ConVars->{$k} if exists $ConVars->{$k};
} else {
$ConVars->{$k} = $v;
}
}
# Prepare the request table
# <SetVariable ConnectionId="conid" Name="name" Value="value"/>
# mandatory args
$XMLRequest = {
'Root' => {
'SetVariable' => $SetVarTable,
'dummy' => 'x',
}
};
# we can do this with the default object
# send the SetVariable request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{'XOB'}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","setVariable()");
return undef;
}
$srv->{'-LastActive'} = time();
# Analyse the return document.
$RootEcount = $XMLResponse->{'Root'}->{'ecount'};
if ($RootEcount ne "0") {
# The message is in the "emsg" attribute of <SetVariable>
# .. but which one ?
#$Emsg = $XMLResponse->{'Root'}->{'SetVariable'}->{'emsg'};
#$Msg = "** SetVariable Request failed : $Emsg **";
$Emsg = "** SetVariable Request failed **";
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
return undef;
}
$srv->{'ErrLastResponse'} = ''; # clean this up in normal case
log_msg("<==setVariables(ok)") if $Debug > 1;
return 1;
}
sub getVariable {
###############
# get a global variable for this connection (Dollar Variable)
# called as : value = $srv->getVariable(Name=>$name);
# returns : value on success (can be empty string !)
# undef on failure
# Note 1 : variable name is case-sensitive
# Note 2 : this does not actually interrogate Star, but returns the value of the
# variable stored in the connection table.
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Debug = $srv->{'-Debug'};
my %args = @_;
my $name = $args{Name} or Carp::croak "** Name argument missing or invalid **";
my $conid = $srv->{ConnectionId};
log_msg("==>getVariable()") if $Debug > 1;
$srv->{'-RequestCount'}++;
log_msg("==>getVariable()") if $Debug > 1;
return $srv->{'-Vars'}->{$name}; # undef if didn' exist
}
sub disconnect {
##############
# Close the connection
# called as :
# $RetCode = srv->disconnect();
# or
# $RetCode = srv->disconnect(1); # keep the object alive
#
# returns : true on success, undef on failure
#
my $srv = shift;
my $keep_data = shift; # set to 1 to not delete the connection object itself
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Debug = $srv->{'-Debug'};
my $Msg;
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $ConId = $srv->{ConnectionId};
log_msg("==>disconnect()") if $Debug > 1;
# request
$XMLRequest = {
'Root' =>{
'Quit' => {
'-dummy'=>"x",
}, #/Quit
}, # /Root
};
# send the request
$XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB});
# and we basically don't care what is sent back
close($srv->{SERVER}); # close the socket
unless ($keep_data) {
undef $srv; # destroy connection object
}
log_msg("Connection \"$ConId\" closed.") if $Debug>1;
log_msg("<==disconnect()") if $Debug > 1;
return 1;
}
sub GetDbName {
#############
# Get actual DB Name from DbId
# called as : $dbname = srv->GetDbName($dbid)
my $srv = shift;
my $ThisDbId = shift;
my $DBs = $srv->{'-DBs'};
warn Dumper $DBs;
my $ThisDb = $DBs->{$ThisDbId};
my $ThisDbName = $ThisDb->{'DbName'};
return $ThisDbName;
}
sub SetDbInfo {
#############
# Get permissions applicable to this database for this user, and list of fields
# called as : $Perms = srv->SetDbInfo($ThisCon,$ThisDb);
# where :
# - $ThisCon is a ref to the connections table entry for this connection
# - $ThisDb is a ref to the databases table entry for this database
# returns : Permission bitmap on success
# undef on failure
#
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my ($ThisCon,$ThisDb) = @_;
my $RetPerms;
my $Databases = $srv->{'Databases'};
my $ThisConId = $ThisCon->{'Id'};
my $ThisDbName;
my ($ThisUserId,$ThisUserComp,$ThisUserGroups);
my ($FieldsDbId,$FieldsDbName,$FieldsDbPw,$FieldsDb);
my ($SearchClear,$SearchNb,$SearchExpr);
my $RecCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my $RetCode;
my ($RptId,$RptName,$RptLayout);
my ($Records,$ThisRec,$ThisFld,$FldName,$FldVal);
my ($ACL,$FLD);
my ($WorkACLS,$UserACL,$GroupACLS,$groupACL);
my ($ACLid,$ACLtype,$ACLcomp);
my ($WorkFLDS,$FieldsTblA);
my ($FldIdx,$FName,$FNumber,$FLabel,$FType,$FLLength,$FLLines,$FLFixed,$FOccs,$FOFixed,$FValid);
my $groupid;
my (@subfields, $subfld);
my ($permtype,$permval);
my $SaveDoDbPerms;
log_msg("==>SetDbInfo()") if $Debug > 1;
$FieldsDb = $ThisCon->{'-FieldsDb'};
unless (defined($FieldsDb)) {
# Can't do if no Fields db opened yet (should happen at Login)
$Msg = "** No Fields db defined/opened **";
log_msg($Msg) if $Debug;
$srv->{'XMLErr'} = 0;
$srv->{'XMLMsg'} = $Msg;
return undef;
}
$ThisUserId = $ThisCon->{'UserId'};
$ThisUserComp = $ThisCon->{'-Company'};
$ThisUserGroups = $ThisCon->{'-Groups'};
# Cancel permissions verification temporarily, so we don't get in a loop
$SaveDoDbPerms = $srv->{'DoDbPerms'};
$srv->{'DoDbPerms'} = 0;
$FieldsDbId = $FieldsDb->{'Id'};
$FieldsDbName = $FieldsDb->{'DbName'};
$FieldsDbPw = $FieldsDb->{'Password'};
$ThisDbName = $ThisDb->{'DbName'};
# # Set this as "CURRDB" variable
# unless (XML_SetVar($srv,$ThisConId,"CURRDB",$ThisDbName)) {
# # returns undef if error
# $Msg = "** Could not set variable \"CURRDB\" **";
# log_msg($Msg) if $Debug;
# $srv->{'XMLErr'} = 0;
# $srv->{'XMLMsg'} = $Msg;
# $srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
# return undef;
# }
# Search for the requested db in the Fields database
# We should get exactly 1 record hit.
$SearchClear = 1;
$SearchNb = "1";
$SearchExpr = "NAME=\"$ThisDbName\"";
$RecCount = $srv->SingleDbSearch($FieldsDbId,$SearchClear,$SearchNb,$SearchExpr);
unless (defined($RecCount) && ($RecCount == 1)) {
$Msg = "** Database \"$ThisDbName\" not found : ";
$Msg .= $srv->{'ComMsg'};
$Msg .= " **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# Get the report
$RptId = _XML_id($srv,"RPT");
$RptName = $srv->{'FieldsProps'};
$RptLayout = "STARXML";
$RetCode = $srv->SingleDbReport($FieldsDbId,$RptId,$RptName,$RptLayout,"S1","","");
unless (defined($RetCode)) {
$Msg = "** Report \"$RptName\" could not be generated, error : \"";
$Msg .= $srv->{'ComMsg'};
$Msg .= "\" **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# ($StarItemsCount,$StarLinesCount) = split(",",$RetCode);
# Get the results
$Records = $srv->GetRecords($RptId,0,1);
unless (defined($Records)) {
$Msg = "** Could not retrieve records, error : \"";
$Msg .= $srv->{'ComMsg'};
$Msg .= "\" **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# and dissect them
$ThisRec = $Records->[0]; # we know there's only one
$WorkACLS = []; # create empty array for ACL's
$WorkFLDS = []; # same for fields
foreach $ThisFld (@{$ThisRec->{'Field'}}) {
$FldName = $ThisFld->{'OutputFieldName'};
log_msg("processing field \"$FldName\"") if $Debug >2;
next if $FldName eq "Sort"; # skip those
next if $FldName eq "XMLUSR"; # skip those
next if $FldName eq "XMLDVS"; # skip those
next if $FldName eq "XMLCOM"; # skip those
$FldVal = $ThisFld->{'$TEXT$'} || "";
next if $FldVal eq ""; # skip empty ones
if ($FldName eq "XACLS") {
log_msg(" ..storing ACL \"$FldVal\"") if $Debug >2;
push(@$WorkACLS,$FldVal);
next;
}
if ($FldName eq "XMLIN") {
log_msg(" ..storing Field \"$FldVal\"") if $Debug >2;
push(@$WorkFLDS,$FldVal);
next;
}
}
# # Process the ACLs (saved in @$WorkACLS)
# log_msg("Processing ACLs") if $Debug >2;
# $UserACL = "";
# $GroupACLS = []; # empty array
# foreach $ACL (@$WorkACLS) {
# log_msg(" ..processing stored ACL \"$ACL\"") if $Debug >2;
# # match id, type and company. If any doesn't match, skip entry
# next unless ($ACL =~ s/^((\w+)\s*)//); # match (and suppress) unlabeled subfield = id
# $ACLid = uc($2);
# log_msg(" .... id = \"$ACLid\"") if $Debug >2;
#
# next unless ($ACL =~ m/\|\|\$T\s+(\w+)\s*\|/); # match T subfield value = type
# $ACLtype = $1;
# log_msg(" .... type = \"$ACLtype\"") if $Debug >2;
#
# next unless ($ACL =~ m/\|\|\$X\s+(\w+)\s*\|/); # match X subfield value = company
# $ACLcomp = $1;
# log_msg(" .... cpy = \"$ACLcomp\"") if $Debug >2;
# if ($ACLtype eq "U") {
# # It's a user ACL, keep it if the Userid & company match
# log_msg(" ..User ACL for \"$ACLid\"") if $Debug >2;
# if (($ACLcomp eq $ThisUserComp) && ($ACLid eq $ThisUserId)) {
# log_msg(" ..User ACL \"$ACL\" kept.") if $Debug >2;
# $UserACL = $ACL; # then keep it
# }
# } else {
# # It's a group ACL.
# # Keep it only if company matches, and if group-id matches one of the User's
# log_msg(" ..Group ACL for \"$ACLid\"") if $Debug >2;
# next unless ($ACLcomp eq $ThisUserComp);
# foreach $groupid (@$ThisUserGroups) {
# next unless ($ACLid eq $groupid); # loop if not same group
# log_msg(" ..Group ACL \"$ACL\" kept.") if $Debug >2;
# push(@$GroupACLS,$ACL); # but if matches, keep it
# last; # and no need to look further, one ACL has only 1 group
# }
# }
# }
#
# # We should have in $UserACL the permissions of this user,
# # and in @$GroupACLS the permissions of each group to which he belongs, like
# # UserACL : ||$T U ||$X RWSWIENG ||$R 1 ||$C 1 ||$E 1 ||$D 1 ||$M 0
# # GroupACLS-> [
# # "||$T G ||$X RWSWIENG ||$R 1 ||$C 1 ||$E 1 ||$D 0 ||$M 0",
# # "||$T G ||$X XYZ ||$R 1 ||$C 0 ||$E 0 ||$D 0 ||$G 0 ||$M 0",
# # ...
# # ]
# # Transform this in permissions bitmap.
# # We "OR" the permissions, so final permissions are the "sum" of user and group permissions.
#
# $RetPerms = PERM_NONE; # start value
#
# # User permissions
# log_msg("User ACL (from Star) is : \"$UserACL\"") if $Debug>2;;
# @subfields = split('\|\|\$',$UserACL);
# foreach $subfld (@subfields) {
# $subfld =~ m/^(\w)\s(\d)/ or next;
# $permtype = $1; $permval = $2;
# log_msg(" permtype : \"$permtype\", permval : \"$permval\"") if $Debug>2;;
# if ($permtype eq "R") {
# $RetPerms |= PERM_READ if $permval eq "1";
# next;
# }
# if ($permtype eq "C") {
# $RetPerms |= PERM_CREATE if $permval eq "1";
# next;
# }
# if ($permtype eq "E") {
# $RetPerms |= PERM_EDIT if $permval eq "1";
# next;
# }
# if ($permtype eq "D") {
# $RetPerms |= PERM_DELETE if $permval eq "1";
# next;
# }
# if ($permtype eq "G") {
# $RetPerms |= PERM_GLOBAL if $permval eq "1";
# next;
# }
# if ($permtype eq "M") {
# $RetPerms |= PERM_MANAGE if $permval eq "1";
# next;
# }
# }
#
# # group(s) permissions, for each group to which user belongs
# foreach $groupACL (@$GroupACLS) {
# log_msg("Group ACL (from Star) is : \"$groupACL\"") if $Debug>2;
# @subfields = split('\|\|\$',$groupACL);
# foreach $subfld (@subfields) {
# $subfld =~ m/^(\w)\s(\d)/ or next;
# $permtype = $1; $permval = $2;
# log_msg(" permtype : \"$permtype\", permval : \"$permval\"") if $Debug>2;
# if ($permtype eq "R") {
# $RetPerms |= PERM_READ if $permval eq "1";
# next;
# }
# if ($permtype eq "C") {
# $RetPerms |= PERM_CREATE if $permval eq "1";
# next;
# }
# if ($permtype eq "E") {
# $RetPerms |= PERM_EDIT if $permval eq "1";
# next;
# }
# if ($permtype eq "D") {
# $RetPerms |= PERM_DELETE if $permval eq "1";
# next;
# }
# if ($permtype eq "G") {
# $RetPerms |= PERM_GLOBAL if $permval eq "1";
# next;
# }
# if ($permtype eq "M") {
# $RetPerms |= PERM_MANAGE if $permval eq "1";
# next;
# }
# }
# }
#
# $ThisDb->{'-Perms'} = $RetPerms; # store permissions bitmap in db table entry
# Process the Fields (saved in @$WorkFLDS)
# ($FldIdx,$FName,$FNumber,$FLabel,$FType,$FLLength,$FLLines,$FLFixed,$FOccs,$FOFixed,$FValid)
$FieldsTblA = []; # ref to empty Fields array
$FldIdx = 0;
foreach $FLD (@$WorkFLDS) {
next if ($FLD =~ /^ZZ/i); # ignore ZZ fields
my $TblRef = []; # empty "single field" array
@$TblRef = ($FldIdx, split('\+\+',$FLD));
push(@$FieldsTblA,$TblRef);
$FldIdx++;
}
$ThisDb->{'-InputFields'} = $FieldsTblA;
log_msg("<==SetDbInfo(ok)") if $Debug > 1;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return $RetPerms; # and return permissions bitmap
}
sub SetUserInfo {
###############
# Get company, groups, etc... for this user on this connection
# called as : $RetCode = XML_SetUserInfo($srv,$ThisCon);
# where :
# - $ThisCon is a ref to the connections table entry for this connection
# (must already contain the Login User-id)
# returns : True on success
# undef on failure
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Msg;
my $Debug = $srv->{'-Debug'};
my ($ThisCon) = @_;
my $RetPerms;
my $Databases = $srv->{'Databases'};
my $ThisConId;
my $ThisUserId;
my ($UsersDbId,$UsersDbName,$UsersDbPw,$UsersDb);
my ($SearchClear,$SearchNb,$SearchExpr);
my $RecCount;
my $XMLObj; # XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $RootEcount;
my $RetCode;
my ($RptId,$RptName,$RptLayout);
my ($Records,$ThisRec,$ThisFld);
my ($DVS,$DVref,$GRPS,$GRPref,$COMP); # what we're trying to get
my (@elems,$element);
my ($FldName,$FldVal);
my $SaveDoUserPerms;
my $SaveDoDbPerms;
log_msg("==>SetUserInfo()") if $Debug > 1;
$ThisConId = $ThisCon->{'Id'};
$ThisUserId = $ThisCon->{'UserId'};
$UsersDb = $ThisCon->{'-UsersDb'};
unless (defined($UsersDb)) {
# Can't do if no Users db opened yet (should happen at Login)
$Msg = "** No Users db defined/opened **";
log_msg($Msg) if $Debug;
$srv->{'XMLErr'} = 0;
$srv->{'XMLMsg'} = $Msg;
return undef;
}
# Cancel permissions verification temporarily, so we don't get in a loop
$SaveDoDbPerms = $srv->{'DoDbPerms'};
$srv->{'DoDbPerms'} = 0;
$UsersDbId = $UsersDb->{'Id'};
$UsersDbName = $UsersDb->{'DbName'};
$UsersDbPw = $UsersDb->{'Password'};
# Search for the current user-id in the Users database
# We should get exactly 1 record hit.
$SearchClear = 1;
$SearchNb = "1";
$SearchExpr = "ID=\"$ThisUserId\"";
$RecCount = XML_singleDbSearch($srv,$UsersDbId,$SearchClear,$SearchNb,$SearchExpr);
unless (defined($RecCount) && ($RecCount == 1)) {
$Msg = "** User \"$ThisUserId\" not found : ";
$Msg .= $srv->{'XMLMsg'};
$Msg .= " **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# Get the report
$RptId = _XML_id($srv,"RPT");
$RptName = $srv->{'UsersProps'};
$RptLayout = "STARXML";
$RetCode = XML_SingleDbReport($srv,$UsersDbId,$RptId,$RptName,$RptLayout,"S1","","");
unless (defined($RetCode)) {
$Msg = "** Report \"$RptName\" could not be generated, error : \"";
$Msg .= $srv->{'XMLMsg'};
$Msg .= "\" **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# ($StarItemsCount,$StarLinesCount) = split(",",$RetCode);
# Get the results
$Records = XML_GetRecords($srv,$RptId,0,1);
unless (defined($Records)) {
$Msg = "** Could not retrieve records, error : \"";
$Msg .= $srv->{'XMLMsg'};
$Msg .= "\" **";
log_msg($Msg) if $Debug;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return undef;
}
# and dissect them
$ThisRec = $Records->[0]; # we know there's only one
foreach $ThisFld (@{$ThisRec->{'Field'}}) {
$FldName = $ThisFld->{'OutputFieldName'};
next if $FldName eq "Sort"; # skip those
next if $FldName eq "XUID"; # skip those
$FldVal = $ThisFld->{'$TEXT$'} || "";
if ($FldName eq "XCOMP") {
$COMP = $FldVal;
next;
}
if ($FldName eq "XDVS") {
$DVS = $FldVal;
next;
}
if ($FldName eq "XGRPS") {
$GRPS = $FldVal;
next;
}
}
# Split the Variables
$DVref = {}; # ref to empty hash
@elems = split('\|\|\$',$DVS);
foreach $element (@elems) {
$element =~ m/^(\w+)\s+(.*)$/ or next;
$FldName = $1; $FldVal = $2;
log_msg(" var name : \"$FldName\", value : \"$FldVal\"") if $Debug>2;
$DVref->{$FldName} = $FldVal;
}
# Split the groups
$GRPref = [ split('\|\|\$',$GRPS) ]; # ref to that array
$ThisCon->{'-Company'} = $COMP;
$ThisCon->{'-Groups'} = $GRPref;
$ThisCon->{'-Vars'} = $DVref;
log_msg("<==XML_SetUserInfo(ok)") if $Debug >1;
$srv->{'DoDbPerms'} = $SaveDoDbPerms; # restore old setting
return 1;
}
sub ping {
########
# Check if a connection with Star is still alive.
# called as : result = srv->ping();
# returns : true if connection alive, false if not
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my %args = @_;
my $Debug = $srv->{'-Debug'};
my $result;
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my ($Ecount,$Emsg);
my $Msg;
my $ConId = $srv->{ConnectionId};
log_msg("==>ping()") if $Debug > 1;
return 0 unless $srv->{'-Active'}; # if it's not even marked as active ..
# else use a "GetConnectionInfo" call to find out
# Prepare the request table
# mandatory args
$XMLRequest = {
'Root' =>{
'GetConnectionInfo' =>{
'ConnectionId'=>$ConId,
},
},
};
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","getRecordLocked()");
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' => {
# 'GetConnectionInfo' => {
# 'ConnectionId' => "id",
# 'Version' => "version",
# 'Charset' => "charset",
# 'ecount' => "errorcount",
# 'emsg' => "error message",
# }, # /GetConnectionInfo
# }, # /Root
# }; # /XMLResponse
$Ecount = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'ecount'};
if ($Ecount && ($Ecount ne "0")) {
# Connection to Star is probably lost
$Emsg = $XMLResponse->{'Root'}->{'GetConnectionInfo'}->{'emsg'};
$Msg = "** Star Info request error : $Emsg **";
_setError($srv,ECAT_COM,6,'',"ERRCOM_06","ping()");
return undef;
}
log_msg("<==ping(ok)") if $Debug > 1;
return 1;
}
sub getXMLInfo {
##############
# Check Star XML connection, return Star XML version
# called as : result = srv->getXMLInfo();
# returns : version if connection alive, else undef
#
my $srv = shift;
#Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $Debug = $srv->{'-Debug'};
my $SERVER = $srv->{SERVER};
my $result;
my $XMLObj; # for XML::Simple object
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $Msg;
log_msg("==>getXMLInfo()") if $Debug > 1;
return undef unless ($SERVER && $SERVER->connected()); # can't succeed unless open socket
# request
$XMLRequest = {
'Root' =>{
'GetSTARXMLInfo' =>{ '-dummy' => "x"}
},
};
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
$Msg = emsg('XREQ_FAIL');
return undef;
}
# Expected response :
# XMLResponse --> {
# 'Root' => {
# 'GetSTARXMLInfo' => {
# 'Version' => "version",
# },
# }, # /Root
# }; # /XMLResponse
$result = $XMLResponse->{'Root'}->{'GetSTARXMLInfo'}->{'Version'};
return $result;
}
#
# Miscellaneous accessor routines
#
sub getDBPerms {
##############
# called as : $perms = $srv->getDBPerms(DbId=>database-id);
# returns :
# - undef if error
# - else permissions bitmask (which can be 0 !)
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my %args = @_;
my $Debug = $srv->{'-Debug'};
my $ThisDbId = $args{DbId} or Carp::croak "Missing argument DbId !";
my $DBs = $srv->{'-DBs'};
my $ThisDb;
return undef unless ($ThisDb = $DBs->{$ThisDbId});
return $ThisDb->{'-Perms'};
}
sub debug {
my $srv = shift;
my $newval = shift;
my $Debug = $srv->{'-Debug'};
$srv->{'-Debug'} = $newval if (defined($newval) && ($newval =~ m/^[0-9]$/));
return $Debug;
}
sub XMLdebug {
my $srv = shift;
my $newval = shift;
my $Debug = $srv->{'-XMLDebug'};
$srv->{'-XMLDebug'} = $newval if (defined($newval) && ($newval =~ m/^[0-9]$/));
return $Debug;
}
sub getLastXMLErrorResponse {
my $srv = shift;
return ($srv->{'-ErrLastResponse'} || '');
}
#################################
# Management functions
#################################
sub AnalyzeSpace {
################
# Get Space information
# called as : arrayref = srv->AnalyzeSpace($name_or_number);
# returns an array ref to ($spNb,$spName,$maxNb,$spAllocKB,$spFreeKB)
# or undef on error
#
# Request syntax: <AnalyzeSpace ConnectionId="conid" [SpaceName="spname"]
# [SpaceNumber="spno"]/>
# Response syntax: <AnalyzeSpace ConnectionId="conid" SpaceName="spname"
# [SpaceNumber="spno" MaxSpaceNumber="maxno" SpaceName="spname"
# SpaceAllocated="allocated" SpaceUsed="used" SpaceFree="free"]
# [ecount="ec" emsg="em"]/>
#
my $srv = shift;
Carp::confess "Invalid call !" unless (ref($srv) =~ /^STAR::API2::STARXMLUTF/);
my $NameOrNumber = shift;
Carp::confess "Invalid call !" unless ($NameOrNumber);
my $Msg;
my $Debug = $srv->{'-Debug'};
my $RetCode;
my ($spNb,$spName,$maxNb,$spAllocKB,$spFreeKB,$spUsedKB);
my ($Ecount,$Emsg);
my $XMLRequest; # out table for XML request to server
my $XMLResponse; # in table for parsed XML server response
my $ConId = $srv->{ConnectionId};
# Prepare the request
$XMLRequest = {
'Root' =>{
'AnalyzeSpace' =>{
'ConnectionId'=>$ConId,
},
'-dummy'=>"x",
},
};
if ($NameOrNumber =~ /^\d+$/) {
$spNb = $NameOrNumber; $spName = '';
$XMLRequest->{'Root'}->{AnalyzeSpace}->{SpaceNumber} = $spNb;
} else {
$spName = $NameOrNumber; $spNb = '';
$XMLRequest->{'Root'}->{AnalyzeSpace}->{SpaceName} = $spName;
}
# send the request
unless (defined($XMLResponse = XML_Request($srv,$XMLRequest,$srv->{XOB}))) {
# No return hash
_setError($srv,ECAT_COM,2,'',"ERRCOM_02","AnalyzeSpace()");
return undef;
}
$Ecount = $XMLResponse->{'Root'}->{'ecount'};
if ($Ecount ne "0") {
# The message is in the "emsg" attribute of <AnalyzeSpace>
$Emsg = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'emsg'};
if ($Emsg =~ /\[SSPNotFound\]/i) {
_setError($srv,ECAT_STAR,54,'',"ERRSTA_54","AnalyzeSpace() : ",$Emsg);
} else {
_setError($srv,ECAT_STAR,99,'',"ERRSTA_99",$Emsg);
}
return undef;
}
# Response syntax: <AnalyzeSpace ConnectionId="conid" SpaceName="spname"
# [SpaceNumber="spno" MaxSpaceNumber="maxno" SpaceName="spname"
# SpaceAllocated="allocated" SpaceUsed="used" SpaceFree="free"]
# [ecount="ec" emsg="em"]/>
$spNb = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'SpaceNumber'} || '';
$spName = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'SpaceName'};
$maxNb = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'MaxSpaceNumber'};
$spAllocKB = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'SpaceAllocated'} * 1024; # given in MB
$spFreeKB = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'SpaceFree'}; # is already in KB
$spUsedKB = $XMLResponse->{'Root'}->{'AnalyzeSpace'}->{'SpaceUsed'} * 1024; # given in MB
return [$spNb,$spName,$maxNb,$spAllocKB,$spFreeKB,$spUsedKB]; # return arrayref
}
#
# Error & message handling
#
sub error {
#########
# public
my $self = shift;
return undef unless $self->{'-ErrCat'};
return wantarray ? ($self->{'-ErrCat'},$self->{'-ErrCode'},$self->{'-ErrMsg'}) :
"($self->{'-ErrCat'}/$self->{'-ErrCode'}) $self->{'-ErrMsg'}";
}
sub _getError {
#############
# private, convenience
# retrieve error codes from STARXMLUTF object private vars and return to caller
# in a more usable form.
# Returns undef if there was no error (allows to test for if (srv->getError()) ..).
# Else returns an error structure such :
# { 'cat' => error category, # as per ECAT_xxx constants
# 'code' => error code, # 01-99
# 'msg' => error message, # as per emsg() sub
# }
my $self = shift;
return undef unless $self->{'-ErrCat'}; # no error if that one not set
return {
'cat' => $self->{'-ErrCat'},
'code' => $self->{'-ErrCode'},
'msg' => $self->{'-ErrMsg'},
};
}
sub _clearError {
###############
# private
my $self = shift;
$self->{'-ErrCat'} = 0;
$self->{'-ErrCode'} = 0;
$self->{'-ErrSys'} = 0;
$self->{'-ErrMsg'} = '';
$self->{'ErrLastResponse'} = '';
}
sub _setError {
#############
# private, convenience
# called as : _setError($self,$cat,$code,$syserr,$msgkey,....)
# will not set error codes if already set, but will append message if any
my $self = shift;
my ($cat,$code,$syserr,$msgkey) = @_;
unless ($self->{'-ErrCat'}) {
$self->{'-ErrCat'} = $cat;
$self->{'-ErrCode'} = $code;
$self->{'-ErrSys'} = $syserr;
}
$self->{'-ErrMsg'} .= "; " . emsg($self->{LANG},$msgkey,@_);
return 1;
}
sub emsg {
########
# return error message indexed by language/key, inserting optional params
my $elang = shift;
my $ekey = shift;
# the rest in @_ is insertable params
my $fmt = $EMSGS->{"${ekey}_${elang}"} || $EMSGS->{"${ekey}_en"} || "(missing message) ($ekey) : %s %s %s %s %s";
return @_ ? sprintf($fmt,@_) : $fmt;
}
#
# Definitely private routines
#
sub _parse_dsn {
##############
# parses dsn string and returns hash
my $dsn = shift;
# - $dsn is a string of the format : "starxml:xxx@host[:port]"
# where :
# - "starxml:" is fixed
# - xxx is either the word "new" (for a new connection),
# or the connection-id of an existing (persistent) connection (starting with "CON")
# - host[:port] : DNS name (and optionally port) of the Star XML server host
die "missing or empty argument" unless $dsn;
my $port = '';
my $host = '';
my ($con,$hostport);
if ($dsn =~ m/^starxml:(.*?)\@(.*)$/) {
$con = $1;
$hostport = $2;
}
return undef unless (defined $con && defined $hostport);
$con = uc $con;
if ($hostport =~ m/(.*?):(\d{1,5})/) {
$host = $1; $port = $2;
} else {
$host = $hostport;
}
$port = '' unless $port;
return undef unless $con =~ m/^(NEW|CON.+)$/;
return {
'ConId' => $con eq "NEW" ? undef : $con,
'Host' => $host,
'Port' => $port,
};
}
sub XML_Request {
###############
my $pfx = 'XML_Request()';
# internal-use only
# Post an XML request from a "request hash" and get the parsed answer back in a "response hash"
# Called as : $XMLResponse = XML_Request($con,$XMLRequest);
# or : $XMLResponse = XML_Request($con,$XMLRequest,$XMLSimpleObject);
# or : $XMLResponse = XML_Request($con,$XMLRequest,$XMLSimpleObject,$XMLInOptions,$XMLOutOptions);
# where :
# Return value :
# - undef if there was an error (for example a communications problem).
# In that case, error codes are set in the connection object.
# note : a Star XML "ecount <> 0" is not here considered as an error.
# - else a ref. to a hash containing the parsed XML response
#
# Input arguments :
# - $con : ref. to main Server table
# - $XMLRequest : ref to hash structure representing the request
# - $XMLSimpleObject, is an optional XML::Simple object.
# If supplied, it will be used to send the request and parse the result
# into $XMLResponse.
# If not supplied, we use the one in $con->{'XOB'}.
# - $XMLInOptions, is an optional ref. to a hash of options for $XMLin()
# - $XMLOutOptions, is an optional ref. to a hash of options for $XMLout()
# - $XMLCmd : optionally, the StarXML command that this is.
# (used for UpdateRecord, to strip <Field> sections from response)
#
my ($con,$Request,$XMLObj,$InOptions,$OutOptions,$XMLCmd) = @_;
# farm this out to the UTF-8-only sub if we can
if ($con->{'-AllUTF'}) {
return XML_RequestUTF($con,$Request,$XMLObj,$InOptions,$OutOptions,$XMLCmd);
}
my $Debug = $con->{'-Debug'};
my $SERVER; # the server socket
my $XMLSent; # what we're going to send
my $SentSize;
my $XMLRcvd; # what the server will answer
my $RcvdSize;
my $Msg;
my ($Response,$RespErr);
my ($RcvBuf,$CntRead);
my ($Idx,$More,$Len,$StartPos);
my $ServerTrash;
my $ServerCharset;
my $XMLHDR;
log_msg("==>$pfx") if $Debug > 1;
_clearError($con);
$XMLObj = $con->{'XOB'} unless defined $XMLObj; # take standard one if not provided
$SERVER = $con->{'SERVER'}; # get the server socket/fh/object
unless ($SERVER->connected()) {
_setError($con,ECAT_COM,1,'',"ERRCOM_01");
return undef;
}
$ServerCharset = $con->{'STARCharset'} || 'iso-8859-1'; # revise later ?
log_msg("server charset: $ServerCharset") if $Debug > 2;
log_msg("STAR XML version: $con->{XMLVersion}") if $Debug > 2;
dump_Tbl($Request,"Request table (before encode)") if $Debug>3;
if ($con->{'XMLVersion'} < 2) {
$XMLHDR = "<?xml version=\"1.0\" encoding=\"$ServerCharset\" ?>";
# compose the XML request
if (defined($OutOptions)) {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$XMLHDR,%$OutOptions);
} else {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$XMLHDR);
}
log_msg("encoding request to charset [$ServerCharset]") if $Debug > 2;
$XMLSent = encode($ServerCharset, $XMLSent);
} else {
$XMLHDR = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>";
if (defined($OutOptions)) {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$XMLHDR,%$OutOptions);
} else {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$XMLHDR);
}
}
{
# Note : this block uses the pragma "use bytes".
# This is important in case the StarXML version is 2.0+, because in that case what we are sending
# is really a UTF-8 encoded string buffer with the "utf8" flag on.
# The syswrite() call below dies with a "wide character in syswrite" if we attempt to write a character
# that is really more than 1 byte long, because the SERVER handle is opened in "byte" mode.
# Specifying "use bytes" temporarily turns off Perl's smart handling of UTF-8 strings, and makes it see
# them as byte strings, without altering their contents.
# And if the buffer is already made of bytes, it has no effect anyway.
use bytes;
$SentSize = length($XMLSent);
log_msg("Sending (encoded) request ($SentSize bytes) :\n$XMLSent\n") if $con->{'-XMLDebug'};
# Now we can send the request
$XMLSent .= EOX; # add end-of-message
unless (syswrite($SERVER,Encode::encode('UTF-8', $Request))) {
_setError($con,ECAT_COM,3,$!,"ERRCOM_03",$!);
return undef;
}
}
log_msg("Request sent.") if $Debug >1;
log_msg("Getting server response ...") if $Debug >1;
RESP:{
$XMLRcvd = ""; $RcvdSize = 0;
while (1) { #1 While there is something to read...
$CntRead = sysread($SERVER,$RcvBuf,SRV_READSIZE); # read header
Encdode::decode('UTF-8', $RcvBuf);
unless (defined($CntRead)) {
$Msg = "ERRCOM_04 : Premature EOF";
log_msg($Msg) if $Debug>1;
_setError($con,ECAT_COM,4,$!,"ERRCOM_04",$!);
return undef;
}
# an EOF before an EOX is also abnormal here
unless ($CntRead) {
$Msg = "ERRCOM_05 : Premature EOF";
log_msg($Msg) if $Debug>1;
_setError($con,ECAT_COM,5,'',"ERRCOM_05","Premature EOF");
return undef;
}
# keep track of total bytes received so far
$RcvdSize += $CntRead;
# # log_msg(" read $CntRead bytes, $RcvdSize so far ..") if $Debug>1;
# # log_msg(" read buffer : \"$RcvBuf\"") if $Debug >2;
# Did we get an EOX ? (Star XML's way of indicating end of response)
# $Idx = index($RcvBuf,EOX,0); # position where we find EOX, -1 if not found
# Try to optimise the above : the EOX should normally be toward the end of what
# we read. $CntRead gives the length of the $RcvBuf that we read.
$StartPos = ($CntRead > 32) ? ($CntRead - 32) : 0;
$Idx = index($RcvBuf,EOX,$StartPos); # position where we find EOX, -1 if not found
if ($Idx >= 0) {
log_msg(" found EOX at position $Idx") if $Debug > 3;
# yes, save the data and exit read loop
$RcvBuf = substr($RcvBuf,0,$Idx); # get rid of everything after EOX
$XMLRcvd .= $RcvBuf;
last;
}
$XMLRcvd .= $RcvBuf; # accumulate data and loop
} # while 1
log_msg("Response is " . length($XMLRcvd) . " bytes.") if $Debug > 1;
# Starting with StarXML 4.4.4, the response comes back using the same encoding as the one used for the
# request (or always as UTF-8 maybe).
# e.g. <?xml version="1.0" encoding="UTF-8" standalone="no"?>
# e.g. <?xml version="1.0" encoding="ISO-8859-1"?>
# We need to take this into account, and decode it appropriately.
# Note : the best way is probably to not strip the <?xml> declaration anymore, like we do below,
# and just let XML::Simple deal with it.
my $res_encoding = 'utf8'; # the default
my $xml_tag = substr($XMLRcvd,0,255);
if ($xml_tag =~ m/<\?xml[^>]*\sencoding=\"([^"]+)\"/) {
my $enc = $1;
if ($enc !~ m/utf\-8/i) {
$res_encoding = $enc;
}
}
log_msg("Response encoding evaluated as [$res_encoding]") if $Debug > 2;
# decode the response to make it a perl string
eval { $XMLRcvd = decode($res_encoding,$XMLRcvd)};
if ($@) {
# decoding problem, fatal
$Msg = "response cannot be decoded : $@";
log_msg($Msg) if $Debug;
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
log_msg("Response contents :\n${XMLRcvd}\n") if $con->{'-XMLDebug'};
# Strip anything before the <Root> tag, and after the </Root> tag
$XMLRcvd =~ s/<\/Root>.*$/<\/Root>/s;
$Idx = index($XMLRcvd,"<Root>",0);
$XMLRcvd = substr($XMLRcvd,$Idx) if ($Idx > 0);
$RcvdSize = length($XMLRcvd);
if ($RcvdSize == 0) {
$Msg = "cleaned-up response is null";
log_msg($Msg) if $Debug;
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
if ($RcvdSize > MAXXML) {
$Msg = "cleaned-up response size exceeds MAXXML : $RcvdSize";
log_msg($Msg) if $Debug;
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
} # end RESP
if ($con->{'StoreLastErr'}) {
# save the entire StarXML response, for possible debugging later.
# This can be very large, so it should be used sparingly.
$con->{'-ErrLastResponse'} = $XMLRcvd;
}
if ((defined $XMLCmd) && ($XMLCmd eq 'UpdateRecord')) {
# strip the <Field> sections from the response before parsing
log_msg("Stripping <Field> sections from response") if $Debug>2;
$XMLRcvd =~ s/<Field[^>]+>.+<\/Field>//sg; # greedy will take them all ?
log_msg("Response contents before parse :\n${XMLRcvd}\n") if $Debug>3;
}
# Parse the XML response
if (defined($InOptions)) {
eval {$Response = $XMLObj->XMLin($XMLRcvd,%$InOptions)};
} else {
eval {$Response = $XMLObj->XMLin($XMLRcvd)};
}
if ($@) {
$Msg = "ERRXML_01 : " . $@;
log_msg("$pfx: $Msg") if $Debug;
_setError($con,ECAT_XML,1,'',"ERRXML_01","$@");
return undef;
}
dump_Tbl($Response,"Parsed response hash : ") if $Debug>3;
log_msg("<==XML_Request(ok)") if $Debug > 1;
# return latin1ise($Response);
return $Response;
}
sub XML_RequestUTF {
my $pfx = 'XML_RequestUTF()';
# internal-use only
# This sub should only be used when we *know* that the system being talked to is Star v5 or higher,
# and the request/response is UTF-8 encoded.
# Post an XML request from a "request hash" and get the parsed answer back in a "response hash"
# Called as : $XMLResponse = XML_Request($con,$XMLRequest);
# or : $XMLResponse = XML_Request($con,$XMLRequest,$XMLSimpleObject);
# or : $XMLResponse = XML_Request($con,$XMLRequest,$XMLSimpleObject,$XMLInOptions,$XMLOutOptions);
# where :
# Return value :
# - undef if there was an error (for example a communications problem).
# In that case, error codes are set in the connection object.
# note : a Star XML "ecount <> 0" is not here considered as an error.
# - else a ref. to a hash containing the parsed XML response
#
# Input arguments :
# - $con : ref. to main Server table
# - $XMLRequest : ref to hash structure representing the request
# - $XMLSimpleObject, is an optional XML::Simple object.
# If supplied, it will be used to send the request and parse the result
# into $XMLResponse.
# If not supplied, we use the one in $con->{'XOB'}.
# - $XMLInOptions, is an optional ref. to a hash of options for $XMLin()
# - $XMLOutOptions, is an optional ref. to a hash of options for $XMLout()
# - $XMLCmd : optionally, the StarXML command that this is.
# (used for UpdateRecord, to strip <Field> sections from response)
#
my ($con,$Request,$XMLObj,$InOptions,$OutOptions,$XMLCmd) = @_;
my $Debug = $con->{'-Debug'};
my $SERVER; # the server socket
my $XMLSent; # what we're going to send
my ($SentChars,$SentBytes);
my $XMLRcvd; # what the server will answer
my $RcvdSize;
my $Msg;
my ($Response,$RespErr);
my ($RcvBuf,$CntRead);
my ($Idx,$More,$Len,$StartPos);
my $ServerTrash;
log_msg("==>$pfx") if $Debug > 1;
_clearError($con);
$XMLObj = $con->{'XOB'} unless defined $XMLObj; # take standard one if not provided
$SERVER = $con->{'SERVER'}; # get the server socket/fh/object
unless ($SERVER->connected()) {
_setError($con,ECAT_COM,1,'',"ERRCOM_01");
return undef;
}
log_msg("$pfx: STAR XML version [" . $con->{XMLVersion} . "]") if $Debug > 2;
dump_Tbl($Request,"$pfx: Request table") if $Debug>3;
if (defined($OutOptions)) {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$con->{'-XMLHDR'},%$OutOptions);
} else {
$XMLSent = $XMLObj->XMLout($Request,'xmldecl'=>$con->{'-XMLHDR'});
}
# we can get rid of the former "use bytes" block, since we know that the server handle
# has the perlio 'utf8 layer' built-in
{
use bytes;
# just for debugging, we want to know how many *bytes* that is though.
# "use bytes" temporarily turns off perl's 'utf8' flag interpretation, which would make it
# count characters instead of bytes. Just within this block.
$SentBytes = length($XMLSent);
}
$SentChars = length($XMLSent);
log_msg("Sending request, size[$SentBytes bytes / $SentChars chars]:[$XMLSent]") if $con->{'-XMLDebug'};
$XMLSent .= EOX; # add end-of-message
if ($con->{'-SaveLastRequest'}) {
$con->{'-LastRequestBuf'} = $XMLSent;
}
unless (print $SERVER $XMLSent) {
_setError($con,ECAT_COM,3,$!,"ERRCOM_03",$!);
return undef;
}
log_msg("Request sent, getting server response ....") if $Debug >1;
RESP:{
# temporarily disable warnings here for the sysread() under perl 5.24+.
# We need to change this to read(), but need time to figure out the possible effects.
no warnings 'deprecated';
$XMLRcvd = ""; $RcvdSize = 0;
while (1) { #1 While there is something to read...
$CntRead = sysread($SERVER,$RcvBuf,SRV_READSIZE); # read header
Encode::decode('UTF-8', $RcvBuf);
unless (defined($CntRead)) {
$Msg = "ERRCOM_04";
log_msg($Msg) if $Debug;
_setError($con,ECAT_COM,4,$!,"ERRCOM_04",$!);
return undef;
}
# an EOF before an EOX is also abnormal here
unless ($CntRead) {
$Msg = "ERRCOM_05 : Premature EOF";
log_msg($Msg) if $Debug;
_setError($con,ECAT_COM,5,'',"ERRCOM_05","Premature EOF");
return undef;
}
log_msg(" received $CntRead bytes") if $Debug > 3;
# keep track of total chars received so far
$RcvdSize += $CntRead;
# # log_msg(" read $CntRead bytes, $RcvdSize so far ..") if $Debug>1;
# # log_msg(" read buffer : \"$RcvBuf\"") if $Debug >2;
# Did we get an EOX ? (Star XML's way of indicating end of response)
# $Idx = index($RcvBuf,EOX,0); # position where we find EOX, -1 if not found
# Try to optimise the above : the EOX should normally be toward the end of what
# we read. $CntRead gives the length of the $RcvBuf that we read.
$StartPos = ($CntRead > 32) ? ($CntRead - 32) : 0;
$Idx = index($RcvBuf,EOX,$StartPos); # position where we find EOX, -1 if not found
if ($Idx >= 0) {
log_msg(" found EOX at position $Idx") if $Debug > 3;
# yes, save the data and exit read loop
$RcvBuf = substr($RcvBuf,0,$Idx); # get rid of everything after EOX
$XMLRcvd .= $RcvBuf;
last;
}
$XMLRcvd .= $RcvBuf; # accumulate data and loop
} # while 1
log_msg("$pfx: Response received, size[" . length($XMLRcvd) . " chars]") if $Debug > 1;
log_msg("$pfx: Response contents [$XMLRcvd]") if $con->{'-XMLDebug'};
if ($con->{'-SaveLastResponse'}) {
$con->{'-LastResponseBuf'} = $XMLRcvd;
}
# This sub is used only with Star >= 5.x, so we *know* that the response is UTF-8.
# and we do not need to check
# Strip anything before the <Root> tag, and after the </Root> tag
$XMLRcvd =~ s/<\/Root>.*$/<\/Root>/s;
$Idx = index($XMLRcvd,"<Root>",0);
$XMLRcvd = substr($XMLRcvd,$Idx) if ($Idx > 0);
$RcvdSize = length($XMLRcvd);
if ($RcvdSize == 0) {
$Msg = "cleaned-up response is null";
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
if ($RcvdSize > MAXXML) {
$Msg = "cleaned-up response size exceeds MAXXML : $RcvdSize";
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
} # end RESP
if ($con->{'StoreLastErr'}) {
# save the entire StarXML response, for possible debugging later.
# This can be very large, so it should be used sparingly.
$con->{'-ErrLastResponse'} = $XMLRcvd;
}
if ((defined $XMLCmd) && ($XMLCmd eq 'UpdateRecord')) {
# strip the <Field> sections from the response before parsing
log_msg("$pfx: Stripping <Field> sections from response") if $Debug>2;
$XMLRcvd =~ s/<Field[^>]+>.+<\/Field>//sg; # greedy will take them all ?
log_msg("$pfx: Response contents before parse [$XMLRcvd]") if $Debug>3;
}
# Parse the XML response
if (defined($InOptions)) {
eval {$Response = $XMLObj->XMLin($XMLRcvd,%$InOptions)};
} else {
eval {$Response = $XMLObj->XMLin($XMLRcvd)};
}
if ($@) {
$Msg = "ERRXML_01 : " . $@;
log_msg("$pfx: $Msg") if $Debug;
_setError($con,ECAT_XML,1,'',"ERRXML_01","$@");
return undef;
}
dump_Tbl($Response,"Parsed response hash : ") if $Debug>3;
log_msg("<==$pfx(ok)") if $Debug > 1;
return $Response;
}
sub XML_Request_String {
######################
# internal-use only
# Post an XML request from a "request string" and get the parsed answer back in a "response hash"
# This is similar to the standard XML_request(), except that instead of receiving the request
# as a hash, the request is already properly formatted as a string buffer.
# Called as : $XMLResponse = XML_Request($con,$XMLRequest);
# where :
# Return value :
# - undef if there was an error (for example a communications problem).
# In that case, error codes are set in the connection object.
# note : a Star XML "ecount <> 0" is not here considered as an error.
# - else a ref. to a hash containing the parsed XML response
#
# Input arguments :
# - $con : ref. to main Server table
# - $XMLRequest : string containing the request
#
my $con = shift;
my ($Request,$XMLObj) = @_;
my $Debug = $con->{'-Debug'};
my $SERVER; # the server socket
my $XMLSent; # what we're going to send
my $SentSize;
my $XMLRcvd; # what the server will answer
my $RcvdSize;
my $Msg;
my ($Response,$RespErr);
my ($RcvBuf,$CntRead);
my ($Idx,$More,$Len,$StartPos);
my $ServerTrash;
my $ServerCharset;
log_msg("==>XML_Request_String()") if $Debug > 1;
_clearError($con);
$XMLObj = $con->{'XOB'} unless defined $XMLObj; # take standard one if not provided
$SERVER = $con->{'SERVER'}; # get the server socket/fh/object
unless ($SERVER->connected()) {
_setError($con,ECAT_COM,1,'',"ERRCOM_01");
return undef;
}
# Same remarks apply about what we receive and what we send
dump_Tbl($Request,"Request table (before encode)") if $Debug>3;
$ServerCharset = $con->{'STARCharset'} || 'iso-8859-1'; # revise later ?
# Note: with StarXML 2.0+, we bypass the kludge below, and assume that StarXML
# processes requests correctly, in the encoding we are sending.
if ($con->{'XMLVersion'} < 2) {
$Request = encode($ServerCharset, $Request);
# now it is 8-bit chars, and correct in it's respective iso alphabet
# but now we make it possibly wrong in UTF-8, by lying to Perl
$Request = decode('iso-8859-1', $Request);
# but the result is a UTF-8 string which, when decoded by Star XML into (what it thinks is) iso-8859-1,
# will give a string of characters/bytes with the values that the Star system expects.
# At least we hope that it is what happens...
}
{
# Note : this block uses the pragma "use bytes".
# This is important in case the StarXML version is 2.0+, because in that case what we are sending
# is really a UTF-8 encoded string buffer with the "utf8" flag on.
# The syswrite() call below dies with a "wide character in syswrite" if we attempt to write a character
# that is really more than 1 byte long, because the SERVER handle is opened in "byte" mode.
# Specifying "use bytes" temporarily turns off Perl's smart handling of UTF-8 strings, and makes it see
# them as byte strings, without altering their contents.
# And if the buffer is already made of bytes, it has no effect anyay.
use bytes;
$SentSize = length($Request);
log_msg("Sending (encoded) request ($SentSize bytes) :\n$Request\n") if $con->{'-XMLDebug'};
# Now we can send the request
$Request .= EOX; # add end-of-message
unless (syswrite($SERVER,Encode::encode('UTF-8', $Request))) {
_setError($con,ECAT_COM,3,$!,"ERRCOM_03",$!);
return undef;
}
}
log_msg("Request sent.") if $Debug >1;
log_msg("Getting server response ...") if $Debug >1;
RESP:{
$XMLRcvd = ""; $RcvdSize = 0;
while (1) { #1 While there is something to read...
$CntRead = sysread($SERVER,$RcvBuf,SRV_READSIZE); # read header
Encode::decode('UTF-8', $RcvBuf);
unless (defined($CntRead)) {
_setError($con,ECAT_COM,4,$!,"ERRCOM_04",$!);
return undef;
}
# an EOF before an EOX is also abnormal here
unless ($CntRead) {
_setError($con,ECAT_COM,5,'',"ERRCOM_05","Premature EOF");
return undef;
}
# keep track of total bytes received so far
$RcvdSize += $CntRead;
# # log_msg(" read $CntRead bytes, $RcvdSize so far ..") if $Debug>1;
# # log_msg(" read buffer : \"$RcvBuf\"") if $Debug >2;
# Did we get an EOX ? (Star XML's way of indicating end of response)
# $Idx = index($RcvBuf,EOX,0); # position where we find EOX, -1 if not found
# Try to optimise the above : the EOX should normally be toward the end of what
# we read. $CntRead gives the length of the $RcvBuf that we read.
$StartPos = 0;
$StartPos = ($CntRead - 32) if ($CntRead > 32); # start at end of buffer - 32
$Idx = index($RcvBuf,EOX,$StartPos); # position where we find EOX, -1 if not found
if ($Idx >= 0) {
# yes, save the data and exit read loop
$XMLRcvd .= $RcvBuf;
last;
}
$XMLRcvd .= $RcvBuf; # accumulate data and loop
} # while 1
log_msg("Received $RcvdSize bytes.") if $Debug > 1;
log_msg("Response contents :\n${XMLRcvd}\n") if $con->{'-XMLDebug'};
# Strip anything before the <Root> tag, and after the </Root> tag
$XMLRcvd =~ s/<\/Root>.*$/<\/Root>/s;
$Idx = index($XMLRcvd,"<Root>",0);
$XMLRcvd = substr($XMLRcvd,$Idx) if ($Idx > 0);
if ($RcvdSize == 0) {
$Msg = "cleaned-up response is null";
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
if ($RcvdSize > MAXXML) {
$Msg = "cleaned-up response size exceeds MAXXML : $RcvdSize";
_setError($con,ECAT_COM,5,'',"ERRCOM_05",$Msg);
return undef;
}
} # end RESP
if ($con->{'StoreLastErr'}) {
# save the entire StarXML response, for possible debugging later.
# This can be very large, so it should be used sparingly.
$con->{'-ErrLastResponse'} = $XMLRcvd;
}
# Parse the XML response
eval {$Response = $XMLObj->XMLin($XMLRcvd)};
if ($@) {
_setError($con,ECAT_XML,1,'',"ERRXML_01","$@");
return undef;
}
log_msg("<==XML_Request_String(ok)") if $Debug > 1;
# return latin1ise($Response);
return $Response;
}
sub _XML_id {
# Return a unique id
# New sub using a connection-based counter
my $srv = shift; # the "Star connection" object
my $Prefix = shift || ''; # a prefix for the returned id
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
my $unique_suffix = $srv->{'-NextId'};
if ($unique_suffix == 999999) {
$srv->{'-NextId'} = 0;
} else {
$srv->{'-NextId'} = $unique_suffix + 1;
}
return $Prefix . sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec) . sprintf("%06d",$unique_suffix);
}
sub XML_id {
# Return a unique id
# Note : this is the old and obsolete sub, which triggers a problem with rand() on some platforms (*).
# Code calling this should be changed, to call "_XML_id(connection,prefix)" instead.
# This sub is only left here temporarily, in case there are calls to it from outside the STARXMLUTF module.
my $Prefix = shift || '';
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
# (*) modify the following anyway, to try to overcome the issue (MS Win32 only has 15 bits of "randomness")
#return $Prefix . sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec) . sprintf("%06d",int(rand 999999));
return $Prefix . sprintf("%04d%02d%02d%02d%02d%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec) . sprintf("%03d",int(rand 999)) . sprintf("%03d",int(rand 999));
}
sub log_msg {
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
my $logtime = sprintf("%04d/%02d/%02d-%02d:%02d:%02d",$year+1900,$mon+1,$mday,$hour,$min,$sec);
warn "$logtime : " . join(" ",@_);
return 1;
}
sub dump_Tbl {
my $Ref = shift;
my $Lab = shift || 'REF';
$Data::Dumper::Indent = 1;
my $Dumped = Data::Dumper::Dumper($Ref);
warn "dump of $Lab :\n" . $Dumped;
}
# Convenience subs, non-OO
sub make_xml_conform {
my $field_value = shift;
# escape &
$field_value =~ s/&/&/g;
# escape '
$field_value =~ s/'/'/g;
# escape <
$field_value =~ s/</</g;
return $field_value;
}
sub process_carets {
my ($occ) = @_;
$occ =~ s/\^B//g;
$occ =~ s/\^N//g;
$occ =~ s/\^L/\x0D\x0A/g;
return $occ;
}
sub concat_occs {
my ($fld,$sep,$list) = @_;
# $fld is a ref to an array of occurrence values
$sep = ';' unless defined $sep;
$list = '' unless defined $list;
return undef unless defined $fld;
unless (ref($fld) eq 'ARRAY') {
$fld = [ $fld ];
}
foreach my $occ (@$fld) {
if ($list eq '') {
$list = $occ;
} else {
$list .= $sep . $occ;
}
}
return $list;
}
sub only_subfields {
my ($occ,$sub_labels,$sep) = @_;
# $sub_labels is a string composed of the subfield labels that we want. "_" is the first unlabeled subfield.
# If multiple subfields are specified, there are returned concatenated by $sep if supplied, else a space
return $occ if ($occ eq ''); # no need for all this work then
$sub_labels = '_' unless defined $sub_labels; # by default, only first unlabeled subfield
$sep = ' ' unless defined $sep; # by default, join char is space
my $value = ''; # returned value
my $subs_hash = {};
my @wanted_labels = split(//,$sub_labels); # splits into single chars ?
my @subfields = split(/\|/,$occ);
$subs_hash->{'_'} = shift(@subfields); # the first unlabeled subfield
foreach my $sub_part (@subfields) {
my $sub_lab = substr($sub_part,0,1); # subfield label
my $sub_val = substr($sub_part,2); # subfield value
$sub_val =~ s/^\s*//; $sub_val =~ s/\s*$//;
$subs_hash->{$sub_lab} = $sub_val;
}
foreach (@wanted_labels) {
if (exists($subs_hash->{$_})) {
$value .= $sep . $subs_hash->{$_};
}
}
$value =~ s/^$sep//; # strip the leading separator
return $value;
}
sub sprintf_subfields {
my ($occ,$sub_labels,$mask) = @_;
# $occ is the field occurence content, with subfields
# $sub_labels is a string composed of the subfield labels that we want. "_" is the first unlabeled subfield.
# $mask is a format-string, sprintf()-like
# If the $occ value does not contain one of the subfields indicated in the $sub_labels list, this value is
# replaced by an empty string.
return $occ if ($occ eq ''); # no need for all this work then
$mask = '%s' unless defined $mask;
$sub_labels = '_' unless defined $sub_labels; # by default, only first unlabeled subfield
my $value = ''; # returned value
my $subs_hash = {};
my @wanted_labels = split(//,$sub_labels); # splits into single chars ?
my @subfields = split(/\|/,$occ); # split the occurrence on '|'
$subs_hash->{'_'} = shift(@subfields); # the first unlabeled subfield
foreach my $sub_part (@subfields) {
my $sub_lab = substr($sub_part,0,1); # the leading char = the subfield label
my $sub_val = substr($sub_part,2); # the rest of the value, skipping the leading space
$sub_val =~ s/^\s*//; $sub_val =~ s/\s*$//; # strip leading and trailing spaces
$subs_hash->{$sub_lab} = $sub_val;
}
# Create an array of the subfield values in the sequenc given.
# If a value is not found in the hash, it is replaced by an empty string value.
my @vals = ();
for my $lab (@wanted_labels) {
my $wanted_val = $subs_hash->{$lab} || '';
push(@vals,$wanted_val);
}
return sprintf($mask,@vals);
}
1;
__END__
=pod
=head1 STARXMLUTF.pm : Parent class for STARXMLUTF objects
.
=head1 Author
A. Warnier, ICE
2006/03/12 (from STARXML.pm)
=head1 Synopsis
=head1 Revisions
=over 4
0.1 : initial version, 2004/04/02 (STARXML.pm)
2.0 : first STARXMLUTF version
=back
=head1 Description
=head2 Development notes
=head3 Dates/time stamps
To compare date/time stamps, the module currently assumes that all sides are on the same timezone and use
local times. However, since the point of Star XML is to be able to connect to Star systems wherever they are,
sooner or later the issue of date/time discrepancies will appear. It would thus be better to save timestamps
relative to GMT. This raises the issue of the timestamps stored in Star itself however, which are not
GMT-oriented.
This either the timestamps stored in Star records need to be GMT-based (which seems unlikely to happen soon), or
Star XML should provide some information as to what is the local timezone of the Star system, and then we could
do the conversions in this module.
=head2 Error codes (to be revisited)
General : 0 = no error
Comm Errors (ComErr) :
1 connection to server lost
2 server read error
3 server write error
99 Other error
XML Errors (XMLErr) :
1 invalid/malformed response
2 reponse parsing error
99 Other error
Star (and pseudo-Star) Errors (StarErr) :
1 Star not available (off)
99 Other error
=head3 System errors
These are errors happening at the "system" level, such as "file not found" etc..,
which cause a STARXML function to abort.
=head3 STARXML errors
These are errors happening at the level of STARXMLUTF.pm, such as for instance when
for some reason a request sent to the XML server through a socket does not succeed
because of a communications failure.
STARXML errors are posted to $srv->{ErrCode/ErrMsg}.
Currently defined codes are :
=over 4
=item 1
Star-level error. See further error code/description in $srv->{StarErr/StarMsg}
=item 2
System-level error. See further error code/description in $srv->{SysErr/SysMsg}
=item 10
Communications error with the XML server (no response to a request)
=item 11
The Connection-id provided is not valid or the corresponding connection is not open.
=item 12
The database-id provided is not valid or the corresponding database is not open.
=back
=head3 Star errors
These are not always errors, but can be failure codes sent back by Star as answer
to an otherwise valid request. An example of that would be an invalid login-id.
At the moment, Star does not report error codes, only error messages, which will
be found in $srv->{StarMsg}.
=head1 COPYRIGHT
Copyright 2004-2099 Andre Warnier
=cut