Convert-IBM390
view release on metacpan or search on metacpan
0xfc, 0xf9, 0xfa, 0xff, 0x5c, 0xf7, 0x53, 0x54, 0x55, 0x56,
0x57, 0x58, 0x59, 0x5a, 0xb2, 0xd4, 0xd6, 0xd2, 0xd3, 0xd5,
0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39,
0xb3, 0xdb, 0xdc, 0xd9, 0xda, 0x9f };
static unsigned char e2ap_table[256] = {
" "
" .<(+|& !$*); -/ ,%_>? `:#@'=\""
" abcdefghi jklmnopqr ~stuvwxyz [ ] "
"{ABCDEFGHI }JKLMNOPQR \\ STUVWXYZ 0123456789 "};
/*---- End of tables ----*/
#ifdef OLD_INTERNAL
#define UNDEF_PTR &sv_undef
#else
#define UNDEF_PTR &PL_sv_undef
#endif
/* 36KB may seem small, but on MVS most records are 32KB or less. */
#define OUTSTRING_MEM 36864
/* Macro: catenate a string to the end of an existing string
* and move the pointer up. */
#define memcat(target,offset,source,len) \
memcpy((target+offset), source, len); \
offset += len;
#ifndef min
#define min(x,y) (((x) < (y)) ? (x) : (y))
#endif
static int
not_here(char *s)
{
croak("%s not implemented on this architecture", s);
return -1;
}
static double
constant(char *name, int len, int arg)
{
errno = EINVAL;
return 0;
}
MODULE = Convert::IBM390 PACKAGE = Convert::IBM390
void
asc2eb(instring_sv)
SV * instring_sv
PROTOTYPE: $
PREINIT:
STRLEN ilength;
char * instring;
char * outstring_wk;
/* To avoid allocating small amounts of storage: */
char shorty[SHORTY_SIZE];
PPCODE:
instring = SvPV(instring_sv, ilength);
#ifdef DEBUG390
fprintf(stderr, "*D* asc2eb: beginning; length %d\n", ilength);
#endif
if (ilength <= SHORTY_SIZE) {
CF_fcs_xlate(shorty, instring, ilength, a2e_table);
PUSHs(sv_2mortal(newSVpvn(shorty, ilength)));
} else {
New(0, outstring_wk, ilength, char);
CF_fcs_xlate(outstring_wk, instring, ilength, a2e_table);
PUSHs(sv_2mortal(newSVpvn(outstring_wk, ilength)));
Safefree(outstring_wk);
}
#ifdef DEBUG390
fprintf(stderr, "*D* asc2eb: returning\n");
#endif
void
eb2asc(instring_sv)
SV * instring_sv
PROTOTYPE: $
PREINIT:
STRLEN ilength;
char * instring;
char * outstring_wk;
/* To avoid allocating small amounts of storage: */
char shorty[SHORTY_SIZE];
PPCODE:
instring = SvPV(instring_sv, ilength);
#ifdef DEBUG390
fprintf(stderr, "*D* eb2asc: beginning; length %d\n", ilength);
#endif
if (ilength <= SHORTY_SIZE) {
CF_fcs_xlate(shorty, instring, ilength, e2a_table);
PUSHs(sv_2mortal(newSVpvn(shorty, ilength)));
} else {
New(0, outstring_wk, ilength, char);
CF_fcs_xlate(outstring_wk, instring, ilength, e2a_table);
PUSHs(sv_2mortal(newSVpvn(outstring_wk, ilength)));
Safefree(outstring_wk);
}
#ifdef DEBUG390
fprintf(stderr, "*D* eb2asc: returning\n");
#endif
void
eb2ascp(instring_sv)
SV * instring_sv
PROTOTYPE: $
PREINIT:
STRLEN ilength;
char * instring;
char * outstring_wk;
/* To avoid allocating small amounts of storage: */
char shorty[SHORTY_SIZE];
PPCODE:
instring = SvPV(instring_sv, ilength);
#ifdef DEBUG390
fprintf(stderr, "*D* eb2ascp: beginning; length %d\n", ilength);
#endif
if (ilength <= SHORTY_SIZE) {
CF_fcs_xlate(shorty, instring, ilength, e2ap_table);
PUSHs(sv_2mortal(newSVpvn(shorty, ilength)));
} else {
New(0, outstring_wk, ilength, char);
CF_fcs_xlate(outstring_wk, instring, ilength, e2ap_table);
PUSHs(sv_2mortal(newSVpvn(outstring_wk, ilength)));
Safefree(outstring_wk);
}
#ifdef DEBUG390
fprintf(stderr, "*D* eb2ascp: returning\n");
#endif
# // Much of the following code is shamelessly stolen from Perl's
# // built-in pack and unpack functions (pp.c).
# // packeb -- Pack a list of values into an EBCDIC record
void
packeb(pat, ...)
char * pat
PREINIT:
char outstring[OUTSTRING_MEM];
SV * item;
STRLEN item_len;
int ii; /* ii = item index */
int oi; /* oi = outstring index */
char datumtype;
register char * patend;
register int len;
int j, ndec, num_ok;
static char null10[] = {0,0,0,0,0,0,0,0,0,0};
/* space10 = native spaces. espace10 = EBCDIC spaces. */
static char space10[] = " ";
static char espace10[] =
{ 0x40, 0x40, 0x40, 0x40, 0x40, 0x40, 0x40, 0x40, 0x40, 0x40 };
I32 along;
char *aptr;
double adouble;
/* The eb_work area is long, but what the heck? Memory is cheap. */
char eb_work[32800];
PPCODE:
#ifdef DEBUG390
fprintf(stderr, "*D* packeb: beginning\n");
#endif
ii = 1;
oi = 0;
patend = pat + strlen(pat);
while (pat < patend) {
/* Have we gone past the end of the list of values? If so, stop. */
if (ii >= items)
break;
if (oi >= OUTSTRING_MEM)
croak("Output structure too large in packeb");
datumtype = *pat++;
if (isSPACE(datumtype))
continue;
if (*pat == '*') {
len = strchr("pz", datumtype) ? 8 :
(strchr("@x", datumtype) ? 0 : items - ii + 1);
pat++;
} else if (isDIGIT(*pat)) {
len = *pat++ - '0';
while (isDIGIT(*pat))
len = (len * 10) + (*pat++ - '0');
/* Decimal places (this result will be ignored if the
datumtype is not packed or zoned). */
ndec = 0;
if (*pat == '.') {
pat++;
while (isDIGIT(*pat))
ndec = (ndec * 10) + (*pat++ - '0');
}
} else {
len = strchr("pz", datumtype) ? 8 : 1;
}
if (len > 32767) {
croak("Field length too large in packeb: %c%d",
datumtype, len);
}
#ifdef DEBUG390
fprintf(stderr, "*D* packeb: datumtype/len %c%d\n",
datumtype, len);
#endif
switch(datumtype) {
case '@':
if (len > OUTSTRING_MEM || len < 0)
croak("@ position outside string");
oi = len;
break;
case 'x':
while (len >= 10) {
memcat(outstring, oi, null10, 10);
len -= 10;
}
memcat(outstring, oi, null10, len);
break;
else
workbyte |= hexbyte & 15;
if (! (xi & 1))
workbyte <<= 4;
else {
final_byte = workbyte & 0xFF;
memcat(outstring, oi, &final_byte, 1);
workbyte = 0;
}
}
if (xi & 1) {
final_byte = workbyte & 0xFF;
memcat(outstring, oi, &final_byte, 1);
}
}
break;
default:
croak("Invalid type in packeb: '%c'", datumtype);
}
}
PUSHs(sv_2mortal(newSVpvn(outstring, oi)));
#ifdef DEBUG390
fprintf(stderr, "*D* packeb: returning\n");
#endif
# unpackeb -- Unpack an EBCDIC record into a list
# Note that the EBCDIC data may contain nulls and other unprintable
# stuff, so we need an SV*, not just a char*.
void
unpackeb(pat, ebrecord)
char * pat
SV * ebrecord
PROTOTYPE: $$
PREINIT:
SV *sv;
STRLEN rlen;
register char *s;
char *sbegin;
char *tail;
char *strend;
register char *patend;
char datumtype;
register I32 len, outlen;
register I32 bits = 0;
int i, j, ndec, fieldlen;
char hexdigit[16] = "0123456789abcdef";
/* Work fields */
I32 along;
unsigned long aulong;
/* Some day we may want to support S/390 floats.... */
/*float afloat;*/
double adouble;
/* The eb_work area is long, but what the heck? Memory is cheap. */
char eb_work[32800];
PPCODE:
#ifdef DEBUG390
fprintf(stderr, "*D* unpackeb: beginning\n");
#endif
s = sbegin = SvPV(ebrecord, rlen);
strend = s + rlen;
patend = pat + strlen(pat);
while (pat < patend) {
datumtype = *pat++;
if (isSPACE(datumtype))
continue;
ndec = 0;
if (pat >= patend) {
len = 1;
}
else if (*pat == '*') {
len = strend - s;
if (datumtype == 'i' || datumtype == 'I') len = len / 4;
if (datumtype == 's' || datumtype == 'S') len = len / 2;
pat++;
}
else if (isDIGIT(*pat)) {
len = *pat++ - '0';
while (isDIGIT(*pat))
len = (len * 10) + (*pat++ - '0');
/* Decimal places (this result will be ignored if the
datumtype is not packed or zoned). */
ndec = 0;
if (*pat == '.') {
pat++;
while (isDIGIT(*pat))
ndec = (ndec * 10) + (*pat++ - '0');
}
}
else {
len = 1;
}
if (len > 32767) {
croak("Field length too large in unpackeb: %c%d",
datumtype, len);
}
#ifdef DEBUG390
fprintf(stderr, "*D* unpackeb: datumtype/len %c%d\n",
datumtype, len);
#endif
switch(datumtype) {
/* @: absolute offset */
case '@':
if (len >= rlen || len < 0)
croak("Absolute offset is outside string: @%d", len);
s = sbegin + len;
break;
/* [eE]: EBCDIC character string. In this case, the length
given in the template is the length of a single field, not
a number of repetitions. */
case 'e':
case 'E':
if (len > strend - s)
len = strend - s;
( run in 0.513 second using v1.01-cache-2.11-cpan-71847e10f99 )