ARSperl
view release on metacpan or search on metacpan
$ARS::VERSION = '2.00';
$ARS::DEBUGGING = 0;
$ARS::logging_file_ptr = 0;
# definitions required for backwards compatibility
if (!defined &ARS::AR_IMPORT_OPT_CREATE) {
eval 'sub AR_IMPORT_OPT_CREATE { 0; }';
}
if (!defined &ARS::AR_IMPORT_OPT_OVERWRITE) {
eval 'sub AR_IMPORT_OPT_OVERWRITE { 1; }';
}
bootstrap ARS $ARS::VERSION;
tie $ARS::ars_errstr, ARS::ERRORSTR;
# This HASH is used by the ars_GetServerStatistics call.
# Refer to your ARS API Programmer's Manual or the "ar.h"
# file for an explaination of what each of these stats are.
#
# Usage of this hash would be something like:
unsigned int tcpport
unsigned int rpcnumber
CODE:
{
int ret = 0, s_ok = 1;
int staticParams = 7;
ARStatusList status;
ARServerNameList serverList;
ARControlStruct *ctrl;
#ifdef PROFILE
struct timeval tv;
#endif
DBG( ("ars_Login(%s, %s, %s, %s, %s, %d, %d)\n",
SAFEPRT(server),
SAFEPRT(username),
SAFEPRT(password),
SAFEPRT(lang),
SAFEPRT(authString),
tcpport,
rpcnumber)
ARS/CodeTemplate.pm view on Meta::CPAN
my( $input ) = @_;
my @input = split( /\n/, $input );
my( $pFlag, $pCode, $output ) = ( 0, '', '' );
my $line;
foreach $line ( @input ){
if( $line =~ /^@@\s+(\S+)\s+(.*)$/ ){
my( $openMode, $outFile ) = ( $1, $2 );
if( $outFile =~ /^<@(.*)@>\s*$/ ){
eval( 'package '.caller()."; \$outFile = $1; package ARS::CodeTemplate;" );
# print "OUTFILE: $outFile\n";
}
# print "OM($openMode) FILE($outFile)\n";
die "Syntax error in \"$line\"\n" unless $openMode =~ /^[>|]+$/;
if( defined $opt{debug} ){
print "#------------------------------------------------------------\n";
print "# OUTPUT: $line\n";
print $pCode;
print "#------------------------------------------------------------\n\n";
}else{
eval( 'package '.caller()."; $pCode; package ARWT::Template;" );
if( $@ ){
warn $@, "\n";
exit 1;
}
open( OUTPUT, "$openMode $outFile" ) or die "Open Error($openMode $outFile): $!\n";
print OUTPUT $output;
close OUTPUT;
}
( $pFlag, $pCode, $output ) = ( 0, '', '' );
}elsif( $line =~ s/^@>+// ){
ARS/CodeTemplate.pm view on Meta::CPAN
}
}
}
}
}
if( defined $opt{debug} ){
print $pCode;
exit;
}else{
eval( 'package '.caller()."; $pCode; package ARWT::Template;" );
if( $@ ){
warn $@, "\n";
exit 1;
}
}
return $output;
}
use Getopt::Long;
ARS/CodeTemplate.pm view on Meta::CPAN
};
my $data = <FILE>;
close FILE;
return $data;
}
sub modByRegex {
package main;
my( $val, @regex ) = @_;
foreach my $regex ( @regex ){
eval "\$val =~ $regex";
warn $@, "\n" if $@;
}
return $val;
}
sub get_header {
my( $of, $tpt ) = @_;
my $HEADER = << "+";
(TS) fixed SignalTypeMap problem
(TS) package directory reorganization/cleanup
(TS) additional ars_Login parameters by Conny Martin
(TS) implemented ars_GetList/Get/Create/Set/DeleteImage
(TS) fixed incorrect AR_ARITH_OP_NEGATE handling in rev_ARArithOpStruct
(TS) fixed wrong operand evaluation for AR_ARITH_OP_NEGATE in perl_ARArithOpStruct
(TS) fixed ars_SetServerInfo() memory violation in case of more than one key/value pair
(TS) ars_GetFieldTable performance improvement by using ARGetMultipleFields
(TS) removed unnecessary second invocation of ARGetField in ars_GetField
(TS) code cleanup (#ifdef statements) in ARGetFieldCached, ars_GetField, ars_GetFieldByName
(TS) ! appended ARControlStruct pointer address to server key in %ARS::field_cache
StructDef.pl view on Meta::CPAN
'AR\w+\*' => '%L = perl_%B( ctrl, %R )',
'(int|long|unsigned\s+int|unsigned\s+long)' => '%L = newSViv( %R )',
'(float|double)' => '%L = newSVnv( %R )',
'char\s*\*' => '%L = newSVpv( %R, 0 )',
'char\[.+]' => '%L = newSVpv( %R, 0 )',
],
);
#print evalTemplate( 'COPY', 'char[10]', 'p->charVal', 'buffer' ), "\n";
#print evalTemplate( 'COPY', 'unsigned char', 'p->unique', 'buffer' ), "\n";
#ARIntegerLimitsStruct intLimits;
#ARRealLimitsStruct realLimits;
#ARCharLimitsStruct charLimits;
#ARDiaryLimitsStruct diaryLimits;
#AREnumLimitsStruct enumLimits;
#AREnumLimitsStruct maskLimits;
#ARAttachLimitsStruct attachLimits;
#ARTableLimitsStruct tableLimits;
$ARS_QUERY = "'Field' = \"$value\" ...etc"
and:
@SYBASE_QUERY would be something like this:
select Ticket_No from Schema_Name
WHERE Field = '$value'
-----------------------------------------------
allow substitution of current transaction values
in qual and recompilation of qual. this facilitates
the retrieval of dynamic query menu items
-------------
createactivelink not working with SQL assignements
changes.dat view on Meta::CPAN
TS added lengthUnits,storageOptionForCLOB attributes to ARCharLimitsStruct,ARDisplayLimits
TS fixed ars_GetServerInfo() keys 325-332 problem
TS modifications for AR 7.6.3 API
TS ars_GetEntryBLOB bugfix by Conny Martin
TS fixed "hv_fetch error" problem in case of undefined ARValueStruct
TS fixed SignalTypeMap problem
TS package directory reorganization/cleanup
TS additional ars_Login parameters by Conny Martin
TS implemented ars_GetList/Get/Create/Set/DeleteImage
TS fixed incorrect AR_ARITH_OP_NEGATE handling in rev_ARArithOpStruct
TS fixed wrong operand evaluation for AR_ARITH_OP_NEGATE in perl_ARArithOpStruct
TS fixed ars_SetServerInfo() memory violation in case of more than one key/value pair
TS ars_GetFieldTable performance improvement by using ARGetMultipleFields
TS removed unnecessary second invocation of ARGetField in ars_GetField
TS code cleanup (#ifdef statements) in ARGetFieldCached, ars_GetField, ars_GetFieldByName
!TS appended ARControlStruct pointer address to server key in %ARS::field_cache
(affects only scripts which make explicit use of the internal field_cache structure)
!CL enhanced ARS OO interface to handle custom enum fields
TS fixed return value of ars_Import
TS fixed memory violation in ars_GetListContainer
TS implemented ars_qualifier_ptr function (inverse of ars_perl_qualifier)
example/GetFilter.pl view on Meta::CPAN
# PrintArith
#
# DESCRIPTION
# Attempt to "pretty print" the arith expression (just for
# the hell of it)
#
# NOTES
# Notic that parenthesis are printed, although they are not
# explicitly part of the node information. They are derived
# from the ordering of the tree, instead. If you want to actually
# *evaluate* the expression, you will have to derive the
# parenthetical encoding from the tree ordering.
#
# Here is an example equation and how it is encoded:
#
# ((10 + 2) / 3)
#
# "/"
# / \
# "+" 3
# / \
# 10 2
#
# ARS apparently sorts the operations for you (based on their
# mathematical precedence) so you should evaluate the tree from
# the bottom up.
#
# ars_web.cgi has an evaluation routine for computing the value
# of a arith structure. we will probably break it out into a
# perl module.
#
# THOUGHTS
# I don't know if this routine will work for all cases.. but
# i did some tests and it looked good. Ah.. i just wrote it
# for the fun of it.. so who cares? :)
sub PrintArith {
my $a = shift;
example/Show_ALink.pl view on Meta::CPAN
# PrintArith
#
# DESCRIPTION
# Attempt to "pretty print" the arith expression (just for
# the hell of it)
#
# NOTES
# Notic that parenthesis are printed, although they are not
# explicitly part of the node information. They are derived
# from the ordering of the tree, instead. If you want to actually
# *evaluate* the expression, you will have to derive the
# parenthetical encoding from the tree ordering.
#
# Here is an example equation and how it is encoded:
#
# ((10 + 2) / 3)
#
# "/"
# / \
# "+" 3
# / \
# 10 2
#
# ARS apparently sorts the operations for you (based on their
# mathematical precedence) so you should evaluate the tree from
# the bottom up.
#
# ars_web.cgi has an evaluation routine for computing the value
# of a arith structure. we will probably break it out into a
# perl module.
#
# THOUGHTS
# I don't know if this routine will work for all cases.. but
# i did some tests and it looked good. Ah.. i just wrote it
# for the fun of it.. so who cares? :)
sub PrintArith {
my $a = shift;
html/changes.html view on Meta::CPAN
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>fixed SignalTypeMap problem
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>package directory reorganization/cleanup
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>additional ars_Login parameters by Conny Martin
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>implemented ars_GetList/Get/Create/Set/DeleteImage
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>fixed incorrect AR_ARITH_OP_NEGATE handling in rev_ARArithOpStruct
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>fixed wrong operand evaluation for AR_ARITH_OP_NEGATE in perl_ARArithOpStruct
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>fixed ars_SetServerInfo() memory violation in case of more than one key/value pair
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>ars_GetFieldTable performance improvement by using ARGetMultipleFields
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='black'>removed unnecessary second invocation of ARGetField in ars_GetField
</font></td></tr>
<tr bgcolor='#dddddd'><td width='10%'>(TS)</td><td width='90%'><font color='black'>code cleanup (#ifdef statements) in ARGetFieldCached, ars_GetField, ars_GetFieldByName
</font></td></tr>
<tr bgcolor='#eeeeee'><td width='10%'>(TS)</td><td width='90%'><font color='red'>appended ARControlStruct pointer address to server key in %ARS::field_cache
html/debug.html view on Meta::CPAN
<PRE>
152 cnu(11:13:13)~/ARSperl/ARSperl/example> gdb /usr/local/bin/perl
GDB is free software and you are welcome to distribute copies of it
under certain conditions; type "show copying" to see the conditions.
There is absolutely no warranty for GDB; type "show warranty" for details.
GDB 4.16 (sparc-sun-solaris2.3),
Copyright 1996 Free Software Foundation, Inc...
(gdb) set args -d GetField.pl remedyserver jmurphy mypass User 1
(gdb) run
Starting program: /usr/local/bin/perl -d GetField.pl remedyserver jmurphy mypass User 1
Stack dump during die enabled outside of evals.
Loading DB routines from perl5db.pl patch level 0.94
Emacs support available.
Enter h or `h h' for help.
main::(GetField.pl:31): ($server, $username, $password, $schema, $fieldname) = @ARGV;
DB<1> n
main::(GetField.pl:32): if(!defined($password)) {
DB<1> n
html/manual/ars_MergeEntry.html view on Meta::CPAN
<ol>
<li> A non-null value returned means that a new entry was created.
<li> A null value returned, plus $ars_errstr empty, means that an existing
entry was replaced.
<li> A null value returned, plus $ars_errstr non-empty, means there was some
error.
</oL>
Here's some sample code that demonstrates how to evaluate the outcome of
this function:
<PRE>
foreach $RPTID (sort keys %RPTEntryList) {
undef @Report;
( @Report = ars_GetEntry($ctrl1, $ISS_RPT_SCHEMA, $RPTID) )
|| arsdie("GetEntry $RPTID");
if ( $ret = ars_MergeEntry($ctrl2, $ISS_RPT_SCHEMA,
3075, @Report) ) {
print "$RPTID -> new $ret\n";
} else {
#!/u1/project/ARSperl/perl/bin/perl
eval 'exec /u1/project/ARSperl/perl/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
use strict;
use Config;
use File::Path qw(mkpath);
use Getopt::Std;
getopts('Dd:rlhaQ');
use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q);
my %isatype;
@isatype{@isatype} = (1) x @isatype;
my $inif = 0;
my %Is_converted;
@ARGV = ('-') unless @ARGV;
build_preamble_if_necessary();
my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
my ($incl, $next);
while (defined (my $file = next_file())) {
if (-l $file and -d $file) {
link_if_possible($file) if ($opt_l);
next;
}
# Recover from header files with unbalanced cpp directives
$t = '';
$tab = 0;
# $eval_index goes into ``#line'' directives, to help locate syntax errors:
$eval_index = 1;
if ($file eq '-') {
open(IN, "-");
open(OUT, ">-");
} else {
($outfile = $file) =~ s/\.h$/.ph/ || next;
print "$file -> $outfile\n" unless $opt_Q;
if ($file =~ m|^(.*)/|) {
$dir = $1;
mkpath "$Dest_dir/$dir";
}
s/^\s+//;
expr();
$new =~ s/(["\\])/\\$1/g; #"]);
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,
"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,
"eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
}
} else {
print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
}
%curargs = ();
} else {
s/^\s+//;
expr();
$new = 1 if $new eq '';
$new = reindent($new);
$args = reindent($args);
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g; #']);
if ($opt_h) {
print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
$eval_index++;
} else {
print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
}
} else {
# Shunt around such directives as `#define FOO FOO':
next if " \&$name" eq $new;
print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
}
}
} elsif (/^(include|import)\s*[<"](.*)[>"]/) {
($incl = $2) =~ s/\.h$/.ph/;
# print OUT $t,"require '$incl';\n"; ### TS, don't require artypes.ph
} elsif(/^include_next\s*[<"](.*)[>"]/) {
($incl = $1) =~ s/\.h$/.ph/;
print OUT ($t,
"eval {\n");
$tab += 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
print OUT ($t,
"my(\%INCD) = map { \$INC{\$_} => 1 } ",
"(grep { \$_ eq \"$incl\" } keys(\%INC));\n");
print OUT ($t,
"my(\@REM) = map { \"\$_/$incl\" } ",
"(grep { not exists(\$INCD{\"\$_/$incl\"})",
"and -f \"\$_/$incl\" } \@INC);\n");
print OUT ($t,
next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
(my $enum_subs = $3) =~ s/\s//g;
my @enum_subs = split(/,/, $enum_subs);
my $enum_val = -1;
foreach my $enum (@enum_subs) {
my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
$enum_value =~ s/^=//;
$enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
if ($opt_h) {
print OUT ($t,
"eval(\"\\n#line $eval_index $outfile\\n",
"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
++ $eval_index;
} else {
print OUT ($t,
"eval(\"sub $enum_name () \{ $enum_val; \}\") ",
"unless defined(\&$enum_name);\n");
}
}
}
}
print OUT "1;\n";
$Is_converted{$file} = 1;
queue_includes_from($file) if ($opt_a);
}
closedir DIR;
}
# Given $file, a symbolic link to a directory in the C include directory,
# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
# Otherwise, just duplicate the file or directory.
sub link_if_possible
{
my ($dirlink) = @_;
my $target = eval 'readlink($dirlink)';
if ($target =~ m:^\.\./: or $target =~ m:^/:) {
# The target of a parent or absolute link could leave the $Dest_dir
# hierarchy, so let's put all of the contents of $dirlink (actually,
# the contents of $target) into @ARGV; as a side effect down the
# line, $dirlink will get created as an _actual_ directory.
expand_glob($dirlink);
} else {
if (-l "$Dest_dir/$dirlink") {
unlink "$Dest_dir/$dirlink" or
print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
}
if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
print "Linking $target -> $Dest_dir/$dirlink\n";
# Make sure that the link _links_ to something:
if (! -e "$Dest_dir/$target") {
mkpath("$Dest_dir/$target", 0755) or
print STDERR "Could not create $Dest_dir/$target/\n";
}
} else {
print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
}
Symbolic links will be replicated in the destination directory. If B<-l>
is not specified, then links are skipped over.
=item -h
Put ``hints'' in the .ph files which will help in locating problems with
I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
errors, instead of the cryptic
[ some error condition ] at (eval mmm) line nnn
you will see the slightly more helpful
[ some error condition ] at filename.ph line nnn
However, the B<.ph> files almost double in size when built using B<-h>.
=item -D
Include the code from the B<.h> file as a comment in the B<.ph> file.
=head1 DIAGNOSTICS
The usual warnings if it can't read or write the files involved.
=head1 BUGS
Doesn't construct the %sizeof array for you.
It doesn't handle all C constructs, but it does attempt to isolate
definitions inside evals so that you can get at the definitions
that it can translate.
It's only intended as a rough tool.
You may need to dicker with the files produced.
You have to run this program by hand; it's not run as part of the Perl
installation.
Doesn't handle complicated expressions built piecemeal, a la:
rev_AR_template.pl view on Meta::CPAN
$ARS::CodeTemplate::DEF_CODE = ARS::CodeTemplate::compile( $ARS::CodeTemplate::TPT_CODE );
ARS::CodeTemplate::procdef( $ARS::CodeTemplate::DEF_CODE );
#use UTAN::Util;
#UTAN::Util::modFileByRegex( 'functions.c', 's/^(\s*)rev_ARQualifierStruct\(.*/$1p->qualifier.operation = AR_OPERATION_NONE;/' );
#--- EDIT HERE ---
sub evalTemplate {
my( $tag, $type, $L, $R ) = @_;
# print STDERR "evalTemplate( $tag, $type, $L, $R )\n"; # _DEBUG_
$tag = lc($tag);
$tag =~ s/^(?=[^_])/_/;
my( $tpDef, $tp ) = ( $TEMPLATES{$tag} );
if( !defined $tpDef ){
die "NO TEMPLATE GROUP\n", "\$tag <$tag> \$type <$type> \$L <$L> \$R <$R>\n"; # _DEBUG_
# exit 1;
}
# foreach my $rx ( keys %$tpDef ){
rev_AR_template.pl view on Meta::CPAN
map {$val{$_} = $match[$_]} (1..$#match) if $#match >= 1;
# print "\$rx <", $rx, "> \@match <", join('|',@match), "> \%val <", join('|',%val), ">\n"; # _DEBUG_
$tp =~ s/\%([LRTB0-9])\b/$val{$1}/g;
return $tp;
}
sub typeCopy {
my( $type, $L, $R ) = @_;
$type = $CONVERT{$type}{_typedef} while defined $CONVERT{$type}{_typedef};
my $str = evalTemplate( '_copy', $type, $L, $R );
return $str;
}
sub perlCopy {
my( $type, $L, $R ) = @_;
$type = $CONVERT{$type}{_typedef} while defined $CONVERT{$type}{_typedef};
my $str = evalTemplate( '_perl', $type, $L, $R );
return $str;
}
sub keyFilter {
my( $hRef, @fkey ) = @_;
my @list;
foreach my $fkey ( @fkey ){
foreach my $key ( keys %$hRef ){
push @list, $key if findSubKey($hRef->{$key},$fkey);
}
( run in 2.515 seconds using v1.01-cache-2.11-cpan-98e64b0badf )