« back to all changes in this revision
Viewing changes to libcob/common.c
- browse files at revision 12
- compare with another revision
- download diff
- download tarball
- view history from revision 12
- Committer: Jim Popovitch
- Date: 2024-11-29 15:39:36 UTC
- Revision ID: jim.popovitch@replatformtech.com-20241129153936-wnjndpxl8m8k1mhe
Upstream changes
- files modified:
- ChangeLog
added
removed
libcob/common.c
156
156
157
157
/* end of library headers */
158
158
159
/* Force symbol exports */
159
/* include internal and external libcob definitions, forcing exports */
160
160
#define COB_LIB_EXPIMP
161
161
#include "common.h"
162
162
#include "cobcapi.h" /* for helper functions */
350
350
351
351
static int cob_switch[COB_SWITCH_MAX + 1];
352
352
353
/* BCD to Integer translation (full byte -> 0 - 99) */
354
static unsigned char b2i[256]=
355
{ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 255, 255, 255, 255, 255, 255,
356
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 255, 255, 255, 255, 255, 255,
357
20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 255, 255, 255, 255, 255, 255,
358
30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 255, 255, 255, 255, 255, 255,
359
40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 255, 255, 255, 255, 255, 255,
360
50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 255, 255, 255, 255, 255, 255,
361
60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 255, 255, 255, 255, 255, 255,
362
70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 255, 255, 255, 255, 255, 255,
363
80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 255, 255, 255, 255, 255, 255,
364
90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 255, 255, 255, 255, 255, 255 };
365
366
#define IS_INVALID_BCD_DATA(c) (b2i[(unsigned char)c] == 255)
367
368
/* note: use of table d2i was tested and seen to be
369
slower for checking validity/invalidity
370
and only 0.2% faster for GET_D2I than COB_D2I */
371
#define IS_INVALID_DIGIT_DATA(c) (c < '0' || c > '9') /* not valid digits '0' - '9' */
372
#define IS_VALID_DIGIT_DATA(c) (c >= '0' && c <= '9') /* valid digits '0' - '9' */
373
353
374
/* Runtime exit handling */
354
375
static struct exit_handlerlist {
355
376
struct exit_handlerlist *next;
938
959
do {
939
960
digit = u % radix;
940
961
u /= radix;
941
*p++ = '0' + digit;
962
*p++ = COB_I2D (digit);
963
942
964
} while (u > 0);
943
965
944
966
len = p - ss_itoa_buf;
1460
1482
#endif
1461
1483
}
1462
1484
1463
/* ASCII Sign
1485
/* ASCII Sign - Reading and undo the "overpunch";
1486
* Note: if used on an EBCDIC machine this is actually _not_ an overpunch
1487
* but a replacement!
1464
1488
* positive: 0123456789
1465
1489
* negative: pqrstuvwxy
1466
1490
* returns one of: 1 = positive (non-negative), -1 = negative
1517
1541
return 1;
1518
1542
#else
1519
1543
if (*p >= (unsigned char)'p' && *p <= (unsigned char)'y') {
1520
*p &= ~64U;
1544
*p &= ~0x40; /* 0x71 'q' -> 0x31 -> '1' */
1521
1545
return -1;
1522
1546
}
1523
if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
1547
if (IS_VALID_DIGIT_DATA (*p)) {
1524
1548
/* already without sign */
1525
return -1;
1549
return 1;
1526
1550
}
1527
1551
*p = (unsigned char)'0';
1528
1552
return 1;
1529
1553
#endif
1530
1554
}
1531
1555
1556
/* overpunches the pointer 'p' with the sign
1557
* Note: if used on an EBCDIC machine this is actually _not_ an overpunch
1558
* but a replacement! */
1532
1559
static void
1533
1560
cob_put_sign_ascii (unsigned char *p)
1534
1561
{
1580
1607
*p = (unsigned char)'0';
1581
1608
}
1582
1609
#else
1583
*p |= 64U;
1610
*p |= 0x40;
1584
1611
#endif
1585
1612
}
1586
1613
1587
/* EBCDIC Sign
1614
/* EBCDIC Sign - Reading and undo the "overpunch";
1615
* Note: if used on an ASCII machine this is actually _not_ an overpunch
1616
* but a replacement!
1588
1617
* positive: {ABCDEFGHI
1618
* unsigned: 0123456789
1589
1619
* negative: }JKLMNOPQR
1590
* returns one of: 1 = positive (non-negative), -1 = negative
1620
* returns one of: 1 = positive (non-negative), -1 = negative, 0 = unsigned
1591
1621
*/
1592
1622
1593
1623
static int
1594
1624
cob_get_sign_ebcdic (unsigned char *p)
1595
1625
{
1626
#ifdef COB_EBCDIC_MACHINE
1627
char sign_nibble = *p & 0xF0;
1628
/* What to do here outside of 0 - 9? */
1629
if ((*p & 0x0F) > 9) {
1630
*p = sign_nibble;
1631
}
1632
switch (sign_nibble) {
1633
/* negative */
1634
case 0xC0:
1635
/* negative, non-preferred */
1636
case 0xA0:
1637
case 0xE0:
1638
return 1;
1639
/* positive */
1640
case 0xD0:
1641
/* positive, non-preferred */
1642
case 0xB0:
1643
return -1;
1644
/* unsigned */
1645
case 0xF0:
1646
return 0;
1647
return -1;
1648
default:
1649
/* What to do here outside of sign nibbles? */
1650
return 1;
1651
}
1652
#else
1596
1653
switch (*p) {
1597
1654
case '{':
1598
1655
*p = (unsigned char)'0';
1655
1712
*p = (unsigned char)'9';
1656
1713
return -1;
1657
1714
default:
1658
/* What to do here */
1659
*p = (unsigned char)('0' + (*p & 0x0F));
1660
if (*p > (unsigned char)'9') {
1715
if (*p >= '0' && *p <= '9') {
1716
return 0;
1717
}
1718
/* What to do here outside of 0 - 9? */
1719
if ((*p & 0x0F) > 9) {
1661
1720
*p = (unsigned char)'0';
1721
} else {
1722
*p = (unsigned char)COB_I2D (COB_D2I (*p));
1662
1723
}
1663
1724
return 1;
1664
1725
}
1726
#endif
1665
1727
}
1666
1728
1667
1729
static void
1871
1933
cob_cmp_all (cob_field *f1, cob_field *f2)
1872
1934
{
1873
1935
const unsigned char *col = COB_MODULE_PTR->collating_sequence;
1874
unsigned char *data;
1875
unsigned char buff[COB_MAX_DIGITS + 1];
1876
1877
if (COB_FIELD_HAVE_SIGN (f1)) {
1878
/* drop sign for comparision, using a copy to not change
1879
the field during comparision */
1880
/* CHECKME: What should be returned if f1 is negative? */
1881
unsigned char *real_data = f1->data;
1882
f1->data = data = buff;
1883
memcpy (buff, real_data, f1->size);
1884
(void)cob_real_get_sign (f1);
1885
f1->data = real_data;
1886
} else {
1887
data = f1->data;
1888
}
1936
const unsigned char *data1 = COB_FIELD_DATA (f1);
1937
const unsigned char *data2 = f2->data;
1938
const size_t size1 = COB_FIELD_SIZE (f1);
1939
const size_t size2 = f2->size;
1940
/* CHECKME: What should be returned if f1 is negative? */
1941
/* CHECKME: Do we ever get here with f2 being numeric? */
1942
const int sign = COB_GET_SIGN_ADJUST (f1);
1943
int ret = 0;
1889
1944
1890
1945
/* check without collation */
1891
1946
if (col == NULL) {
1892
if (f2->size == 1) {
1893
if (f2->data[0] == ' ') {
1947
if (size2 == 1) {
1948
if (*data2 == ' ') {
1894
1949
/* check for IF VAR = [ALL] SPACE[S] */
1895
return compare_spaces (f1->data, f1->size);
1896
}
1897
if (f2->data[0] == '0') {
1950
ret = compare_spaces (data1, size1);
1951
} else
1952
if (*data2 == '0') {
1898
1953
/* check for IF VAR = [ALL] ZERO[ES] */
1899
return compare_zeroes (f1->data, f1->size);
1954
ret = compare_zeroes (data1, size1);
1955
} else {
1956
/* check for IF VAR = ALL '5' / HIGH-VALUE / ... */
1957
ret = compare_character (data1, size1, data2, 1);
1900
1958
}
1901
}
1902
/* check for IF VAR = ALL ... / HIGH-VALUE / ... */
1903
if (f1->size > f2->size) {
1904
return compare_character (f1->data, f1->size, f2->data, f2->size);
1959
} else
1960
/* check for IF VAR = ALL ... / ... */
1961
if (size1 > size2) {
1962
ret = compare_character (data1, size1, data2, size2);
1905
1963
} else {
1906
return compare_character (f1->data, f1->size, f2->data, f1->size);
1964
ret = compare_character (data1, size1, data2, size1);
1907
1965
}
1908
}
1909
1966
} else
1910
1967
/* check with collation */
1911
if (f2->size == 1) {
1968
if (size2 == 1) {
1912
1969
/* check for IF VAR = ALL "9" / IF VAR = ZERO */
1913
return common_cmpc (data, f2->data[0], f1->size, col);
1970
ret = common_cmpc (data1, *data2, size1, col);
1914
1971
} else {
1915
1972
/* check for IF VAR = ALL "AB" ... */
1916
size_t size = f1->size;
1917
int ret;
1918
while (size >= f2->size) {
1919
if ((ret = common_cmps (data, f2->data, f2->size, col)) != 0) {
1920
return ret;
1973
const size_t chunk_size = size2;
1974
size_t size_loop = size1;
1975
while (size_loop >= chunk_size) {
1976
if ((ret = common_cmps (data1, data2, chunk_size, col)) != 0) {
1977
break;
1921
1978
}
1922
size -= f2->size;
1923
data += f2->size;
1979
size_loop -= chunk_size;
1980
data1 += chunk_size;
1924
1981
}
1925
if (size > 0) {
1926
return common_cmps (data, f2->data, size, col);
1982
if (!ret
1983
&& size1 > 0) {
1984
ret = common_cmps (data1, data2, size_loop, col);
1927
1985
}
1928
1986
}
1929
return 0;
1987
1988
COB_PUT_SIGN_ADJUSTED (f1, sign);
1989
return ret;
1930
1990
}
1931
1991
1932
1992
/* compare content of field 'f1' to content of 'f2', space padded,
1935
1995
cob_cmp_alnum (cob_field *f1, cob_field *f2)
1936
1996
{
1937
1997
const unsigned char *col = COB_MODULE_PTR->collating_sequence;
1938
const size_t min = (f1->size < f2->size) ? f1->size : f2->size;
1998
const unsigned char *data1 = COB_FIELD_DATA (f1);
1999
const unsigned char *data2 = COB_FIELD_DATA (f2);
2000
const size_t size1 = COB_FIELD_SIZE (f1);
2001
const size_t size2 = COB_FIELD_SIZE (f2);
2002
const size_t min = (size1 < size2) ? size1 : size2;
1939
2003
int ret;
1940
2004
1941
2005
if (col == NULL) { /* check without collation */
1942
2006
1943
2007
/* Compare common substring */
1944
if ((ret = memcmp (f1->data, f2->data, min)) != 0) {
2008
if ((ret = memcmp (data1, data2, min)) != 0) {
1945
2009
return ret;
1946
2010
}
1947
2011
1948
2012
/* Compare the rest (if any) with spaces */
1949
if (f1->size > f2->size) {
1950
const size_t spaces_to_test = f1->size - min;
1951
return compare_spaces (f1->data + min, spaces_to_test);
1952
} else if (f1->size < f2->size) {
1953
const size_t spaces_to_test = f2->size - min;
1954
return -compare_spaces (f2->data + min, spaces_to_test);
2013
if (size1 > size2) {
2014
const size_t spaces_to_test = size1 - min;
2015
return compare_spaces (data1 + min, spaces_to_test);
2016
} else if (size1 < size2) {
2017
const size_t spaces_to_test = size2 - min;
2018
return -compare_spaces (data2 + min, spaces_to_test);
1955
2019
}
1956
2020
1957
2021
} else { /* check with collation */
1958
2022
1959
2023
/* Compare common substring */
1960
if ((ret = common_cmps (f1->data, f2->data, min, col)) != 0) {
2024
if ((ret = common_cmps (data1, data2, min, col)) != 0) {
1961
2025
return ret;
1962
2026
}
1963
2027
1964
2028
/* Compare the rest (if any) with spaces */
1965
if (f1->size > f2->size) {
1966
const size_t spaces_to_test = f1->size - min;
1967
return common_cmpc (f1->data + min, ' ', spaces_to_test, col);
1968
} else if (f1->size < f2->size) {
1969
const size_t spaces_to_test = f2->size - min;
1970
return -common_cmpc (f2->data + min, ' ', spaces_to_test, col);
2029
if (size1 > size2) {
2030
const size_t spaces_to_test = size1 - min;
2031
return common_cmpc (data1 + min, ' ', spaces_to_test, col);
2032
} else if (size1 < size2) {
2033
const size_t spaces_to_test = size2 - min;
2034
return -common_cmpc (data2 + min, ' ', spaces_to_test, col);
1971
2035
}
1972
2036
1973
2037
}
2140
2204
int
2141
2205
cob_check_env_true (char * s)
2142
2206
{
2143
if (s) {
2144
if (strlen (s) == 1 && (*s == 'Y' || *s == 'y' || *s == '1')) return 1;
2145
if (strcasecmp (s, "YES") == 0 || strcasecmp (s, "ON") == 0 ||
2146
strcasecmp (s, "TRUE") == 0) {
2147
return 1;
2148
}
2149
}
2150
return 0;
2207
return s && ((strlen (s) == 1 && (*s == 'Y' || *s == 'y' || *s == '1'))
2208
|| strcasecmp (s, "YES") == 0 || strcasecmp (s, "ON") == 0
2209
|| strcasecmp (s, "TRUE") == 0);
2151
2210
}
2152
2211
2153
2212
int
2154
2213
cob_check_env_false (char * s)
2155
2214
{
2156
2215
return s && ((strlen (s) == 1 && (*s == 'N' || *s == 'n' || *s == '0'))
2157
|| (strcasecmp (s, "NO") == 0 || strcasecmp (s, "NONE") == 0
2158
|| strcasecmp (s, "OFF") == 0 || strcasecmp (s, "FALSE") == 0));
2216
|| strcasecmp (s, "NO") == 0 || strcasecmp (s, "NONE") == 0
2217
|| strcasecmp (s, "OFF") == 0 || strcasecmp (s, "FALSE") == 0);
2159
2218
}
2160
2219
2161
2220
static char file_path_name [COB_FILE_BUFF] = "";
3273
3332
return (cob_u8_ptr)tmptr;
3274
3333
}
3275
3334
3276
/* stores the field's rtrimmed string content into the given buffer
3277
with maxlength */
3278
void
3279
cob_field_to_string (const cob_field *f, void *str, const size_t maxsize)
3280
{
3281
register unsigned char *end, *data, *s;
3282
3283
if (f == NULL) {
3284
snprintf (str, maxsize, "%s", ("NULL field"));
3285
return;
3286
}
3287
3288
if (f->size == 0) {
3289
return;
3290
}
3291
data = f->data;
3292
/* check if field has data assigned (may be a BASED / LINKAGE item) */
3293
if (data == NULL) {
3294
snprintf (str, maxsize, "%s", ("field with NULL address"));
3295
return;
3296
}
3297
end = data + f->size - 1;
3298
while (end > data) {
3299
if (*end != ' ' && *end) {
3300
break;
3301
}
3302
end--;
3303
}
3304
s = (unsigned char *)str;
3305
if (*end == ' ' || *end == 0) {
3306
*s = 0;
3307
return;
3308
}
3309
3310
/* note: the specified max does not contain the low-value */
3311
if ((size_t)(end - data) > maxsize) {
3312
end = data + maxsize;
3313
}
3314
while (data <= end) {
3315
*s++ = *data++;
3316
}
3317
*s = 0;
3318
}
3319
3320
3335
static void
3321
3336
call_exit_handlers_and_terminate (void)
3322
3337
{
3797
3812
void
3798
3813
cob_correct_numeric (cob_field *f)
3799
3814
{
3800
unsigned char *p;
3801
unsigned char *data;
3802
size_t size;
3803
size_t i;
3815
register unsigned char *p = f->data;
3816
unsigned char *end = p + f->size;
3817
unsigned char *c;
3804
3818
3805
3819
if (!COB_FIELD_IS_NUMDISP (f)) {
3806
3820
return;
3807
3821
}
3808
size = f->size;
3809
data = f->data;
3822
3810
3823
if (COB_FIELD_HAVE_SIGN (f)) {
3811
3824
/* Adjust for sign byte */
3812
size--;
3813
3825
if (COB_FIELD_SIGN_LEADING (f)) {
3814
p = f->data;
3815
data = p + 1;
3826
c = p++;
3816
3827
} else {
3817
p = f->data + f->size - 1;
3828
c = --end;
3818
3829
}
3819
3830
if (COB_FIELD_SIGN_SEPARATE (f)) {
3820
if (*p != '+' && *p != '-') {
3821
*p = '+';
3831
if (*c != '+' && *c != '-') {
3832
*c = '+';
3822
3833
}
3823
3834
} else if (COB_MODULE_PTR->ebcdic_sign) {
3824
switch (*p) {
3835
switch (*c) {
3825
3836
case '{':
3826
3837
case 'A':
3827
3838
case 'B':
3844
3855
case 'R':
3845
3856
break;
3846
3857
case '0':
3847
*p = '{';
3858
*c = '{';
3848
3859
break;
3849
3860
case '1':
3850
*p = 'A';
3851
break;
3852
3861
case '2':
3853
*p = 'B';
3854
break;
3855
3862
case '3':
3856
*p = 'C';
3857
break;
3858
3863
case '4':
3859
*p = 'D';
3860
break;
3861
3864
case '5':
3862
*p = 'E';
3863
break;
3864
3865
case '6':
3865
*p = 'F';
3866
break;
3867
3866
case '7':
3868
*p = 'G';
3869
break;
3870
3867
case '8':
3871
*p = 'H';
3872
break;
3873
3868
case '9':
3874
*p = 'I';
3869
*c = 'A' + (*c - '1');
3875
3870
break;
3876
3871
case 0:
3877
3872
case ' ':
3878
*p = '{';
3873
*c = '{';
3879
3874
break;
3880
3875
default:
3881
3876
break;
3882
3877
}
3883
3878
} else {
3884
if (!*p || *p == ' ') {
3885
*p = '0';
3879
if (!*c || *c == ' ') {
3880
*c = '0';
3886
3881
}
3887
3882
}
3888
3883
} else {
3889
p = f->data + f->size - 1;
3884
c = end - 1;
3890
3885
if (COB_MODULE_PTR->ebcdic_sign) {
3891
switch (*p) {
3886
switch (*c) {
3892
3887
case 0:
3893
3888
case ' ':
3894
3889
case '{':
3895
3890
case '}':
3896
*p = '0';
3891
*c = '0';
3897
3892
break;
3898
3893
case 'A':
3899
3894
case 'B':
3904
3899
case 'G':
3905
3900
case 'H':
3906
3901
case 'I':
3907
*p = '1' + (*p - 'A');
3902
*c = '1' + (*c - 'A');
3908
3903
break;
3909
3904
case 'J':
3910
3905
case 'K':
3915
3910
case 'P':
3916
3911
case 'Q':
3917
3912
case 'R':
3918
*p = '1' + (*p - 'J');
3913
*c = '1' + (*c - 'J');
3919
3914
break;
3920
3915
default:
3921
3916
break;
3922
3917
}
3923
3918
} else {
3924
switch (*p) {
3919
switch (*c) {
3925
3920
case 0:
3926
3921
case ' ':
3927
3922
case 'p':
3928
*p = '0';
3923
*c = '0';
3929
3924
break;
3930
3925
case 'q':
3931
*p = '1';
3932
break;
3933
3926
case 'r':
3934
*p = '2';
3935
break;
3936
3927
case 's':
3937
*p = '3';
3938
break;
3939
3928
case 't':
3940
*p = '4';
3941
break;
3942
3929
case 'u':
3943
*p = '5';
3944
break;
3945
3930
case 'v':
3946
*p = '6';
3947
break;
3948
3931
case 'w':
3949
*p = '7';
3950
break;
3951
3932
case 'x':
3952
*p = '8';
3953
break;
3954
3933
case 'y':
3955
*p = '9';
3934
*c = *c - 'p';
3956
3935
break;
3957
3936
default:
3958
3937
break;
3959
3938
}
3960
3939
}
3961
3940
}
3962
for (i = 0, p = data; i < size; ++i, ++p) {
3941
while (p < end) {
3963
3942
switch (*p) {
3964
3943
case '0':
3965
3944
case '1':
3978
3957
break;
3979
3958
default:
3980
3959
if ((*p & 0x0F) <= 9) {
3981
*p = (*p & 0x0F) + '0';
3960
*p = COB_I2D (*p & 0x0F);
3982
3961
}
3983
3962
break;
3984
3963
}
3964
p++;
3985
3965
}
3986
3966
}
3987
3967
3988
3968
static int
3989
3969
cob_check_numdisp (const cob_field *f)
3990
3970
{
3991
unsigned char *p;
3992
unsigned char *data;
3993
size_t size;
3994
size_t i;
3971
register const unsigned char *p = f->data;
3972
const unsigned char *end = p + f->size;
3995
3973
3996
size = f->size;
3997
data = f->data;
3998
3974
if (COB_FIELD_HAVE_SIGN (f)) {
3999
3975
/* Adjust for sign byte */
4000
size--;
3976
unsigned char c;
4001
3977
if (COB_FIELD_SIGN_LEADING (f)) {
4002
p = f->data;
4003
data = p + 1;
3978
c = *p++;
4004
3979
} else {
4005
p = f->data + f->size - 1;
3980
c = *(--end);
4006
3981
}
4007
3982
if (COB_FIELD_SIGN_SEPARATE (f)) {
4008
if (*p != '+' && *p != '-') {
4009
return 0;
4010
}
4011
} else if (COB_MODULE_PTR->ebcdic_sign) {
4012
switch (*p) {
4013
case '0':
4014
case '1':
4015
case '2':
4016
case '3':
4017
case '4':
4018
case '5':
4019
case '6':
4020
case '7':
4021
case '8':
4022
case '9':
4023
case '{':
4024
case 'A':
4025
case 'B':
4026
case 'C':
4027
case 'D':
4028
case 'E':
4029
case 'F':
4030
case 'G':
4031
case 'H':
4032
case 'I':
4033
case '}':
4034
case 'J':
4035
case 'K':
4036
case 'L':
4037
case 'M':
4038
case 'N':
4039
case 'O':
4040
case 'P':
4041
case 'Q':
4042
case 'R':
4043
break;
4044
default:
4045
return 0;
4046
}
4047
} else {
4048
switch (*p) {
4049
case '0':
4050
case '1':
4051
case '2':
4052
case '3':
4053
case '4':
4054
case '5':
4055
case '6':
4056
case '7':
4057
case '8':
4058
case '9':
4059
case 'p':
4060
case 'q':
4061
case 'r':
4062
case 's':
4063
case 't':
4064
case 'u':
4065
case 'v':
4066
case 'w':
4067
case 'x':
4068
case 'y':
4069
break;
4070
default:
4071
return 0;
3983
if (c != '+' && c != '-') {
3984
return 0;
3985
}
3986
} else if (IS_INVALID_DIGIT_DATA (c)) {
3987
if (COB_MODULE_PTR->ebcdic_sign) {
3988
switch (c) {
3989
case '{':
3990
case 'A':
3991
case 'B':
3992
case 'C':
3993
case 'D':
3994
case 'E':
3995
case 'F':
3996
case 'G':
3997
case 'H':
3998
case 'I':
3999
case '}':
4000
case 'J':
4001
case 'K':
4002
case 'L':
4003
case 'M':
4004
case 'N':
4005
case 'O':
4006
case 'P':
4007
case 'Q':
4008
case 'R':
4009
break;
4010
default:
4011
return 0;
4012
}
4013
} else {
4014
switch (c) {
4015
case 'p':
4016
case 'q':
4017
case 'r':
4018
case 's':
4019
case 't':
4020
case 'u':
4021
case 'v':
4022
case 'w':
4023
case 'x':
4024
case 'y':
4025
break;
4026
default:
4027
return 0;
4028
}
4072
4029
}
4073
4030
}
4074
4031
}
4075
for (i = 0; i < size; ++i) {
4076
if (!isdigit (data[i])) {
4032
4033
while (p < end) {
4034
if (IS_INVALID_DIGIT_DATA (*p)) {
4077
4035
return 0;
4078
4036
}
4037
p++;
4079
4038
}
4080
4039
return 1;
4081
4040
}
4091
4050
return f->data + f->size - 1;
4092
4051
}
4093
4052
4094
/* get sign from DISPLAY/PACKED fields
4095
returns one of: 1 = positive (non-negative), -1 = negative,
4053
/* get sign from DISPLAY/PACKED field 'f';
4054
4055
if 'adjust_ebcdic' is set then original DISPLAY data is "unpunched"
4056
for `ebcdic_sign` and return adjusted;
4057
that allows conversion without handling that afterwards
4058
4059
returns one of: 1 = positive (non-negative); -1 = negative;
4060
2 = positive (non-negative), adjusted;
4061
-2 = negative, adjusted;
4096
4062
0 = neither DISPLAY nor PACKED */
4097
4063
int
4098
cob_real_get_sign (cob_field *f)
4064
cob_real_get_sign (cob_field *f, const int adjust_ebcdic)
4099
4065
{
4100
4066
unsigned char *p;
4101
4067
4107
4073
if (COB_FIELD_SIGN_SEPARATE (f)) {
4108
4074
return (*p == '-') ? -1 : 1;
4109
4075
}
4110
if (*p >= (unsigned char)'0' && *p <= (unsigned char)'9') {
4076
if (IS_VALID_DIGIT_DATA (*p)) {
4111
4077
return 1;
4112
4078
}
4113
4079
if (*p == ' ') {
4114
4080
#if 0 /* RXWRXW - Space sign */
4115
*p = (unsigned char)'0';
4081
*p = '0';
4116
4082
#endif
4117
4083
return 1;
4118
4084
}
4119
if (COB_MODULE_PTR->ebcdic_sign) {
4120
return cob_get_sign_ebcdic (p);
4085
if (adjust_ebcdic) {
4086
#ifdef COB_EBCDIC_MACHINE
4087
if (COB_MODULE_PTR->ebcdic_sign) {
4088
return cob_get_sign_ebcdic (p);
4089
}
4090
return cob_get_sign_ascii (p) < 0 ? -2 : 2;
4091
#else
4092
if (COB_MODULE_PTR->ebcdic_sign) {
4093
return cob_get_sign_ebcdic (p) < 0 ? -2 : 2;
4094
}
4095
return ((*p & 0xF0) == 0x70) ? -1 : 1;
4096
#endif
4097
} else {
4098
if (COB_MODULE_PTR->ebcdic_sign) {
4099
return cob_get_sign_ebcdic (p);
4100
}
4101
return cob_get_sign_ascii (p);
4121
4102
}
4122
return cob_get_sign_ascii (p);
4123
4103
case COB_TYPE_NUMERIC_PACKED:
4124
4104
if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
4125
4105
return 1;
4141
4121
/* Note: we only locate the sign if needed,
4142
4122
as the common case will be "nothing to do" */
4143
4123
if (COB_FIELD_SIGN_SEPARATE (f)) {
4144
const unsigned char c = (sign == -1) ? (cob_u8_t)'-' : (cob_u8_t)'+';
4124
const unsigned char c = (sign == -1) ? '-' : '+';
4145
4125
p = locate_sign (f);
4146
4126
if (*p != c) {
4147
4127
*p = c;
4212
4192
const int f1_is_numeric = f1_type & COB_TYPE_NUMERIC;
4213
4193
const int f2_is_numeric = f2_type & COB_TYPE_NUMERIC;
4214
4194
4215
/* both numeric -> direct compare */
4195
/* both numeric -> direct numeric compare */
4216
4196
if (f1_is_numeric && f2_is_numeric) {
4217
4197
return cob_numeric_cmp (f1, f2);
4218
4198
}
4248
4228
only in test "Alphanumeric and binary numeric" */
4249
4229
4250
4230
if (f1_is_numeric || f2_is_numeric) {
4251
/* CHECKME: What should be returned if field is negative?
4252
We suspicously change -12 to 12 here... */
4231
/* Note: the standard explicit defines how to handle that:
4232
intermediate MOVE to a NUMERIC_DISPLAY with same amount
4233
of digits (= drop sign and implied decimal point), then
4234
compare that */
4253
4235
cob_field field;
4254
4236
cob_field_attr attr;
4255
4237
unsigned char buff[COB_MAX_DIGITS + 10];
4256
4238
4257
/* CHECKME: may need to abort if we ever get here with float data */
4258
4259
/* FIXME: must be converted to COB_TYPE_NUMERIC_EDITED with an
4260
internal PIC of COB_FIELD_DIGITS '9's and leading sign,
4261
otherwise we'll fail as soon as we enable COB_MAX_BINARY */
4239
/* note: the standard explicit forbits floating-point numeric
4240
in this scenario */
4262
4241
if (f1_is_numeric
4263
4242
&& f1_type != COB_TYPE_NUMERIC_DISPLAY) {
4264
4243
COB_FIELD_INIT (COB_FIELD_DIGITS (f1), buff, &attr);
4281
4260
if (COB_FIELD_HAVE_SIGN (f1)) {
4282
4261
/* Note: if field is numeric then it is always
4283
4262
USAGE DISPLAY here */
4284
4285
if (f1 != &field) {
4286
/* drop sign for comparision, using a copy to not change
4287
the field during comparision */
4288
unsigned char buff2[COB_MAX_DIGITS + 10];
4289
const size_t size = f1->size;
4290
int ret;
4291
unsigned char *real_data = f1->data;
4292
memcpy (buff2, real_data, size);
4293
f1->data = buff2;
4294
(void)cob_real_get_sign (f1);
4295
ret = cob_cmp_alnum (f1, f2);
4296
f1->data = real_data;
4263
if (f1 != &field) {
4264
const int sign = COB_GET_SIGN (f1);
4265
int ret = cob_cmp_alnum (f1, f2);
4266
COB_PUT_SIGN (f1, sign);
4297
4267
return ret;
4298
4268
} else {
4299
4269
/* we operate on a buffer already, just go on */
4300
(void)cob_real_get_sign (f1);
4270
(void)cob_real_get_sign (f1, 0);
4301
4271
return cob_cmp_alnum (f1, f2);
4302
4272
}
4303
4273
}
4305
4275
if (COB_FIELD_HAVE_SIGN (f2)) {
4306
4276
/* Note: if field is numeric then it is always
4307
4277
USAGE DISPLAY here */
4308
4309
4278
if (f2 != &field) {
4310
/* drop sign for comparision, using a copy to not change
4311
the field during comparision */
4312
unsigned char buff2[COB_MAX_DIGITS + 10];
4313
const size_t size = f2->size;
4314
int ret;
4315
unsigned char *real_data = f2->data;
4316
memcpy (buff2, real_data, size);
4317
f2->data = buff2;
4318
(void)cob_real_get_sign (f2);
4319
ret = cob_cmp_alnum (f1, f2);
4320
f2->data = real_data;
4279
const int sign = COB_GET_SIGN (f2);
4280
int ret = cob_cmp_alnum (f1, f2);
4281
COB_PUT_SIGN (f2, sign);
4321
4282
return ret;
4322
4283
} else {
4323
4284
/* we operate on a buffer already, just go on */
4324
(void)cob_real_get_sign (f2);
4285
(void)cob_real_get_sign (f2, 0);
4325
4286
return cob_cmp_alnum (f1, f2);
4326
4287
}
4327
4288
}
4368
4329
}
4369
4330
case COB_TYPE_NUMERIC_PACKED:
4370
4331
{
4371
size_t i;
4372
int sign;
4332
register const unsigned char *p = f->data;
4333
const unsigned char *end = p + f->size - 1;
4334
4335
/* Check sign */
4336
{
4337
const char sign = *end & 0x0F;
4338
if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
4339
/* COMP-6 - Check last nibble */
4340
if (sign > 0x09) {
4341
return 0;
4342
}
4343
} else if (COB_FIELD_HAVE_SIGN (f)) {
4344
if (COB_MODULE_PTR->flag_host_sign
4345
&& sign == 0x0F) {
4346
/* all fine, go on */
4347
} else
4348
if (sign != 0x0C
4349
&& sign != 0x0D) {
4350
return 0;
4351
}
4352
} else if (sign != 0x0F) {
4353
return 0;
4354
}
4355
}
4356
4357
/* Check high nibble of last byte */
4358
if ((*end & 0xF0) > 0x90) {
4359
return 0;
4360
}
4361
4373
4362
/* Check digits */
4374
for (i = 0; i < f->size - 1; ++i) {
4375
if ((f->data[i] & 0xF0) > 0x90
4376
|| (f->data[i] & 0x0F) > 0x09) {
4377
return 0;
4378
}
4379
}
4380
/* Check high nibble of last byte */
4381
if ((f->data[i] & 0xF0) > 0x90) {
4382
return 0;
4383
}
4384
4385
if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
4386
/* COMP-6 - Check last nibble */
4387
if ((f->data[i] & 0x0F) > 0x09) {
4388
return 0;
4389
}
4390
return 1;
4391
}
4392
4393
/* Check sign */
4394
sign = f->data[i] & 0x0F;
4395
if (COB_FIELD_HAVE_SIGN (f)) {
4396
if (sign == 0x0C || sign == 0x0D) {
4397
return 1;
4398
}
4399
if (COB_MODULE_PTR->flag_host_sign
4400
&& sign == 0x0F) {
4401
return 1;
4402
}
4403
} else if (sign == 0x0F) {
4404
return 1;
4405
}
4406
return 0;
4363
while (p < end) {
4364
if (IS_INVALID_BCD_DATA (*p)) {
4365
return 0;
4366
}
4367
p++;
4368
}
4369
4370
return 1;
4407
4371
}
4408
4372
case COB_TYPE_NUMERIC_DISPLAY:
4409
4373
return cob_check_numdisp (f);
4421
4385
#endif
4422
4386
default:
4423
4387
{
4424
size_t i;
4425
for (i = 0; i < f->size; ++i) {
4426
if (!isdigit (f->data[i])) {
4388
register const unsigned char *p = f->data;
4389
const unsigned char *end = p + f->size;
4390
4391
while (p < end) {
4392
if (IS_INVALID_DIGIT_DATA (*p)) {
4427
4393
return 0;
4428
4394
}
4395
p++;
4429
4396
}
4430
4397
return 1;
4431
4398
}
4435
4402
int
4436
4403
cob_is_alpha (const cob_field *f)
4437
4404
{
4438
size_t i;
4405
register const unsigned char *p = f->data;
4406
const unsigned char *end = p + f->size;
4439
4407
4440
for (i = 0; i < f->size; ++i) {
4441
if (!isalpha (f->data[i]) && f->data[i] != (unsigned char)' ') {
4408
while (p < end) {
4409
if (*p == (unsigned char)' '
4410
|| isalpha (*p)) {
4411
p++;
4412
} else {
4442
4413
return 0;
4443
4414
}
4444
4415
}
4448
4419
int
4449
4420
cob_is_upper (const cob_field *f)
4450
4421
{
4451
size_t i;
4422
register const unsigned char *p = f->data;
4423
const unsigned char *end = p + f->size;
4452
4424
4453
for (i = 0; i < f->size; ++i) {
4454
if (!isupper (f->data[i]) && f->data[i] != (unsigned char)' ') {
4425
while (p < end) {
4426
if (*p == (unsigned char)' '
4427
|| isupper (*p)) {
4428
p++;
4429
} else {
4455
4430
return 0;
4456
4431
}
4457
4432
}
4461
4436
int
4462
4437
cob_is_lower (const cob_field *f)
4463
4438
{
4464
size_t i;
4439
register const unsigned char *p = f->data;
4440
const unsigned char *end = p + f->size;
4465
4441
4466
for (i = 0; i < f->size; ++i) {
4467
if (!islower (f->data[i]) && f->data[i] != (unsigned char)' ') {
4442
while (p < end) {
4443
if (*p == (unsigned char)' '
4444
|| islower (*p)) {
4445
p++;
4446
} else {
4468
4447
return 0;
4469
4448
}
4470
4449
}
4560
4539
case COB_TYPE_NUMERIC_BINARY:
4561
4540
return "BINARY";
4562
4541
case COB_TYPE_NUMERIC_PACKED:
4542
if (COB_FIELD_NO_SIGN_NIBBLE (f)) {
4543
return "COMP-6";
4544
}
4545
if (!COB_FIELD_HAVE_SIGN (f)) {
4546
return "PACKED-DECIMAL (unsigned)";
4547
}
4563
4548
return "PACKED-DECIMAL";
4564
4549
case COB_TYPE_NUMERIC_FLOAT:
4565
4550
return "FLOAT";
4601
4586
void
4602
4587
cob_check_numeric (const cob_field *f, const char *name)
4603
4588
{
4604
unsigned char *data;
4605
char *p;
4606
char *buff;
4607
size_t i;
4608
4609
4589
if (!cob_is_numeric (f)) {
4590
register unsigned char *data = f->data;
4591
unsigned char *end = data + f->size;
4592
char *p;
4593
char *buff;
4594
4610
4595
cob_set_exception (COB_EC_DATA_INCOMPATIBLE);
4611
4596
buff = cob_fast_malloc ((size_t)COB_SMALL_BUFF);
4612
4597
p = buff;
4613
data = f->data;
4614
4598
if (COB_FIELD_IS_NUMDISP(f) || COB_FIELD_IS_ANY_ALNUM(f)) {
4615
for (i = 0; i < f->size; ++i) {
4616
if (isprint (data[i])) {
4617
*p++ = data[i];
4599
while (data < end) {
4600
if (isprint (*data)) {
4601
*p++ = *data++;
4618
4602
} else {
4619
p += sprintf (p, "\\%03o", data[i]);
4603
p += sprintf (p, "\\%03o", *data++);
4620
4604
}
4621
4605
}
4622
4606
} else {
4623
4607
p += sprintf (p, "0x");
4624
for (i = 0; i < f->size; ++i) {
4625
p += sprintf (p, "%02x", data[i]);
4608
while (data < end) {
4609
p += sprintf (p, "%02x", *data++);
4626
4610
}
4627
4611
}
4628
4612
*p = '\0';
4840
4824
time_t utctime, lcltime, difftime;
4841
4825
#endif
4842
4826
4843
#ifndef TIME_T_IS_NON_ARITHMETIC
4844
4827
static time_t last_time = 0;
4845
4828
static struct cob_time last_cobtime;
4846
4829
4847
/* FIXME: on reseting appropriate locale set last_time_no_sec = 0 */
4830
/* FIXME: on setting related locale set last_time = 0 */
4848
4831
if (curtime == last_time) {
4849
4832
memcpy (cb_time, &last_cobtime, sizeof (struct cob_time));
4850
4833
return;
4877
4860
}
4878
4861
}
4879
4862
last_time = curtime;
4880
#endif
4881
4863
4882
4864
tmptr = localtime (&curtime);
4883
4865
4932
4914
/* LCOV_EXCL_STOP */
4933
4915
#endif
4934
4916
4935
#ifndef TIME_T_IS_NON_ARITHMETIC
4936
4917
/* keep backup for next call */
4937
4918
memcpy (&last_cobtime, cb_time, sizeof (struct cob_time));
4938
#endif
4939
4919
}
4940
4920
4941
4921
#if defined (_WIN32) /* cygwin does not define _WIN32 */
5102
5082
}
5103
5083
5104
5084
int
5105
cob_set_date_from_epoch (struct cob_time *cb_time, const char *config)
5085
cob_set_date_from_epoch (struct cob_time *cb_time, const unsigned char *p)
5106
5086
{
5107
5087
struct tm *tmptr;
5108
5088
time_t t = 0;
5109
5089
long long seconds = 0;
5110
unsigned char *p = (unsigned char *)config;
5111
5090
5112
while (isdigit (*p)) {
5113
seconds = seconds * 10 + *p - '0';
5114
p++;
5091
while (IS_VALID_DIGIT_DATA (*p)) {
5092
seconds = seconds * 10 + COB_D2I (*p++);
5115
5093
}
5116
5094
if (*p != 0 || seconds > 253402300799) {
5117
5095
/* The value (as a unix timestamp) corresponds to date
5158
5136
{
5159
5137
int yr, mm, dd, hh, mi, ss, ns;
5160
5138
int offset = 9999;
5161
int i, j, ret;
5139
int i, ret;
5162
5140
time_t t;
5163
5141
struct tm *tmptr;
5164
5142
char iso_timezone[7] = { 0 };
5165
char nanoseconds[10];
5143
unsigned char *p = (unsigned char*)cobsetptr->cob_date;
5166
5144
5167
if (cobsetptr == NULL
5168
|| cobsetptr->cob_date == NULL) {
5145
if (p == NULL) {
5169
5146
return;
5170
5147
}
5171
5148
5172
j = 0;
5173
5174
5149
/* skip quotes and space-characters */
5175
while (cobsetptr->cob_date[j] == '\''
5176
|| cobsetptr->cob_date[j] == '"'
5177
|| isspace((unsigned char)cobsetptr->cob_date[j])) {
5178
j++;
5150
while (*p == '\''
5151
|| *p == '"'
5152
|| isspace (*p)) {
5153
p++;
5179
5154
}
5180
5155
5181
5156
/* extract epoch, if specified */
5182
if (cobsetptr->cob_date[j] == '@') {
5157
if (*p == '@') {
5183
5158
/* @sssssssss seconds since epoch */
5184
ret = cob_set_date_from_epoch (&cobsetptr->cob_time_constant, cobsetptr->cob_date + j + 1);
5159
ret = cob_set_date_from_epoch (&cobsetptr->cob_time_constant, ++p);
5185
5160
if (ret) {
5186
5161
cob_runtime_warning (_("COB_CURRENT_DATE '%s' is invalid"), cobsetptr->cob_date);
5187
5162
}
5192
5167
ret = 0;
5193
5168
5194
5169
/* extract date */
5195
if (cobsetptr->cob_date[j] != 0) {
5170
if (*p) {
5196
5171
yr = 0;
5197
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5198
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5199
yr = yr * 10 + COB_D2I (cobsetptr->cob_date[j]);
5200
} else {
5172
for (i = 0; *p; p++) {
5173
if (IS_INVALID_DIGIT_DATA (*p)) {
5201
5174
break;
5202
5175
}
5176
yr = yr * 10 + COB_D2I (*p);
5203
5177
if (++i == 4) {
5204
j++;
5178
p++;
5205
5179
break;
5206
5180
}
5207
5181
}
5208
5182
if (i != 2 && i != 4) {
5209
5183
/* possible template with partial system lookup */
5210
if (cobsetptr->cob_date[j] == 'Y') {
5211
while (cobsetptr->cob_date[j] == 'Y') j++;
5184
if (*p == 'Y') {
5185
while (*p == 'Y') p++;
5212
5186
} else {
5213
5187
ret = 1;
5214
5188
}
5216
5190
} else if (yr < 100) {
5217
5191
yr += 2000;
5218
5192
}
5219
if (cobsetptr->cob_date[j] == '/'
5220
|| cobsetptr->cob_date[j] == '-') {
5221
j++;
5193
if (*p == '/'
5194
|| *p == '-') {
5195
p++;
5222
5196
}
5223
5197
}
5224
if (cobsetptr->cob_date[j] != 0) {
5198
if (*p) {
5225
5199
mm = 0;
5226
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5227
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5228
mm = mm * 10 + COB_D2I (cobsetptr->cob_date[j]);
5229
} else {
5200
for (i = 0; *p; p++) {
5201
if (IS_INVALID_DIGIT_DATA (*p)) {
5230
5202
break;
5231
5203
}
5204
mm = mm * 10 + COB_D2I (*p);
5232
5205
if (++i == 2) {
5233
j++;
5206
p++;
5234
5207
break;
5235
5208
}
5236
5209
}
5237
5210
if (i != 2) {
5238
5211
/* possible template with partial system lookup */
5239
if (cobsetptr->cob_date[j] == 'M') {
5240
while (cobsetptr->cob_date[j] == 'M') j++;
5212
if (*p == 'M') {
5213
while (*p == 'M') p++;
5241
5214
} else {
5242
5215
ret = 1;
5243
5216
}
5245
5218
} else if (mm < 1 || mm > 12) {
5246
5219
ret = 1;
5247
5220
}
5248
if (cobsetptr->cob_date[j] == '/'
5249
|| cobsetptr->cob_date[j] == '-') {
5250
j++;
5221
if (*p == '/'
5222
|| *p == '-') {
5223
p++;
5251
5224
}
5252
5225
}
5253
if (cobsetptr->cob_date[j] != 0) {
5226
if (*p) {
5254
5227
dd = 0;
5255
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5256
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5257
dd = dd * 10 + COB_D2I (cobsetptr->cob_date[j]);
5258
} else {
5228
for (i = 0; *p; p++) {
5229
if (IS_INVALID_DIGIT_DATA (*p)) {
5259
5230
break;
5260
5231
}
5232
dd = dd * 10 + COB_D2I (*p);
5261
5233
if (++i == 2) {
5262
j++;
5234
p++;
5263
5235
break;
5264
5236
}
5265
5237
}
5266
5238
if (i != 2) {
5267
5239
/* possible template with partial system lookup */
5268
if (cobsetptr->cob_date[j] == 'D') {
5269
while (cobsetptr->cob_date[j] == 'D') j++;
5240
if (*p == 'D') {
5241
while (*p == 'D') p++;
5270
5242
} else {
5271
5243
ret = 1;
5272
5244
}
5277
5249
}
5278
5250
5279
5251
/* extract time */
5280
if (cobsetptr->cob_date[j] != 0) {
5252
if (*p) {
5281
5253
hh = 0;
5282
while (isspace ((unsigned char)cobsetptr->cob_date[j])) j++;
5283
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5284
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5285
hh = hh * 10 + COB_D2I (cobsetptr->cob_date[j]);
5286
} else {
5254
while (isspace (*p)) p++;
5255
for (i = 0; *p; p++) {
5256
if (IS_INVALID_DIGIT_DATA (*p)) {
5287
5257
break;
5288
5258
}
5259
hh = hh * 10 + COB_D2I (*p);
5289
5260
if (++i == 2) {
5290
j++;
5261
p++;
5291
5262
break;
5292
5263
}
5293
5264
}
5294
5265
5295
5266
if (i != 2) {
5296
5267
/* possible template with partial system lookup */
5297
if (cobsetptr->cob_date[j] == 'H') {
5298
while (cobsetptr->cob_date[j] == 'H') j++;
5268
if (*p == 'H') {
5269
while (*p == 'H') p++;
5299
5270
} else {
5300
5271
ret = 1;
5301
5272
}
5303
5274
} else if (hh > 23) {
5304
5275
ret = 1;
5305
5276
}
5306
if (cobsetptr->cob_date[j] == ':'
5307
|| cobsetptr->cob_date[j] == '-')
5308
j++;
5277
if (*p == ':'
5278
|| *p == '-')
5279
p++;
5309
5280
}
5310
if (cobsetptr->cob_date[j] != 0) {
5281
if (*p) {
5311
5282
mi = 0;
5312
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5313
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5314
mi = mi * 10 + COB_D2I (cobsetptr->cob_date[j]);
5315
} else {
5283
for (i = 0; *p; p++) {
5284
if (IS_INVALID_DIGIT_DATA (*p)) {
5316
5285
break;
5317
5286
}
5287
mi = mi * 10 + COB_D2I (*p);
5318
5288
if (++i == 2) {
5319
j++;
5289
p++;
5320
5290
break;
5321
5291
}
5322
5292
}
5323
5293
if (i != 2) {
5324
5294
/* possible template with partial system lookup */
5325
if (cobsetptr->cob_date[j] == 'M') {
5326
while (cobsetptr->cob_date[j] == 'M') j++;
5295
if (*p == 'M') {
5296
while (*p == 'M') p++;
5327
5297
} else {
5328
5298
ret = 1;
5329
5299
}
5331
5301
} else if (mi > 59) {
5332
5302
ret = 1;
5333
5303
}
5334
if (cobsetptr->cob_date[j] == ':'
5335
|| cobsetptr->cob_date[j] == '-') {
5336
j++;
5304
if (*p == ':'
5305
|| *p == '-') {
5306
p++;
5337
5307
}
5338
5308
}
5339
5309
5340
if (cobsetptr->cob_date[j] != 0
5341
&& cobsetptr->cob_date[j] != 'Z'
5342
&& cobsetptr->cob_date[j] != '+'
5343
&& cobsetptr->cob_date[j] != '-') {
5310
if (*p != 0
5311
&& *p != 'Z'
5312
&& *p != '+'
5313
&& *p != '-') {
5344
5314
ss = 0;
5345
for (i = 0; cobsetptr->cob_date[j] != 0; j++) {
5346
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5347
ss = ss * 10 + COB_D2I (cobsetptr->cob_date[j]);
5348
} else {
5315
for (i = 0; *p != 0; p++) {
5316
if (IS_INVALID_DIGIT_DATA (*p)) {
5349
5317
break;
5350
5318
}
5319
ss = ss * 10 + COB_D2I (*p);
5351
5320
if (++i == 2) {
5352
j++;
5321
p++;
5353
5322
break;
5354
5323
}
5355
5324
}
5356
5325
if (i != 2) {
5357
5326
/* possible template with partial system lookup */
5358
if (cobsetptr->cob_date[j] == 'S') {
5359
while (cobsetptr->cob_date[j] == 'S') j++;
5327
if (*p == 'S') {
5328
while (*p == 'S') p++;
5360
5329
} else {
5361
5330
ret = 1;
5362
5331
}
5368
5337
}
5369
5338
5370
5339
/* extract nanoseconds */
5371
if (cobsetptr->cob_date[j] != 0
5372
&& cobsetptr->cob_date[j] != 'Z'
5373
&& cobsetptr->cob_date[j] != '+'
5374
&& cobsetptr->cob_date[j] != '-') {
5340
if (*p != 0
5341
&& *p != 'Z'
5342
&& *p != '+'
5343
&& *p != '-') {
5375
5344
ns = 0;
5376
if (cobsetptr->cob_date[j] == '.'
5377
|| cobsetptr->cob_date[j] == ':') {
5378
j++;
5345
if (*p == '.'
5346
|| *p == ':') {
5347
p++;
5379
5348
}
5380
strcpy (nanoseconds, "000000000");
5381
for (i=0; cobsetptr->cob_date[j] != 0; j++) {
5382
if (isdigit ((unsigned char)cobsetptr->cob_date[j])) {
5383
nanoseconds[i] = cobsetptr->cob_date[j];
5384
} else {
5349
for (i = 0; *p; p++) {
5350
if (IS_INVALID_DIGIT_DATA (*p)) {
5385
5351
break;
5386
5352
}
5353
ns = ns * 10 + COB_D2I (*p);
5387
5354
if (++i == 9) {
5388
j++;
5355
p++;
5389
5356
break;
5390
5357
}
5391
5358
}
5392
ns = atoi(nanoseconds);
5393
5359
}
5394
5360
5395
5361
/* extract UTC offset */
5396
if (cobsetptr->cob_date[j] == 'Z') {
5362
if (*p == 'Z') {
5397
5363
offset = 0;
5398
5364
iso_timezone[0] = 'Z';
5399
} else if (cobsetptr->cob_date[j] == '+'
5400
|| cobsetptr->cob_date[j] == '-') {
5401
int len = snprintf (&iso_timezone[0], 7, "%s", cobsetptr->cob_date + j);
5365
} else
5366
if (*p == '+'
5367
|| *p == '-') {
5368
/* we operate on a buffer here to drop the included ":" */
5369
int len = snprintf (&iso_timezone[0], 7, "%s", p);
5402
5370
if (len == 3) {
5403
5371
memcpy (iso_timezone + 3, "00", 3);
5404
5372
} else
5405
5373
if (len >= 5 && iso_timezone[3] == ':') {
5406
snprintf (&iso_timezone[3], 3, "%s", cobsetptr->cob_date + j + 4);
5374
snprintf (&iso_timezone[3], 3, "%s", p + 4);
5407
5375
len--;
5408
5376
}
5409
5377
if (len > 5) {
5410
5378
ret = 1;
5411
5379
}
5412
for (i=1; i < 5 && iso_timezone[i] != 0; i++) {
5413
if (!isdigit ((unsigned char)iso_timezone[i])) {
5380
for (i = 1; i < 5 && iso_timezone[i] != 0; i++) {
5381
if (IS_INVALID_DIGIT_DATA (iso_timezone[i])) {
5414
5382
break;
5415
5383
}
5416
5384
}
5417
5385
i--;
5418
5386
if (i == 4) {
5419
5387
offset = COB_D2I (iso_timezone[1]) * 60 * 10
5420
+ COB_D2I (iso_timezone[2]) * 60
5421
+ COB_D2I (iso_timezone[3]) * 10
5422
+ COB_D2I (iso_timezone[4]);
5388
+ COB_D2I (iso_timezone[2]) * 60
5389
+ COB_D2I (iso_timezone[3]) * 10
5390
+ COB_D2I (iso_timezone[4]);
5423
5391
if (iso_timezone[0] == '-') {
5424
5392
offset *= -1;
5425
5393
}
5532
5500
+ (time.year % 100) * 10000;
5533
5501
cob_field field;
5534
5502
cob_field_attr attr;
5535
const size_t digits = 6;
5503
const unsigned short digits = 6;
5536
5504
5537
5505
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr);
5538
5506
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5554
5522
+ time.year * 10000;
5555
5523
cob_field field;
5556
5524
cob_field_attr attr;
5557
const size_t digits = 8;
5525
const unsigned short digits = 8;
5558
5526
5559
5527
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr);
5560
5528
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5574
5542
const cob_u32_t val = time.day_of_year + (time.year % 100) * 1000;
5575
5543
cob_field field;
5576
5544
cob_field_attr attr;
5577
const size_t digits = 5;
5545
const unsigned short digits = 5;
5578
5546
5579
5547
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr);
5580
5548
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5594
5562
const cob_u32_t val = time.day_of_year + time.year * 1000;
5595
5563
cob_field field;
5596
5564
cob_field_attr attr;
5597
const size_t digits = 7;
5565
const unsigned short digits = 7;
5598
5566
5599
5567
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr);
5600
5568
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5612
5580
{
5613
5581
const struct cob_time time = cob_get_current_datetime (DTR_DATE);
5614
5582
const unsigned char day = (unsigned char)(time.day_of_week + '0');
5615
const size_t digits = 1;
5583
const unsigned short digits = 1;
5616
5584
cob_move_intermediate (f, &day, digits);
5617
5585
}
5618
5586
5629
5597
+ time.hour * 1000000;
5630
5598
cob_field field;
5631
5599
cob_field_attr attr;
5632
const size_t digits = 8;
5600
const unsigned short digits = 8;
5633
5601
5634
5602
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&val, &attr);
5635
5603
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5652
5620
+ (cob_u64_t)time.hour * 10000000000;
5653
5621
cob_field field;
5654
5622
cob_field_attr attr;
5655
const size_t digits = 12;
5623
const unsigned short digits = 12;
5656
5624
5657
5625
COB_FIELD_INIT (sizeof (cob_u64_t), (unsigned char *)&val, &attr);
5658
5626
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5726
5694
int n;
5727
5695
cob_field field;
5728
5696
cob_field_attr attr;
5729
const size_t digits = 9;
5697
const unsigned short digits = 9;
5730
5698
5731
5699
COB_FIELD_INIT (4, (unsigned char *)&n, &attr);
5732
5700
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5744
5712
const cob_u32_t n = cob_argc - 1;
5745
5713
cob_field field;
5746
5714
cob_field_attr attr;
5747
const size_t digits = 9;
5715
const unsigned short digits = 9;
5748
5716
5749
5717
COB_FIELD_INIT (sizeof (cob_u32_t), (unsigned char *)&n, &attr);
5750
5718
COB_ATTR_INIT (COB_TYPE_NUMERIC_BINARY, digits, 0, 0, NULL);
5854
5822
void
5855
5823
cob_display_environment (const cob_field *f)
5856
5824
{
5857
size_t i;
5825
int ret;
5858
5826
5859
5827
if (cob_local_env_size < f->size) {
5860
5828
cob_local_env_size = f->size;
5863
5831
}
5864
5832
cob_local_env = cob_malloc (cob_local_env_size + 1U);
5865
5833
}
5866
cob_field_to_string (f, cob_local_env, cob_local_env_size);
5834
ret = cob_field_to_string (f, cob_local_env, cob_local_env_size, CCM_NONE);
5835
if (ret < 0) {
5836
return;
5837
}
5867
5838
if (cobsetptr->cob_env_mangle) {
5868
const size_t len = strlen (cob_local_env);
5839
const size_t len = ret;
5840
size_t i;
5869
5841
for (i = 0; i < len; ++i) {
5870
5842
if (!isalnum ((int)cob_local_env[i])) {
5871
5843
cob_local_env[i] = '_';
5874
5846
}
5875
5847
}
5876
5848
5849
/* DISPLAY ... UPON ENVIRONMENT VALUE */
5877
5850
void
5878
5851
cob_display_env_value (const cob_field *f)
5879
5852
{
5880
char *env2;
5881
5853
int ret;
5882
5854
5883
if (!cob_local_env) {
5884
cob_set_exception (COB_EC_IMP_DISPLAY);
5885
return;
5886
}
5887
if (!*cob_local_env) {
5888
cob_set_exception (COB_EC_IMP_DISPLAY);
5889
return;
5890
}
5891
env2 = cob_malloc (f->size + 1U);
5892
cob_field_to_string (f, env2, f->size);
5893
ret = cob_setenv (cob_local_env, env2, 1);
5894
cob_free (env2);
5855
if (!cob_local_env
5856
|| !cob_local_env[0]) {
5857
cob_set_exception (COB_EC_IMP_DISPLAY);
5858
return;
5859
}
5860
{
5861
char buff[COB_MEDIUM_BUFF];
5862
int flen = cob_field_to_string (f, buff,
5863
COB_MEDIUM_MAX, CCM_NONE);
5864
if (flen < 0) {
5865
cob_set_exception (COB_EC_IMP_DISPLAY);
5866
return;
5867
}
5868
ret = cob_setenv (cob_local_env, buff, 1);
5869
}
5895
5870
if (ret != 0) {
5896
5871
cob_set_exception (COB_EC_IMP_DISPLAY);
5897
5872
return;
5910
5885
void
5911
5886
cob_get_environment (const cob_field *envname, cob_field *envval)
5912
5887
{
5913
const char *p;
5914
char *buff;
5915
size_t size;
5888
char buff[COB_MEDIUM_BUFF];
5889
char *p;
5890
int flen;
5916
5891
5917
5892
if (envname->size == 0 || envval->size == 0) {
5918
5893
cob_set_exception (COB_EC_IMP_ACCEPT);
5919
5894
return;
5920
5895
}
5921
5896
5922
buff = cob_malloc (envname->size + 1U);
5923
cob_field_to_string (envname, buff, envname->size);
5897
flen = cob_field_to_string (envname, buff,
5898
COB_MEDIUM_MAX, CCM_NONE);
5899
if (flen < 1) {
5900
cob_set_exception (COB_EC_IMP_ACCEPT);
5901
return;
5902
}
5903
5924
5904
if (cobsetptr->cob_env_mangle) {
5925
const size_t len = strlen (buff);
5926
for (size = 0; size < len; ++size) {
5927
if (!isalnum ((int)buff[size])) {
5928
buff[size] = '_';
5905
const char *p_end = buff + flen;
5906
for (p = buff; p < p_end; ++p) {
5907
if (!isalnum ((int)*p)) {
5908
*p = '_';
5929
5909
}
5930
5910
}
5931
5911
}
5932
5912
p = getenv (buff);
5933
if (!p) {
5913
if (p) {
5914
cob_move_intermediate (envval, p, strlen (p));
5915
} else {
5934
5916
cob_set_exception (COB_EC_IMP_ACCEPT);
5935
p = " ";
5917
cob_move_intermediate (envval, " ", 1);
5936
5918
}
5937
cob_move_intermediate (envval, p, strlen (p));
5938
cob_free (buff);
5939
5919
}
5940
5920
5941
5921
void
5946
5926
if (cob_local_env) {
5947
5927
p = getenv (cob_local_env);
5948
5928
}
5949
if (!p) {
5929
if (p) {
5930
cob_move_intermediate (f, p, strlen (p));
5931
} else {
5950
5932
cob_set_exception (COB_EC_IMP_ACCEPT);
5951
p = " ";
5933
cob_move_intermediate (f, " ", 1);
5952
5934
}
5953
cob_move_intermediate (f, p, strlen (p));
5954
5935
}
5955
5936
5956
5937
void
5957
5938
cob_chain_setup (void *data, const size_t parm, const size_t size)
5958
5939
{
5959
size_t len;
5960
5961
5940
/* only set if given on command-line, otherwise use normal
5962
5941
program internal initialization */
5963
5942
if (parm <= (size_t)cob_argc - 1) {
5943
const size_t len = strlen (cob_argv[parm]);
5964
5944
memset (data, ' ', size);
5965
len = strlen (cob_argv[parm]);
5966
5945
if (len <= size) {
5967
5946
memcpy (data, cob_argv[parm], len);
5968
5947
} else {
5977
5956
cob_s64_t nanoseconds = get_sleep_nanoseconds_from_seconds (decimal_seconds);
5978
5957
5979
5958
if (nanoseconds < 0) {
5980
/* TODO: current COBOL 20xx change proposal
5981
specifies EC-CONTINUE-LESS-THAN-ZERO (NF) here... */
5959
cob_set_exception (COB_EC_CONTINUE_LESS_THAN_ZERO);
5982
5960
return;
5983
5961
}
5984
5962
internal_nanosleep (nanoseconds, 0);
6642
6620
6643
6621
if (COB_MODULE_PTR->cob_procedure_params[1]) {
6644
6622
i = (int)COB_MODULE_PTR->cob_procedure_params[1]->size;
6645
if ((i == 4) && !strncmp (name, "argc", 4)) {
6623
if ((i == 4) && !memcmp (name, "argc", 4)) {
6646
6624
*((int *)data) = cob_argc;
6647
6625
return 0;
6648
6626
}
6649
if ((i == 4) && !strncmp (name, "argv", 4)) {
6627
if ((i == 4) && !memcmp (name, "argv", 4)) {
6650
6628
*((char ***)data) = cob_argv;
6651
6629
return 0;
6652
6630
}
6653
if ((i == 5) && !strncmp (name, "stdin", 5)) {
6631
if ((i == 5) && !memcmp (name, "stdin", 5)) {
6654
6632
*((FILE **)data) = stdin;
6655
6633
return 0;
6656
6634
}
6657
if ((i == 6) && !strncmp (name, "stdout", 6)) {
6635
if ((i == 6) && !memcmp (name, "stdout", 6)) {
6658
6636
*((FILE **)data) = stdout;
6659
6637
return 0;
6660
6638
}
6661
if ((i == 6) && !strncmp (name, "stderr", 6)) {
6639
if ((i == 6) && !memcmp (name, "stderr", 6)) {
6662
6640
*((FILE **)data) = stderr;
6663
6641
return 0;
6664
6642
}
6665
if ((i == 5) && !strncmp (name, "errno", 5)) {
6643
if ((i == 5) && !memcmp (name, "errno", 5)) {
6666
6644
*((int **)data) = &errno;
6667
6645
return 0;
6668
6646
}
6669
6647
#if defined (HAVE_TIMEZONE)
6670
if ((i == 6) && !strncmp (name, "tzname", 6)) {
6648
if ((i == 6) && !memcmp (name, "tzname", 6)) {
6671
6649
/* Recheck: bcc raises "suspicious pointer conversion */
6672
6650
*((char ***)data) = tzname;
6673
6651
return 0;
6674
6652
}
6675
if ((i == 8) && !strncmp (name, "timezone", 8)) {
6653
if ((i == 8) && !memcmp (name, "timezone", 8)) {
6676
6654
*((long *)data) = timezone;
6677
6655
return 0;
6678
6656
}
6679
if ((i == 8) && !strncmp (name, "daylight", 8)) {
6657
if ((i == 8) && !memcmp (name, "daylight", 8)) {
6680
6658
*((int *)data) = daylight;
6681
6659
return 0;
6682
6660
}
7514
7492
/* add 0-termination to strings */
7515
7493
shortoptions = cob_malloc (so_size + 1U);
7516
7494
if (COB_MODULE_PTR->cob_procedure_params[0]) {
7517
cob_field_to_string (COB_MODULE_PTR->cob_procedure_params[0], shortoptions, so_size);
7495
cob_field_to_string (COB_MODULE_PTR->cob_procedure_params[0],
7496
shortoptions, so_size, CCM_NONE);
7518
7497
}
7519
7498
7520
7499
if (COB_MODULE_PTR->cob_procedure_params[1]) {
7734
7713
cob_set_locale (cob_field *locale, const int category)
7735
7714
{
7736
7715
#ifdef HAVE_SETLOCALE
7716
char buff[COB_MINI_BUFF];
7737
7717
char *p;
7738
char *buff;
7739
7718
7740
p = NULL;
7741
7719
if (locale) {
7742
if (locale->size == 0) {
7720
int flen = cob_field_to_string (locale, buff,
7721
COB_MINI_MAX, CCM_NONE);
7722
if (flen < 1) {
7743
7723
return;
7744
7724
}
7745
buff = cob_malloc (locale->size + 1U);
7746
cob_field_to_string (locale, buff, locale->size);
7725
p = buff;
7747
7726
} else {
7748
buff = NULL;
7727
p = NULL;
7749
7728
}
7750
7729
7751
7730
switch (category) {
7752
7731
case COB_LC_COLLATE:
7753
p = setlocale (LC_COLLATE, buff);
7732
p = setlocale (LC_COLLATE, p);
7754
7733
break;
7755
7734
case COB_LC_CTYPE:
7756
p = setlocale (LC_CTYPE, buff);
7735
p = setlocale (LC_CTYPE, p);
7757
7736
break;
7758
7737
#ifdef LC_MESSAGES
7759
7738
case COB_LC_MESSAGES:
7760
p = setlocale (LC_MESSAGES, buff);
7739
p = setlocale (LC_MESSAGES, p);
7761
7740
break;
7762
7741
#endif
7763
7742
case COB_LC_MONETARY:
7764
p = setlocale (LC_MONETARY, buff);
7743
p = setlocale (LC_MONETARY, p);
7765
7744
break;
7766
7745
case COB_LC_NUMERIC:
7767
p = setlocale (LC_NUMERIC, buff);
7746
p = setlocale (LC_NUMERIC, p);
7768
7747
break;
7769
7748
case COB_LC_TIME:
7770
p = setlocale (LC_TIME, buff);
7749
p = setlocale (LC_TIME, p);
7771
7750
break;
7772
7751
case COB_LC_ALL:
7773
p = setlocale (LC_ALL, buff);
7752
p = setlocale (LC_ALL, p);
7774
7753
break;
7775
7754
case COB_LC_USER:
7776
7755
if (cobglobptr->cob_locale_orig) {
7784
7763
}
7785
7764
break;
7786
7765
}
7787
if (buff) {
7788
cob_free (buff);
7789
}
7790
7766
if (!p) {
7791
7767
cob_set_exception (COB_EC_LOCALE_MISSING);
7792
7768
return;
8101
8077
if (ptr == NULL || *ptr == 0) {
8102
8078
return 2;
8103
8079
}
8104
if (*(ptr + 1) == 0 && isdigit ((unsigned char)*ptr)) {
8105
return atoi (ptr); /* 0 or 1 */
8080
if (*(ptr + 1) == 0
8081
&& (*ptr == '0' || *ptr == '1')) {
8082
return COB_D2I (*ptr); /* 0 or 1 */
8106
8083
} else
8107
8084
/* pre-translated boolean "never" - not set" */
8108
8085
if (strcmp (ptr, "!") == 0) {
8129
8106
static int /* returns 1 if any error, else 0 */
8130
8107
set_config_val (char *value, int pos)
8131
8108
{
8132
char *ptr = value, *str;
8109
register char *ptr = value;
8110
char *str;
8133
8111
cob_s64_t numval = 0;
8134
8112
int i, slen;
8135
8113
8216
8194
sign = *ptr;
8217
8195
ptr++;
8218
8196
}
8219
if (!isdigit ((unsigned char)*ptr)) {
8197
if (IS_INVALID_DIGIT_DATA (*ptr)) {
8220
8198
conf_runtime_error_value (ptr, pos);
8221
8199
conf_runtime_error (1, _("should be numeric"));
8222
8200
return 1;
8223
8201
}
8224
for (; *ptr != 0 && (isdigit ((unsigned char)*ptr)); ptr++) {
8225
numval = (numval * 10) + COB_D2I (*ptr);
8202
while (IS_VALID_DIGIT_DATA (*ptr)) {
8203
numval = (numval * 10) + COB_D2I (*ptr++);
8226
8204
}
8227
8205
if (sign != 0
8228
8206
&& ( *ptr == '-'
8333
8311
}
8334
8312
8335
8313
/* call internal routines that do post-processing */
8336
if (data == (char *)cobsetptr->cob_date) {
8314
if (data == (void *)cobsetptr->cob_date) {
8337
8315
check_current_date ();
8338
8316
}
8339
8317
8921
8899
}
8922
8900
}
8923
8901
}
8924
check_current_date();
8902
check_current_date ();
8925
8903
8926
8904
return 0;
8927
8905
}
9329
9307
err_cause = cob_get_filename_print (cobglobptr->cob_error_file, 1);
9330
9308
/* FIXME: additional check if referenced program has active code location */
9331
9309
if (cobglobptr->last_exception_statement == STMT_UNKNOWN) {
9332
cob_runtime_error (_ ("%s (status = %02d) for file %s"),
9310
cob_runtime_error (_("%s (status = %02d) for file %s"),
9333
9311
msg, status, err_cause);
9334
9312
} else {
9335
9313
cob_runtime_error (_("%s (status = %02d) for file %s on %s"),
10451
10429
/* Call inits with cobsetptr to get the addresses of all */
10452
10430
/* Screen-IO might be needed for error outputs */
10453
10431
cob_init_screenio (cobglobptr, cobsetptr);
10432
cob_init_cconv (cobglobptr);
10454
10433
cob_init_numeric (cobglobptr);
10455
10434
cob_init_strings (cobglobptr);
10456
10435
cob_init_move (cobglobptr, cobsetptr);
10505
10484
#endif
10506
10485
}
10507
10486
10508
#if defined(_MSC_VER)
10509
get_function_ptr_for_precise_time ();
10510
#endif
10511
10512
10487
/* This must be last in this function as we do early return */
10513
10488
/* from certain ifdef's */
10514
10489
Loggerhead is a web-based interface for Breezy
Version: 2.0.1