void msg1Prtln( const char * text, int * status ) {
int err; /* return value from printf */
size_t len = 0; /* Length of input text */
if (*status != SAI__OK) return;
/* how many characters do we expect to deliver (including newline) */
len = strlen( text ) + 1;
/* Note that we must add the newline */
err = printf( "%s\n", text );
/* only call fflush if printf succeeded so as not to reset errno */
if (err > 0) fflush(stdout);
if (err < 0) {
*status = MSG__OPTER;
emsMark();
emsSyser( "ERR", errno );
emsRep( "MSG_PRINT_MESS",
"msg1Prtln: Error printing message to stdout: ^ERR", status );
emsRlse();
} else if ((size_t)err != len) {
emsMark();
*status = MSG__OPTER;
emsSeti( "NEX", len );
emsSeti( "NGOT", err );
emsRep("MSG_PRINT_MESS",
"msg1Prtln: Error printing message to stdout. Printed ^NGOT"
" characters but expected to print ^NEX", status );
emsRlse();
}
}
int
datPut1L( const HDSLoc * locator,
size_t nval,
const hdsbool_t values[],
int * status ) {
size_t size;
hdsdim dim[1];
if ( *status != SAI__OK ) return *status;
datSize( locator, &size, status );
if ( *status == SAI__OK && size != nval ) {
*status = DAT__BOUND;
emsSeti( "IN", (int)nval );
emsSeti( "SZ", (int)size );
emsRep( "DAT_PUT1L_ERR", "Bounds mismatch: ^IN != ^SZ", status);
} else {
dim[0] = (hdsdim)size;
datPutL( locator, 1, dim, values, status );
}
return *status;
}
/* Function Definitons: */
void emsErrno( const char *token, int errval ){
char mess[EMS__SZTOK+1]; /* Message associated with errval */
TRACE("emsErrno");
/* Call EMS1_SERR */
ems1Serr( mess, EMS__SZTOK, &errval );
mess[EMS__SZTOK] = '\0';
/* Check for a good translation */
if ( strspn(mess," ") != EMS__SZTOK ){
/* OK - put the mesage in a token */
emsSetc( token, mess);
} else {
/* Bad - construct an error message */
emsSetc( token, "No translation for errno");
emsSetc( token, " ");
emsSeti( token, errval );
}
return;
}
void idlprimfill( HDSLoc *cloc, IDL_VPTR datav, void *datptr, int *status ) {
int j; /* loop counters */
UCHAR idltype; /* The IDL type */
char type[DAT__SZTYP+1]; /* Type in which to to map HDS data */
int bpix; /* Number of bytes/value */
int defined; /* If HDS value defined */
void *cpntr; /* True C pointer to mapped data */
size_t nels; /* Number of mapped elements */
int nels_i;
size_t nbytes; /* Number of bytes in array */
int flen; /* length of HDS strings */
int clen; /* length of corresponding C string */
char *chars; /* pointer to imported characters */
IDL_STRING *strings; /* pointer to array of string structures */
IDL_VPTR chptr; /* Scratch variable pointer */
if ( *status != SAI__OK ) return;
/* check type compatibility */
/* Get the number of bytes per element */
/* and the HDS type in which to map the data */
idltype = datav->type;
switch (idltype) {
case IDL_TYP_FLOAT:
strcpy( type, "_REAL" );
bpix = 4;
break;
case IDL_TYP_LONG:
strcpy( type, "_INTEGER" );
bpix = 4;
break;
case IDL_TYP_INT:
strcpy( type, "_WORD" );
bpix = 2;
break;
case IDL_TYP_DOUBLE:
strcpy( type, "_DOUBLE" );
bpix = 8;
break;
case IDL_TYP_BYTE:
strcpy( type, "_UBYTE" );
bpix = 1;
break;
case IDL_TYP_STRING:
datType( cloc, type, status);
bpix = 1;
break;
default:
/* flag no data to copy */
bpix = 0;
*status = SAI__ERROR;
emsSeti( "TYPE", idltype );
emsRep( " ", "Illegal IDL type ^TYPE", status );
break;
} /* end of case */
if ( (*status == SAI__OK ) && bpix ) {
/* Map the data as if a vector - provided it is defined */
datState( cloc, &defined, status );
if ( defined ) {
datMapV( cloc, type, "READ", &cpntr, &nels, status );
if ( *status != SAI__OK ) {
emsRep(" ", "Failed to map HDS component", status );
} else {
if ( idltype == IDL_TYP_STRING ) {
flen = atoi( type + 6 );
clen = flen + 1;
/* Import the Fortran strings to C */
nels_i = (int)nels;
chars = IDL_GetScratch( &chptr, nels_i, clen );
cnfImprta( cpntr, flen, chars, clen, 1, &nels_i );
/* set strings to be a pointer to the IDL_STRING structure(s) */
strings = (IDL_STRING *)datptr;
/* store the imported strings into the STRING structures */
for ( j=0; j<nels; j++ )
IDL_StrStore( strings+j, &chars[j*clen] );
IDL_Deltmp( chptr );
} else {
/* Type other than string */
if ( datav->flags & IDL_V_ARR ) {
/* Number Array */
/* copy the data to the array */
nbytes = bpix * nels;
memcpy( datptr, cpntr, nbytes );
} else {
/* Number Scalar */
switch (idltype) {
case IDL_TYP_FLOAT:
((IDL_ALLTYPES *)datptr)->f = *(float *)cpntr;
break;
case IDL_TYP_LONG:
((IDL_ALLTYPES *)datptr)->l = *(int *)cpntr;
break;
case IDL_TYP_INT:
((IDL_ALLTYPES *)datptr)->i = *(short *)cpntr;
break;
case IDL_TYP_DOUBLE:
((IDL_ALLTYPES *)datptr)->d = *(double *)cpntr;
break;
case IDL_TYP_BYTE:
((IDL_ALLTYPES *)datptr)->c = *(UCHAR *)cpntr;
break;
} /* end of case */
} /* end of if array */
} /* end if string */
datUnmap( cloc, status );
} /* end of mapped data */
} /* end of if defined */
} /* end of bpix non-zero */
return;
}
int
dau_flush_data(struct LCP_DATA *data)
/*+
* DAU_FLUSH_DATA - Flush mapped data
*
* This routine will unmap any primitive data that is currently mapped to the
* specified locator. If the data object is a discontiguous slice, then a
* scatter write-back is performed if mapped in either 'WRITE' or 'UPDATE' mode.
*
* Calling sequence:
*
* DAU_FLUSH_DATA(DATA)
*
* DATA is the address of the data part of the Locator Control Packet.
*
* Routine value:
*
* DAT__OK if successful.
*/
{
struct LCP_STATE *state;
struct PDD *app;
struct PDD *obj;
unsigned char *dom;
int writing;
INT_BIG objlen;
INT_BIG objoff;
INT_BIG applen;
int nbad;
int mapsave;
/* Return if no data currently mapped. */
state = &data->state;
if ( !state->mapped )
return hds_gl_status;
/* Begin a new error reporting context. */
emsBegin( &hds_gl_status );
/* Set the global file mapping flag to the value used when the data were */
/* originally mapped. */
mapsave = hds_gl_map;
hds_gl_map = data->filemap;
/* Associate the application data and object data attributes descriptors. */
app = &data->app;
obj = &data->obj;
writing = (data->mode != 'R');
/* Calculate the length (in bytes) of the virtual memory allocated to the
application program data and the corresponding length of the object data.
Determine the byte-offset into the object record's dynamic domain. */
applen = app->length * data->size;
objlen = obj->length * data->size;
objoff = obj->length * data->offset;
/* Scatter discontiguous object data if the program is writing or updating. */
if (state->broken)
{
if (writing)
{
dau_scatter_data(1, data, &nbad );
/* If conversion errors occurred, then report contextual information. */
if ( hds_gl_status == DAT__CONER )
{
emsSeti( "NBAD", nbad );
emsRep( "DAU_FLUSH_1",
"A total of ^NBAD data conversion error(s) occurred.",
&hds_gl_status );
}
}
rec_deall_xmem( applen, (void **) &app->body );
}
/* If a copy of the object data was given to the program, then locate the
record's dynamic domain and translate the data from the virtual memory copy.
*/
else if (state->vmcopy)
{
if (writing)
{
rec_locate_data(&data->han, objlen, objoff, 'W', &dom);
obj->body = dom;
dat1_cvt( 1, data->size, app, obj, &nbad );
/* If conversion errors occurred, then report contextual information. */
if ( hds_gl_status == DAT__CONER )
{
emsSeti( "NBAD", nbad );
emsRep( "DAU_FLUSH_2",
"A total of ^NBAD data conversion error(s) occurred.",
&hds_gl_status );
}
rec_release_data(&data->han, objlen, objoff, 'W', &dom);
}
rec_deall_xmem( applen, (void **) &app->body );
}
/* Otherwise, the application program was given direct access to the data. */
else
{
dom = app->body;
rec_release_data(&data->han, objlen, objoff, data->mode, &dom);
}
/* Clear the pointer and the map flags. */
app->body = 0;
state->mapped = 0;
state->unlike = 0;
state->vmcopy = 0;
/* Restore the global file mapping flag. */
hds_gl_map = mapsave;
/* End the error reporting context. */
emsEnd( &hds_gl_status );
return hds_gl_status;
}
int main (void) {
/* Local Variables: */
const char path[] = "hds_ctest";
int status = DAT__OK;
hdsdim dim[] = { 10, 20 };
hdsdim dimd[1];
const char * chararr[] = { "TEST1", "TEST2", "Longish String" };
char *retchararr[4];
char buffer[1024]; /* plenty large enough */
double darr[] = { 4.5, 2.5 };
double retdarr[2];
void *mapv; /* Mapped void* */
double *mapd; /* Mapped _DOUBLE */
float *mapf; /* Mapped _REAL */
int *mapi; /* Mapped _INTEGER */
int64_t *mapi64; /* Mapped _INT64 */
HDSLoc * loc1 = NULL;
HDSLoc * loc2 = NULL;
HDSLoc * loc3 = NULL;
size_t actval;
size_t nel;
size_t nelt;
size_t nbytes;
size_t i;
int n;
double sumd;
int sumi;
int64_t sumi64;
int64_t test64;
int64_t testin64;
const int64_t VAL__BADK = (-9223372036854775807 - 1);
emsBegin(&status);
/* Force 64-bit mode */
hdsTune( "64BIT", 1, &status );
/* Create a new container file */
hdsNew( path, "HDS_TEST", "NDF", 0, dim, &loc1, &status );
/* Some components */
datNew( loc1, "DATA_ARRAY", "_INTEGER", 2, dim, &status );
datNew1C( loc1, "ONEDCHAR", 14, 3, &status );
datNew1D( loc1, "ONEDD", 2, &status );
datNew0K( loc1, "TESTI64", &status );
datNew0K( loc1, "TESTBADI64", &status );
/* Populate */
testin64 = 9223372036854775800;
datFind( loc1, "TESTI64", &loc2, &status );
datPut0K( loc2, testin64, &status );
datGet0K( loc2, &test64, &status );
datAnnul( &loc2, &status );
if (status == DAT__OK) {
if ( test64 != testin64 ) {
status = DAT__FATAL;
emsRepf( "TESTI64", "Test _INT64 value %" PRIi64 " did not match expected %"PRIi64,
&status, test64, testin64 );
}
}
datFind( loc1, "TESTBADI64", &loc2, &status );
datPut0K( loc2, VAL__BADK, &status );
datGet0K( loc2, &test64, &status );
datAnnul( &loc2, &status );
if (status == DAT__OK) {
if ( test64 != VAL__BADK ) {
status = DAT__FATAL;
emsRepf( "TESTBADI64", "Test _INT64 value %" PRIi64 " did not match expected VAL__BADK",
&status, test64 );
}
}
datFind( loc1, "ONEDCHAR", &loc2, &status );
datPutVC( loc2, 3, chararr, &status );
/* Check contents */
datGetVC(loc2, 3, 1024, buffer, retchararr, &actval, &status);
if (status == DAT__OK) {
if (actval == 3) {
for (i = 0; i < 3; i++ ) {
if (strncmp( chararr[i], retchararr[i], strlen(chararr[i]) ) ) {
status = DAT__DIMIN;
emsSetc( "IN", chararr[i]);
emsSetc( "OUT", retchararr[i] );
emsRep( "GET1C","Values from Get1C differ (^IN != ^OUT)", &status);
break;
}
}
} else {
status = DAT__DIMIN;
emsRep( "GET1C","Did not get back as many strings as put in", &status);
}
}
datAnnul( &loc2, &status );
datFind( loc1, "ONEDD", &loc2, &status );
datPutVD( loc2, 2, darr, &status );
/* Check contents */
datGetVD( loc2, 2, retdarr, &actval, &status);
if (status == DAT__OK) {
if (actval == 2) {
for (i = 0; i < 2; i++ ) {
if (darr[i] != retdarr[i]) {
status = DAT__DIMIN;
emsRep( "GETVD","Values from getVD differ", &status);
break;
}
}
} else {
status = DAT__DIMIN;
emsRep( "GETVD","Did not get back as many values as put in", &status);
}
}
/* Try mapping - _DOUBLE */
dimd[0] = 2;
datMapD(loc2, "READ", 1, dimd, &mapd, &status);
if (status == DAT__OK) {
for (i = 0; i < 2; i++ ) {
if (darr[i] != mapd[i]) {
status = DAT__DIMIN;
emsRep( "MAPD","Values from MapD differ", &status);
break;
}
}
}
datUnmap(loc2, &status);
/* Try mapping - _FLOAT */
datMapR(loc2, "READ", 1, dimd, &mapf, &status);
if (status == DAT__OK) {
for (i = 0; i < 2; i++ ) {
if ( (float)darr[i] != mapf[i]) {
status = DAT__DIMIN;
emsRep( "MAPR","Values from MapR differ", &status);
break;
}
}
}
datUnmap(loc2, &status);
/* Annul */
datAnnul( &loc2, &status );
/* Find and map DATA_ARRAY */
datFind( loc1, "DATA_ARRAY", &loc2, &status );
datMapV( loc2, "_REAL", "WRITE", &mapv, &nel, &status );
mapf = mapv;
if (status == DAT__OK) {
nelt = dim[0] * dim[1];
if ( nelt != nel) {
status = DAT__FATAL;
emsSeti( "NEL", (int)nel );
emsSeti( "NORI", (int)nelt );
emsRep( "SIZE","Number of elements originally (^NORI) not the same as now (^NEL)", &status);
}
}
sumd = 0.0;
for (i = 1; i <= nel; i++) {
mapf[i-1] = (float)i;
sumd += (double)i;
}
datUnmap( loc2, &status );
datAnnul( &loc2, &status );
hdsClose( &loc1, &status );
/* Re-open */
hdsOpen( path, "UPDATE", &loc1, &status );
/* Look for the data array and map it */
datFind( loc1, "DATA_ARRAY", &loc2, &status );
datVec( loc2, &loc3, &status );
datSize( loc3, &nel, &status);
if (status == DAT__OK) {
nelt = dim[0] * dim[1];
if ( nelt != nel) {
status = DAT__FATAL;
emsSeti( "NEL", (int)nel );
emsSeti( "NORI", (int)nelt );
emsRep( "SIZE","Number of elements before (^NORI) not the same as now (^NEL)", &status);
}
}
datPrec( loc3, &nbytes, &status );
if (status == DAT__OK) {
if ( nbytes != 4) {
status = DAT__FATAL;
emsSeti( "NB", nbytes );
emsRep( "PREC","Precision for _REAL not 4 bytes but ^NB", &status);
}
}
/* Try hdsShow */
hdsShow("LOCATORS", &status);
hdsShow("FILES", &status);
hdsInfoI(NULL, "LOCATORS", "!HDS_TEST.,YYY", &n, &status );
hdsInfoI(NULL, "FILES", NULL, &n, &status );
datAnnul( &loc3, &status );
datMapV( loc2, "_INTEGER", "READ", &mapv, &nel, &status );
mapi = mapv;
if (status == DAT__OK) {
nelt = dim[0] * dim[1];
if ( nelt != nel) {
status = DAT__FATAL;
emsSeti( "NEL", (int)nel );
emsSeti( "NORI", (int)nelt );
emsRep( "SIZE","Number of elements originally (^NORI) not the same as now (^NEL)", &status);
}
}
sumi = 0;
for (i = 0; i < nel; i++) {
sumi += mapi[i];
}
datUnmap( loc2, &status );
if (status == DAT__OK) {
if (sumi != (int)sumd) {
status = DAT__FATAL;
emsSeti( "I", sumi );
emsSeti( "D", (int)sumd );
emsRep("SUM","Sum was not correct. Got ^I rather than ^D", &status );
}
}
/* _INT64 test */
datMapV( loc2, "_INT64", "READ", &mapv, &nel, &status );
mapi64 = mapv;
if (status == DAT__OK) {
nelt = dim[0] * dim[1];
if ( nelt != nel) {
status = DAT__FATAL;
emsSeti( "NEL", (int)nel );
emsSeti( "NORI", (int)nelt );
emsRep( "SIZE","Number of elements originally (^NORI) not the same as now (^NEL)", &status);
}
}
sumi64 = 0;
for (i = 0; i < nel; i++) {
sumi64 += mapi64[i];
}
datUnmap( loc2, &status );
if (status == DAT__OK) {
if (sumi64 != (int)sumd) {
status = DAT__FATAL;
emsSeti( "I", (int)sumi64 );
emsSeti( "D", (int)sumd );
emsRep("SUM","Sum was not correct. Got ^I rather than ^D", &status );
}
}
/* Tidy up and close */
hdsErase( &loc1, &status );
if (status == DAT__OK) {
printf("HDS C installation test succeeded\n");
emsEnd(&status);
return EXIT_SUCCESS;
} else {
printf("HDS C installation test failed\n");
emsEnd(&status);
return EXIT_FAILURE;
}
}
void errTune( const char * param, int value, int * status ) {
const char * parnames[] = { "SZOUT", "STREAM", "REVEAL", NULL };
const char * thispar = NULL; /* Selected parameter */
int i;
int set; /* Value has been set */
int istat = SAI__OK; /* Internal status */
int env = 0; /* Are we using the environment? */
int npars = 0; /* Number of parameters to read */
int useval = 0; /* Tuning value to actually use */
int envval; /* Tuning value from environment */
int fromenv = 0; /* Value came from environment */
int ltune; /* Actual tuning value used */
/* Check for 'ENVIRONMENT' */
if (strcasecmp( param, "ENVIRONMENT" ) == 0) {
env = 1;
/* work it out ourselves */
npars = 0;
while ( parnames[npars] ) {
npars++;
}
} else {
env = 0;
npars = 1;
thispar = param;
}
/* Now for each required parameter */
i = 0;
while ( istat == SAI__OK && i < npars) {
/* Select next par name if we are in env mode */
if (env) {
thispar = parnames[i];
set = 0;
} else {
set = 1;
}
i++;
/* See if the associated environment variable is set
* If so, override the given VALUE - make sure we do not
* clear tokens by starting a new context. */
emsMark();
fromenv = 0;
envval = mers1Getenv( 0, thispar, &istat );
emsRlse();
if (envval == -1) {
/* everything okay but no environment variable */
useval = value;
} else if (envval > 0 ) {
set = 1;
useval = envval;
fromenv = 1;
}
if (istat == SAI__OK && set) {
ltune = -1;
/* Check that the given parameter name is acceptable
* and handle it. */
if (strcasecmp( "SZOUT", thispar) == 0) {
if (useval == 0) {
ltune = ERR__SZMSG;
} else if ( useval > 6 ) {
ltune = MIN( useval, ERR__SZMSG );
} else {
istat = ERR__BTUNE;
}
if (ltune != -1) {
err1Ptwsz( ltune );
}
} else if (strcasecmp( "STREAM", thispar) == 0 ) {
if (useval == 0) {
ltune = 0;
} else if (useval == 1) {
ltune = 1;
} else {
istat = ERR__BTUNE;
}
if (ltune != -1) err1Ptstm( ltune );
} else if (strcasecmp( "REVEAL", thispar ) == 0 ) {
if (useval == 0) {
ltune = 0;
} else if (useval == 1) {
ltune = 1;
} else {
istat = ERR__BTUNE;
}
if (ltune != -1) {
emsTune( "REVEAL", ltune, &istat );
err1Ptrvl( ltune );
}
} else {
/* The given tuning parameter was not in the available set.
* Set status and report an error message.
* We mark and rlse to prevent possible token name clash */
emsMark();
istat = ERR__BDPAR;
emsSetc( "PARAM", thispar );
emsRep( "ERR_TUNE_PAR",
"errTune: Invalid tuning parameter: ^PARAM", &istat );
emsRlse();
}
if (istat == ERR__BTUNE) {
/* The given tuning parameter value was invalid
* Report an error message
* We mark and rlse to prevent posible token name clash */
emsMark();
emsSetc( "PARAM", thispar );
emsSeti( "VALUE", useval );
if (fromenv) {
emsSetc( "SOURCE", "from environment variable" );
} else {
emsSetc( "SOURCE", " " );
}
emsRep( "ERR_TUNE_INV",
"errTune: ^PARAM invalid value ^VALUE ^SOURCE", &istat);
emsRlse();
}
}
}
/* Set return status */
if (*status == SAI__OK) *status = istat;
}