hid_t
dat1GetParentID( hid_t objid, hdsbool_t allow_root, int * status ) {
hid_t parent_id = -1;
ssize_t lenstr = 0;
char * tempstr = NULL;
if (*status != SAI__OK) return parent_id;
/* Not sure if there is a specific API for this. For now,
get the full name of the object and then open the group
with the lowest part of the path removed */
tempstr = dat1GetFullName( objid, 0, &lenstr, status );
if (*status == SAI__OK && lenstr <= 1) {
*status = DAT__OBJIN;
emsRep("datParen_0",
"Object is the HDF5 root group and has no parent "
"group (possible programming error).", status);
goto CLEANUP;
}
/* Now walk through the name in reverse and nul out the first "/"
we encounter. */
if (*status == SAI__OK) {
ssize_t iposn;
ssize_t i;
for (i = 0; i < lenstr; i++) {
iposn = lenstr - (i+1);
if (tempstr[iposn] == '/') {
tempstr[iposn] = '\0';
break;
}
}
}
/* if this seems to be the root group we rewrite it to be "/" else,
optionally return an error. */
if (tempstr[0] == '\0') {
if (allow_root) {
tempstr[0] = '/';
tempstr[1] = '\0';
} else if (*status == SAI__OK) {
*status = DAT__OBJIN;
emsRep("datParen_1",
"Object is a top-level object and has no parent "
"structure (possible programming error).", status);
goto CLEANUP;
}
}
/* It seems you can open a group on an arbitrary
item (group or dataset) if you use a fully specified
path. This means you do not need to get an
explicit file_id to open the group */
CALLHDFE( hid_t, parent_id,
H5Gopen(objid, tempstr, H5P_DEFAULT),
DAT__HDF5E,
emsRepf("datParen_2", "Error opening parent structure '%s'",
status, tempstr );
);
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();
}
}
HDSLoc *
dat1ImportFloc ( const char flocator[DAT__SZLOC], int loc_length, int * status) {
long ptr_as_long = 0;
HDSLoc * clocator = NULL;
/* Validate the locator length. */
if (loc_length != DAT__SZLOC ) {
if (*status == SAI__OK ) {
*status = DAT__LOCIN;
emsRepf( "DAT1_IMPORT_FLOC", "Locator length is %d not %d", status,
loc_length, DAT__SZLOC);
}
return NULL;
};
/* Check obvious error conditions */
if (strncmp( DAT__ROOT, flocator, loc_length) == 0 ){
if( *status == SAI__OK ) {
*status = DAT__LOCIN;
emsRep( "dat1ImportFloc_ROOT",
"Input HDS Locator corresponds to DAT__ROOT but that can only be used from NDF",
status );
}
return NULL;
}
/* Check obvious error conditions */
if (strncmp( DAT__NOLOC, flocator, loc_length) == 0 ){
if( *status == SAI__OK ) {
*status = DAT__LOCIN;
emsRep( "datImportFloc_NOLOC",
"Input HDS Locator corresponds to DAT__NOLOC but status is good (Possible programming error)",
status );
}
return NULL;
}
/* Everything seems to be okay so now convert the string buffer to the
required pointer. We ignore status as sometimes we need to try
to get the value regardless (otherwise DAT_ANNUL from Fortran would
never succeed). */
ptr_as_long = strtol( flocator, NULL, 16 );
if (ptr_as_long == 0) {
/* This should not have happened */
if (*status == SAI__OK) {
*status = DAT__LOCIN;
emsRep("dat1_import_floc_3",
"Error importing locator from Fortran", status );
return NULL;
}
}
/* Do the cast */
clocator = (HDSLoc *)ptr_as_long;
return clocator;
}
/*
* Name:
* img1ExtractParam
*
* Purpose:
* Extracts the nth parameter from a string.
*
* Arguments:
* string = const char *
* The parameter string.
* n = const int
* The element to extract/
* value = char *
* The value of the nth element.
* status = int *
* The global status.
*
*/
void img1ExtractParam( const char *string, const int n, char *value,
int *status )
{
char *first;
char stringc[132];
int i;
if ( *status != SAI__OK ) return;
/* Copy input string into local buffer as strtok would modify
it. */
strcpy( stringc, string );
/* Count number of tokens until reach required position */
first = strtok( stringc, "," );
for ( i = 1; i < n; i ++ ) {
first = strtok( (char *) NULL, "," );
}
/* Check that the required number exist. If not complain. */
if ( first == (char *) NULL ) {
*status = IMG__FATIN;
emsRep( " ","img1StringArray: too few parameters for request.",
status );
}
strcpy ( value, first );
return;
}
void err1Prerr( const char * text, int * status ) {
int errstat = 0; /* status from printf */
/* Fortran version stripped trailing space. We assume that the
fortran interface to this routine has already done that */
/* Write the message to STDERR */
/* Note that this routine must include the new line character */
errstat = fprintf( stderr, "%s\n", text );
fflush(stderr);
/* If that failed or STDERR was not a TTY, try STDOUT */
if (errstat < 0 || !isatty( STDERR_FILENO ) ) {
*status = ERR__OPTER;
emsRep( "ERR1_PRERR", "Unable to deliver error message to STDERR",
status );
/* Write the message to STDOUT */
printf( "%s\n", text );
fflush(stdout);
}
}
int datUnlock( HDSLoc *locator, int recurs, int *status ) {
/* Local variables; */
Handle *error_handle = NULL;
int lstat;
const char *phrase;
/* Check inherited status. */
if (*status != SAI__OK) return *status;
/* Validate input locator. */
dat1ValidateLocator( "datUnlock", 0, locator, 0, status );
/* Check we can de-reference "locator" safely. */
if( *status == SAI__OK ) {
/* Attempt to unlock the specified object, plus all its components if
required. Report suitable errors if this fails. */
error_handle = dat1HandleLock( locator->handle, 3, recurs, 0, &lstat,
status );
if( *status == SAI__OK && lstat < 1 ) {
*status = DAT__THREAD;
datMsg( "O", locator );
emsRep( " ", "datUnlock: Cannot unlock HDS object '^O' for "
"use by the current thread:", status );
if( lstat < 0 ) {
phrase = "currently locked for writing by a different thread";
} else {
phrase = "not currently locked by the current thread";
}
emsSetc( "P", phrase );
dat1HandleMsg( "E", error_handle );
if( error_handle != locator->handle ) {
emsRep( " ", "A component within it (^E) is ^P.", status );
} else {
emsRep( " ", "It is ^P.", status );
}
}
}
return *status;
}
int mers1Getenv( int usemsg, const char * param, int *status ) {
char envvar[32]; /* environment variable name */
char *c; /* pointer to character in name */
char *val; /* environ value */
int retval = -1;
long result = 0;
if (*status != SAI__OK) return retval;
/* copy prefix and param into the buffer */
if (usemsg) {
star_strlcpy( envvar, "MSG_", sizeof(envvar) );
} else {
star_strlcpy( envvar, "ERR_", sizeof(envvar) );
}
star_strlcat( envvar, param, sizeof(envvar) );
/* upper case it */
c = envvar;
while ( *c ) {
*c = toupper(*c);
c++;
}
/* Query the environment */
val = getenv( envvar );
if (val) {
/* Convert to an integer */
char *endptr = NULL;
result = strtol( val, &endptr, 10 );
if (result == 0 && endptr == val) {
if (usemsg) {
*status = MSG__BDENV;
emsSetc( "SYS", "msgTune");
} else {
*status = ERR__BDENV;
emsSetc( "SYS", "errTune");
}
emsSetc( "EV", envvar );
emsSetc( "VAL", val );
emsRep( "MERS_TUNE_BDENV",
"^SYS: Failed to convert environment variable "
"^EV (^VAL) to integer", status );
} else {
retval = result;
}
}
return retval;
}
int
datDrep(const HDSLoc *locator, char **format_str, char **order_str,
int *status) {
if (*status != SAI__OK) return *status;
*status = DAT__FATAL;
emsRep("datDrep", "datDrep: Not yet implemented for HDF5",
status);
return *status;
}
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;
}
hid_t
dau1Native2MemType( hid_t nativetype, int * status ) {
hdstype_t htype = HDSTYPE_NONE;
hid_t rettype = 0;
if (*status != SAI__OK) return 0;
htype = dau1HdsType( nativetype, status );
if (*status != SAI__OK) return 0;
if ( htype == HDSTYPE_LOGICAL ) {
/* _LOGICAL is a 32bit number but we store in HDF5 in 8 bits */
size_t szbool = sizeof(hdsbool_t);
switch (szbool) {
case 4:
rettype = H5T_NATIVE_B32;
break;
case 2:
rettype = H5T_NATIVE_B16;
break;
case 1:
rettype = H5T_NATIVE_B8;
break;
default:
*status = DAT__TYPIN;
emsRep("dau1Native2MemType", "Unexpected size of _LOGICAL type"
" (possible programming error)", status );
return 0;
}
} else {
rettype = nativetype;
}
/* But we promise to copy the type so that it is clear that the
caller should free it */
return H5Tcopy(rettype);
}
int
datErase(const HDSLoc *locator, const char *name_str, int *status) {
char groupstr[DAT__SZNAM+1];
char cleanname[DAT__SZNAM+1];
if (*status != SAI__OK) return *status;
/* Validate input locator. */
dat1ValidateLocator( "datErase", 1, locator, 0, status );
/* containing locator must refer to a group */
if (locator->group_id <= 0) {
*status = DAT__OBJIN;
emsRep("datErase_1", "Input object is not a structure",
status);
return *status;
}
/* Parent group for error reporting */
datName( locator, groupstr, status);
/* Ensure the name is cleaned up before we use it */
dau1CheckName( name_str, 1, cleanname, sizeof(cleanname), status );
CALLHDFQ( H5Ldelete( locator->group_id, cleanname, H5P_DEFAULT ));
/* Remove the handle for the erased component and all sub-components */
dat1EraseHandle( locator->handle, cleanname, status );
CLEANUP:
if (*status != SAI__OK) {
emsRepf("datErase_2", "Error deleting component %s in group %s",
status, name_str, groupstr);
}
return *status;
}
hdstype_t
dau1HdsType( hid_t h5type, int * status ) {
H5T_class_t tclass = 0;
size_t dsize = 0;
hdstype_t thetype = HDSTYPE_NONE;
if (*status != SAI__OK) return thetype;
CALLHDFE( H5T_class_t, tclass,
H5Tget_class( h5type ),
DAT__HDF5E,
emsRep("dat1Type_2", "datType: Error obtaining class of data type", status)
);
/* Number of bytes representing the type */
dsize = H5Tget_size( h5type );
if (*status == SAI__OK) {
switch (tclass) {
case H5T_INTEGER:
{
/* then need to know signed or unsigned int */
H5T_sign_t dsign = H5Tget_sign( h5type );
if (dsign < 0) {
*status = DAT__HDF5E;
emsRep("dat1Type_3", "datType: Error obtaining sign of an integer type", status );
goto CLEANUP;
}
if (dsign == H5T_SGN_NONE) {
if ( dsize == 1 ) {
thetype = HDSTYPE_UBYTE;
} else if (dsize == 2) {
thetype = HDSTYPE_UWORD;
} else {
*status = DAT__TYPIN;
emsRepf("dat1Type_3a",
"Unexpected number of bytes (%zu) in unsigned integer type",
status, dsize);
}
} else {
/* Signed types */
switch (dsize) {
case 1:
thetype = HDSTYPE_BYTE;
break;
case 2:
thetype = HDSTYPE_WORD;
break;
case 4:
thetype = HDSTYPE_INTEGER;
break;
case 8:
thetype = HDSTYPE_INT64;
break;
default:
*status = DAT__TYPIN;
emsRepf("dat1Type_3b", "datType: Unexpected number of bytes in integer (%zu)",
status, dsize);
}
}
}
break;
case H5T_FLOAT:
if ( dsize == 4 ) {
thetype = HDSTYPE_REAL;
} else if (dsize == 8) {
thetype = HDSTYPE_DOUBLE;
} else {
*status = DAT__FATAL;
emsRepf("datType_5", "Error reading size of float data type. Got %zu bytes"
" but only understand 4 and 8", status, dsize);
}
break;
case H5T_STRING:
thetype = HDSTYPE_CHAR;
break;
case H5T_BITFIELD:
if ( dsize == 1 || dsize == 4 ) { /* on disk and in memory version */
thetype = HDSTYPE_LOGICAL;
} else {
*status = DAT__FATAL;
emsRepf("datType_5", "Error reading size of logical data type. Got %zu bytes"
" but only understand 1 or 4", status, dsize);
}
break;
default:
*status = DAT__TYPIN;
emsRep("datType_4", "dat1Type: Unexpected type class from dataset", status);
}
}
CLEANUP:
return thetype;
}
static void *
dat1Mmap( size_t nbytes, int prot, int flags, int fd, off_t offset, int *isreg, void **pntr, size_t *actbytes, int * status ) {
void * mapped = NULL;
int tries = 0;
size_t pagesize = 0;
void * where = NULL;
off_t off = 0;
*pntr = NULL;
*isreg = 0;
if (*status != SAI__OK) return NULL;
/* We need to know the pagesize */
pagesize = sysconf( _SC_PAGESIZE );
*actbytes = nbytes;
if (offset > 0) {
/* Calculate the starting offset into the file and round this down to a */
/* multiple of the system page size. Calculate the number of bytes to map, */
/* allowing for this rounding. */
off = offset - ( offset % pagesize );
*actbytes += ( offset - off );
}
while (!mapped) {
*isreg = 0;
tries++;
if (*status != SAI__OK) goto CLEANUP;
/* Get some anonymous memory - we always have to map read/write
because we always have to copy data into this space. */
//printf("mmap(%p, %zu, %d, %d, %d, %zu -> %zu [%d])\n", where, *actbytes, prot, flags, fd, offset, off, pagesize);
mapped = mmap( where, *actbytes, prot, flags, fd, off );
if (mapped == MAP_FAILED) {
emsSyser( "MESSAGE", errno );
*status = DAT__FILMP;
emsRep("datMap_2", "Error mapping some memory: ^MESSAGE", status );
mapped = NULL;
*pntr = NULL;
goto CLEANUP;
}
/* The pointer we register is the one that has been corrected
for the shift we applied in the original request */
*pntr = mapped + (offset - off );
/* Must register with CNF so the pointer can be used by Fortran */
*isreg = cnfRegp( *pntr );
if (*isreg == -1) {
/* Serious internal error */
*status = DAT__FILMP;
emsRep("datMap_3", "Error registering a pointer for mapped data "
" - internal CNF error", status );
goto CLEANUP;
} else if (*isreg == 0) {
/* Free the memory and try again */
if ( munmap( mapped, *actbytes ) != 0 ) {
*status = DAT__FILMP;
emsSyser( "MESSAGE", errno );
emsRep("datMap_4", "Error unmapping mapped memory following"
" failed registration: ^MESSAGE", status);
goto CLEANUP;
}
if (!where) where = mapped;
where += pagesize;
mapped = NULL;
*pntr = NULL;
}
if (!mapped && tries > 100) {
*status = DAT__FILMP;
emsRepf("datMap_4b", "Failed to register mapped memory with CNF"
" after %d attempts", status, tries );
goto CLEANUP;
}
}
CLEANUP:
return mapped;
}
int
datMap(HDSLoc *locator, const char *type_str, const char *mode_str, int ndim,
const hdsdim dims[], void **pntr, int *status) {
int isprim = 0;
char normtypestr[DAT__SZTYP+1];
size_t nbytes = 0;
hid_t h5type = 0;
int isreg = 0;
void *regpntr = NULL;
void *mapped = NULL;
hdsmode_t accmode = HDSMODE_UNKNOWN;
haddr_t offset;
hdsbool_t try_mmap = HDS_FALSE;
unsigned intent = 0;
size_t actbytes = 0;
if (*status != SAI__OK) return *status;
/* First have to validate the access mode */
switch (mode_str[0]) {
case 'R':
case 'r':
accmode = HDSMODE_READ;
break;
case 'U':
case 'u':
accmode = HDSMODE_UPDATE;
break;
case 'W':
case 'w':
accmode = HDSMODE_WRITE;
break;
default:
*status = DAT__MODIN;
emsRepf("datMap_6", "Unrecognized mode string '%s' for datMap",
status, mode_str);
goto CLEANUP;
}
/* Validate input locator. */
dat1ValidateLocator( "datMap", 1, locator, (accmode & HDSMODE_READ), status );
/* Get the HDF5 type code and confirm this is a primitive type */
isprim = dau1CheckType( 1, type_str, &h5type, normtypestr,
sizeof(normtypestr), status );
if (!isprim) {
if (*status == SAI__OK) {
*status = DAT__TYPIN;
emsRepf("datMap_1", "datGet: Data type must be a primitive type and not '%s'",
status, normtypestr);
}
goto CLEANUP;
}
/* Not allowed to map undefined data in READ or UPDATE mode */
if (accmode == HDSMODE_UPDATE || accmode == HDSMODE_READ) {
hdsbool_t defined;
if (*status == SAI__OK) {
datState( locator, &defined, status );
if (!defined) {
*status = DAT__UNSET;
emsRepf("datMap_6bb", "Can not map an undefined primitive in mode '%s'",
status, mode_str);
goto CLEANUP;
}
}
}
/* How did we open this file? */
CALLHDFQ( H5Fget_intent( locator->file_id, &intent ));
if (accmode == HDSMODE_UPDATE || accmode == HDSMODE_WRITE) {
/* Must check whether the file was opened for write */
if ( intent == H5F_ACC_RDONLY ) {
*status = DAT__ACCON;
emsRepf("datMap_6b", "datMap: Can not map readonly locator in mode '%s'",
status, mode_str);
goto CLEANUP;
}
}
/* Verify that the specified dimensions match the locator dimensions */
if (*status == SAI__OK) {
hdsdim locdims[DAT__MXDIM];
int locndims;
int i;
datShape(locator, DAT__MXDIM, locdims, &locndims, status );
/* Note that if we are mapping as a scalar the locator should
refer to a single element */
if (ndim == 0) {
size_t nelem = 1;
for (i=0; i<locndims; i++) {
nelem *= locdims[i];
}
if (nelem != 1) {
*status = DAT__DIMIN;
emsRepf("datMap_6e", "datMap: Attempt to map as a scalar but locator"
" refers to a primitive with %zu elements",
status, nelem);
goto CLEANUP;
}
} else {
if (ndim != locndims) {
*status = DAT__DIMIN;
emsRepf("datMap_6c", "datMap: Dimensionality mismatch --"
" requested number: %d locator number: %d", status,
ndim, locndims );
goto CLEANUP;
}
for (i=0; i<ndim; i++) {
if ( locdims[i] != dims[i] ) {
*status = DAT__DIMIN;
emsRepf("datMap_6d", "datMap: Dimension %d has size %zu but requested size %zu",
status, i, (size_t)locdims[i], (size_t)dims[i]);
goto CLEANUP;
}
}
}
}
/* There is a super-special case for datMap when called with a map
type of "_CHAR". In that case we need to work out the size ourselves
and adjust the type size */
if (strcmp( "_CHAR", normtypestr ) == 0 ) {
size_t clen = 0;
char tmpbuff[DAT__SZTYP+1];
datClen( locator, &clen, status );
CALLHDFQ( H5Tset_size( h5type, clen ) );
one_snprintf( tmpbuff, sizeof(tmpbuff), "*%zu",
status, clen );
one_strlcat( normtypestr, tmpbuff, DAT__SZTYP+1, status );
}
/* Now we want the HDSTYPE of the requested type so that we can work out how much
memory we will need to allocate. */
CALLHDFE( size_t, nbytes,
H5Tget_size( h5type ),
DAT__HDF5E,
emsRep("datLen_size", "datMap: Error obtaining size of requested data type",
status)
);
{
int i;
if (ndim > 0) {
for (i = 0; i < ndim; i++) {
nbytes *= dims[i];
}
}
}
/* Work out whether memory mapping is possible -- at the moment
I'm pretty sure the only safe use of mmap is when we are reading
the data and the file itself was opened readonly. I'm not sure what happens
if other components are removed or added -- will the offset change? Maybe we just try */
offset = H5Dget_offset( locator->dataset_id );
if (offset != HADDR_UNDEF) {
hid_t dataset_h5type = 0;
/* In theory we can do a memory map so now compare
the data types of the request and the low-level dataset. */
CALLHDFE( hid_t, dataset_h5type,
H5Dget_type( locator->dataset_id ),
DAT__HDF5E,
emsRep("datMap_type", "datType: Error obtaining data type of dataset", status)
);
if (H5Tequal( dataset_h5type, h5type )) {
try_mmap = HDS_TRUE;
}
H5Tclose(dataset_h5type);
}
/* If this is a locator to a slice then for now we can't memory map. In theory
if we knew the slice was contiguous (e.g a vectorized slice, or a single
plane of a cube then we could mmap it anyhow. We do not want to have to
emulate HDF5 dataspaces here */
if (locator->isslice) try_mmap = 0;
/* There seem to be issues doing this on files opened for update/write.
For now only allow mmap for files opened read only */
if (intent != H5F_ACC_RDONLY) try_mmap = 0;
/* If mmap has been disabled by tuning the environment we just force it off here. */
if (!hds1GetUseMmap()) try_mmap = 0;
#if DEBUG_HDS
{
char *name_str;
char * file_str;
const char * reason;
name_str = dat1GetFullName( locator->dataset_id, 0, NULL, status );
file_str = dat1GetFullName( locator->dataset_id, 1, NULL, status );
if (offset != HADDR_UNDEF) {
reason = "[HAD offset]";
} else {
reason = "[no offset]";
}
if (!try_mmap) {
printf("Will NOT attempt %s to mmap %s:%s\n",reason,file_str,name_str);
} else {
printf("WILL TRY %s to mmap OFFSET=%zu %s:%s\n", reason, (size_t)offset, file_str, name_str);
}
MEM_FREE(name_str);
}
#endif
if (try_mmap) {
int fd = 0;
int flags = 0;
int prot = 0;
hdsbool_t opened_fd = 0;
if ( intent == H5F_ACC_RDONLY || accmode == HDSMODE_READ ) {
flags |= O_RDONLY;
prot = PROT_READ;
} else {
flags |= O_RDWR;
prot = PROT_READ | PROT_WRITE;
}
if (*status == SAI__OK) {
/* see what file driver we have */
hid_t fapl_id = -1;
hid_t fdriv_id = -1;
void * file_handle = NULL;
herr_t herr = -1;
fapl_id = H5Fget_access_plist(locator->file_id);
fdriv_id = H5Pget_driver(fapl_id);
if (fdriv_id == H5FD_SEC2 || fdriv_id == H5FD_STDIO) {
/* If this is a POSIX or STDIO driver we get the handle */
herr = H5Fget_vfd_handle( locator->file_id, fapl_id, (void**)&file_handle);
if (herr >= 0) {
if (fdriv_id == H5FD_SEC2) {
fd = *((int *)file_handle);
} else if (fdriv_id == H5FD_STDIO) {
FILE * fh = (FILE *)file_handle;
fd = fileno(fh);
}
}
}
if (fapl_id > 0) H5Pclose( fapl_id );
if (fd == 0) {
/* We have to open the file ourselves! */
char * fname = NULL;
fname = dat1GetFullName( locator->dataset_id, 1, NULL, status );
fd = open(fname, flags);
opened_fd = 1;
if (fname) MEM_FREE(fname);
}
if (fd > 0) {
/* Set up for memory mapping */
int mflags = 0;
mflags = MAP_SHARED | MAP_FILE;
if (*status == SAI__OK) {
mapped = dat1Mmap( nbytes, prot, mflags, fd, offset, &isreg, ®pntr, &actbytes, status );
if (*status == SAI__OK) {
/* Store the file descriptor in the locator to allow us to close */
if (mapped) {
if (opened_fd) locator->fdmap = fd;
locator->uses_true_mmap = 1;
}
} else {
/* Not currently fatal -- we can try without the file */
if (opened_fd) close(fd);
emsAnnul(status);
}
}
}
}
}
/* If we have not been able to map anything yet, just get some memory. It is
zeroed (for WRITE) to match mmap behavior. We rely on the OS to decide when it is reasonable
to do an anonymous mmap. */
if (!regpntr) {
hdsbool_t mustget;
mustget = (accmode == HDSMODE_READ || accmode == HDSMODE_UPDATE);
if (mustget) {
regpntr = cnfMalloc( nbytes );
} else {
regpntr = cnfCalloc( 1, nbytes );
}
if (!regpntr) {
*status = DAT__NOMEM;
emsRepf("datMap_cnf","datMap: Unable to allocate %zu bytes of memory",
status, nbytes);
goto CLEANUP;
}
/* Populate the memory - check with datState occurred earlier */
if (mustget) {
datGet( locator, normtypestr, ndim, dims, regpntr, status );
}
}
CLEANUP:
/* Cleanups that must happen always */
if (h5type) H5Tclose(h5type);
/* cleanups that only happen if status is bad */
if (*status != SAI__OK) {
if (mapped) {
if (isreg == 1) cnfUregp( regpntr );
if ( munmap( mapped, actbytes ) != 0 ) {
emsSyser( "MESSAGE", errno );
emsRep("datMap_4", "Error unmapping mapped memory: ^MESSAGE", status);
}
mapped = NULL;
} else if (regpntr) {
cnfFree( regpntr );
}
regpntr = NULL;
}
/* Update the locator to reflect the mapped status */
if (*status == SAI__OK) {
int i;
locator->pntr = mapped;
locator->regpntr = regpntr;
locator->bytesmapped = actbytes;
locator->accmode = accmode;
/* In order to copy the data back into the underlying HDF5 dataset
we need to store additional information about how this was mapped
to allow us to either call datPut later on or at least a new
dataspace. For now store the arguments so we can pass them straight
to datPut */
locator->ndims = ndim;
for (i=0; i<ndim; i++) {
(locator->mapdims)[i] = dims[i];
}
star_strlcpy( locator->maptype, normtypestr, sizeof(locator->maptype) );
}
/* Note that the returned pointer is not necessarily the same as the
mapped pointer because of pagesize corrections */
*pntr = regpntr;
return *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;
}
}
Handle *dat1HandleLock( Handle *handle, int oper, int recurs, int rdonly,
int *result, int *status ){
/* Local Variables; */
Handle *child;
int ichild;
int top_level;
pthread_t *locker;
pthread_t *rlocker;
int i;
int j;
Handle *error_handle = NULL;
int child_result;
/* initialise */
*result = 0;
/* Check inherited status. */
if( *status != SAI__OK ) return error_handle;
/* Validate the supplied Handle */
if( !dat1ValidateHandle( "dat1HandleLock", handle, status ) ) return error_handle;
/* To avoid deadlocks, we only lock the Handle mutex for top level
entries to this function. If "oper" is negative, negate it and set a
flag indicating we do not need to lock the mutex. */
if( oper < 0 ) {
oper = -oper;
top_level = 0;
} else {
top_level = 1;
}
/* For top-level entries to this function, we need to ensure no other thread
is modifying the details in the handle, so attempt to lock the handle's
mutex. */
if( top_level ) pthread_mutex_lock( &(handle->mutex) );
/* Return information about the current lock on the supplied Handle.
------------------------------------------------------------------ */
if( oper == 1 ) {
/* Default: unlocked */
if( handle->nwrite_lock ) {
if( pthread_equal( handle->write_locker, pthread_self() )) {
/* Locked for writing by the current thread. */
*result = 1;
} else {
/* Locked for writing by another thread. */
*result = 2;
}
} else if( handle->nread_lock ){
/* Locked for reading by one or more other threads (the current thread does
not have a read lock on the Handle). */
*result = 4;
/* Now check to see if the current thread has a read lock, changing the
above result value if it does. */
locker = handle->read_lockers;
for( i = 0; i < handle->nread_lock;i++,locker++ ) {
if( pthread_equal( *locker, pthread_self() )) {
/* Locked for reading by the current thread (other threads may also have
a read lock on the Handle). */
*result = 3;
break;
}
}
}
/* If required, check any child handles. If we already have a status of
2, (the supplied handle is locked read-write by another thread), we do
not need to check the children. */
if( recurs && *result != 2 ){
for( ichild = 0; ichild < handle->nchild; ichild++ ) {
child = handle->children[ichild];
if( child ) {
/* Get the lock status of the child. */
(void) dat1HandleLock( child, -1, 1, rdonly, &child_result,
status );
/* If it's 2, we can set the final result and exit immediately. */
if( child_result == 2 ) {
*result = 2;
break;
/* Otherwise, ensure the child gives the same result as all the others,
breaking out and returning the catch-all value if not. */
} else if( child_result != *result ) {
*result = 5;
break;
}
}
}
}
/* Lock the handle for use by the current thread.
------------------------------------------------------------------ */
} else if( oper == 2 ) {
/* A read-only lock requested.... */
if( rdonly ) {
/* If the current thread has a read-write lock on the Handle, demote it
to a read-only lock and return 1 (success). In this case, we know
there will be no other read-locks. Otherwise if any other thread has
read-write lock, return zero (failure). */
if( handle->nwrite_lock ) {
if( pthread_equal( handle->write_locker, pthread_self() )) {
/* If we do not have an array in which to store read lock thread IDs,
allocate one now with room for NTHREAD locks. It will be extended as
needed. */
if( !handle->read_lockers ) {
handle->read_lockers = MEM_CALLOC(NTHREAD,sizeof(pthread_t));
if( !handle->read_lockers ) {
*status = DAT__NOMEM;
emsRep( "", "Could not allocate memory for HDS "
"Handle read locks list.", status );
}
}
/* If we now have an array, store the current thread in the first element. */
if( handle->read_lockers ) {
handle->read_lockers[ 0 ] = pthread_self();
handle->nread_lock = 1;
handle->nwrite_lock = 0;
*result = 1;
}
}
/* If there is no read-write lock on the Handle, add the current thread
to the list of threads that currently have a read-only lock, but only
if it is not already there. */
} else {
/* Set "result" to 1 if the current thread already has a read-only lock. */
locker = handle->read_lockers;
for( i = 0; i < handle->nread_lock;i++,locker++ ) {
if( pthread_equal( *locker, pthread_self() )) {
*result = 1;
break;
}
}
/* If not, extend the read lock thread ID array if necessary, and append
the current thread ID to the end. */
if( *result == 0 ) {
handle->nread_lock++;
if( handle->maxreaders < handle->nread_lock ) {
handle->maxreaders += NTHREAD;
handle->read_lockers = MEM_REALLOC( handle->read_lockers,
handle->maxreaders*sizeof(pthread_t));
if( !handle->read_lockers ) {
*status = DAT__NOMEM;
emsRep( "", "Could not reallocate memory for HDS "
"Handle read locks list.", status );
}
}
if( handle->read_lockers ) {
handle->read_lockers[ handle->nread_lock - 1 ] = pthread_self();
/* Indicate the read-only lock was applied successfully. */
*result = 1;
}
}
}
/* A read-write lock requested. */
} else {
/* If there are currently no locks of any kind, apply the lock. */
if( handle->nread_lock == 0 ) {
if( handle->nwrite_lock == 0 ) {
handle->write_locker = pthread_self();
handle->nwrite_lock = 1;
*result = 1;
/* If the current thread already has a read-write lock, indicate success. */
} else if( pthread_equal( handle->write_locker, pthread_self() )) {
*result = 1;
}
/* If there is currently only one read-only lock, and it is owned by the
current thread, then promote it to a read-write lock. */
} else if( handle->nread_lock == 1 &&
pthread_equal( handle->read_lockers[0], pthread_self() )) {
handle->nread_lock = 0;
handle->write_locker = pthread_self();
handle->nwrite_lock = 1;
*result = 1;
}
}
/* If required, and if the above lock operation was successful, lock any
child handles that can be locked. */
if( *result ){
if( recurs ){
for( ichild = 0; ichild < handle->nchild; ichild++ ) {
child = handle->children[ichild];
if( child ) {
error_handle = dat1HandleLock( child, -2, 1, rdonly,
result, status );
if( error_handle ) break;
}
}
}
/* If the lock operation failed, return a pointer to the Handle. */
} else {
error_handle = handle;
}
/* Unlock the handle.
----------------- */
} else if( oper == 3 ) {
/* Assume failure. */
*result = 0;
/* If the current thread has a read-write lock, remove it. */
if( handle->nwrite_lock ) {
if( pthread_equal( handle->write_locker, pthread_self() )) {
handle->nwrite_lock = 0;
*result = 1;
} else {
*result = -1;
}
/* Otherwise, if the current thread has a read-only lock, remove it. */
} else {
/* Loop through all the threads that have read-only locks. */
locker = handle->read_lockers;
for( i = 0; i < handle->nread_lock; i++,locker++ ) {
/* If the current thread is found, shuffle any remaining threads down one
slot to fill the gap left by removing the current thread from the list. */
if( pthread_equal( *locker, pthread_self() )) {
rlocker = locker + 1;
for( j = i + 1; j < handle->nread_lock; j++,locker++ ) {
*locker = *(rlocker++);
}
/* Reduce the number of read-only locks. */
handle->nread_lock--;
*result = 1;
break;
}
}
}
/* If required, and if the above unlock operation was successful, unlock any
child handles that can be unlocked. */
if( *result == 1 ){
if( recurs ){
for( ichild = 0; ichild < handle->nchild; ichild++ ) {
child = handle->children[ichild];
if( child ) {
error_handle = dat1HandleLock( child, -3, 1, 0,
result, status );
if( error_handle ) break;
}
}
}
/* If the unlock operation failed, return a pointer to the Handle. */
} else {
error_handle = handle;
}
/* Report an error for any other "oper" value. */
} else if( *status == SAI__OK ) {
*status = DAT__FATAL;
emsRepf( " ", "dat1HandleLock: Unknown 'oper' value (%d) supplied - "
"(internal HDS programming error).", status, oper );
}
/* If this is a top-level entry, unlock the Handle's mutex so that other
threads can access the values in the Handle. */
if( top_level ) pthread_mutex_unlock( &(handle->mutex) );
/* Return the error handle. */
return error_handle;
}
IDL_VPTR hds2idl( int argc, IDL_VPTR argv[] ) {
/*
** Declare variables
*/
IDL_VPTR hds_name; /* IDL_VPTR to name of the HDS object to be read */
IDL_VPTR var; /* Variable pointer to IDL object */
IDL_VARIABLE temp; /* Temporary storage for primitive scalar variable */
IDL_StructDefPtr sdef; /* Structure definition of sub-structure */
IDL_STRING *objname; /* Pointer to object name as IDL string */
HDSLoc *objloc = NULL; /* Locator of file */
int status; /* Starlink status */
char type[DAT__SZTYP+1];/* HDS type of component */
UCHAR idltype; /* IDl type of component */
int ndims; /* Number of dimensions of object */
int dims[DAT__MXDIM]; /* Dimensions of object HDS style */
IDL_LONG idldims[DAT__MXDIM];/* Dimensions of object IDL style */
int i; /* loop index */
int fstat; /* Final status (before emsEload) */
int isstruct; /* Whether object is structure */
void *tdata; /* Pointer to data area of IDL variable or array */
char param[EMS__SZPAR+1]; /* Error message parameter name */
int parlen; /* Length of error message parameter name */
char opstr[EMS__SZMSG+1]; /* Error message */
int oplen; /* Length of error message */
IDL_LONG one[IDL_MAX_ARRAY_DIM]={1};
/* Start Error context */
status = SAI__OK;
emsMark();
/* Check that the correct number of arguments were passed in */
if(argc != 1) {
/* Print an error message and return */
status = SAI__ERROR;
emsRep( " ", "hds2idl: Incorrect number of arguments", &status );
} else {
/* Extract the arguments to comprehensible names */
hds_name = argv[0];
objname = &hds_name->value.str;
/* Open the HDS object */
getcomp( IDL_STRING_STR(objname), "READ", &objloc, &status );
/* Check for structure or primitive */
datStruc( objloc, &isstruct, &status );
if (status == SAI__OK) {
if ( isstruct ) {
/* Create a structure */
sdef = idlstructdef( objloc, &status );
/* Create a temporary variable */
if ( status == SAI__OK ) {
(void *)IDL_MakeTempStruct( sdef, 1, one, &var, TRUE );
idlstructfill( objloc, var->value.s, &status );
}
} else {
/* Object is primitive */
datType( objloc, type, &status );
idltype = getidltype( type );
datShape( objloc, DAT__MXDIM, dims, &ndims, &status );
if ( status == SAI__OK ) {
if (ndims) {
/* Get dimensions IDL style */
for (i=0;i<ndims;i++) idldims[i] = (IDL_LONG)dims[i];
/* Object is primitive array */
tdata = IDL_MakeTempArray( (int)idltype, ndims, idldims,
IDL_BARR_INI_ZERO , &var );
} else {
/* Object is primitive scalar */
var = &temp;
var->type = idltype;
var->flags = 0;
tdata = &var->value;
}
idlprimfill( objloc, var, tdata, &status );
}
}
/* Annul the object (and close the file) */
datAnnul( &objloc, &status );
}
}
if ( status != SAI__OK ) {
/* Report any error messages */
/* Adding Starlink-style !! and ! prefix */
fstat = status;
while ( status != SAI__OK ) {
emsEload(
param, &parlen, opstr, &oplen, &status );
if ( status != SAI__OK )
IDL_Message( IDL_M_NAMED_GENERIC, IDL_MSG_INFO, opstr );
}
/* Set to return undefined variable */
var = IDL_Gettmp();
/* and close error context */
emsRlse();
}
/* That's it, return to the calling routine */
return var;
}
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
dat1GetBounds( const HDSLoc * locator, hdsdim lower[DAT__MXDIM],
hdsdim upper[DAT__MXDIM], hdsbool_t * issubset,
int *actdim, int * status ) {
int rank = 0;
hssize_t nblocks = 0;
hsize_t *blockbuf = NULL;
*actdim = 0;
*issubset = 0;
if (*status != SAI__OK) return *status;
/* If the supplied locator has a dataspace, then use the bounds of the
data space. This is done even if the object is a structure, since
vectorised structure arrays will have a dataspace describing their
vectorised extent. */
if( locator->dataspace_id ) {
int i;
hsize_t h5lower[DAT__MXDIM];
hsize_t h5upper[DAT__MXDIM];
hsize_t h5dims[DAT__MXDIM];
CALLHDFE( int,
rank,
H5Sget_simple_extent_dims( locator->dataspace_id, h5dims, NULL ),
DAT__DIMIN,
emsRep("datshape_1", "datShape: Error obtaining shape of object",
status)
);
/* If we are using datSlice then there should be one (and only one) hyperslab
for the dataspace and we need to handle that. Should be same dimensionality
as above. Negative number indicates there were no hyperslabs. */
if( H5Sget_select_type( locator->dataspace_id ) == H5S_SEL_HYPERSLABS ) {
nblocks = H5Sget_select_hyper_nblocks( locator->dataspace_id );
} else {
nblocks = 0;
}
if (nblocks == 1) {
herr_t h5err = 0;
*issubset = 1;
blockbuf = MEM_MALLOC( nblocks * rank * 2 * sizeof(*blockbuf) );
CALLHDF( h5err,
H5Sget_select_hyper_blocklist( locator->dataspace_id, 0, 1, blockbuf ),
DAT__DIMIN,
emsRep("datShape_2", "datShape: Error obtaining shape of slice", status )
);
/* We only go through one block. The buffer is returned in form:
ndim start coordinates, then ndim opposite corner coordinates
and repeats for each block (if we had more than one block).
*/
for (i = 0; i<rank; i++) {
hsize_t start;
hsize_t opposite;
start = blockbuf[i];
opposite = blockbuf[i+rank];
/* So update the shape to account for the slice: HDS is 1-based */
h5lower[i] = start + 1;
h5upper[i] = opposite + 1;
}
} else if (nblocks > 1) {
if (*status == SAI__OK) {
*status = DAT__WEIRD;
emsRepf("datShape_2", "Unexpectedly got %zd hyperblocks from locator. Expected 1."
" (possible programming error)", status, (ssize_t)nblocks);
goto CLEANUP;
}
} else {
/* No hyperblock */
for (i=0; i<rank; i++) {
h5lower[i] = 1; /* HDS value 1-based */
h5upper[i] = h5dims[i];
}
}
dat1ExportDims( rank, h5lower, lower, status );
dat1ExportDims( rank, h5upper, upper, status );
/* If no dataspace ia available, and the locator is a structure
array... */
} else if (dat1IsStructure( locator, status ) ) {
int datRef( const HDSLoc * locator, char * ref, size_t reflen, int * status ) {
/* Local Variables: */
char buff[MAX_PATH_LEN+1]; /* Buffer */
char file[MAX_PATH_LEN+1]; /* Container file name */
char path[MAX_PATH_LEN+1]; /* Object path name */
char *bra; /* Position of '(' character */
char *dot; /* Position of '.' */
size_t ncf; /* Number of characters in filename */
int i; /* Loop counter */
int nlev; /* Object level in HDS */
#if defined( vms )
char *semi; /* Position of ';' */
#endif
char *start; /* Position to start in path name */
int add_dot; /* Do we need to add a '.' ? */
int odd; /* Is the filename odd? */
/* Terminate the buffer so that it is safe*/
*ref = '\0';
/* Check intial global status */
if ( *status != DAT__OK ) return *status;
/* Obtain the data object path and container file name. */
/* Lie about the size of the supplied buffer to account for quotes
and dots that may be added */
hdsTrace( locator, &nlev, path, file, status, MAX_PATH_LEN-3, MAX_PATH_LEN-1 );
if ( *status == DAT__OK ) {
/* If necessary, handle VAX/VMS file names. Locate the semicolon which
* delimits the version number in the file name. */
#if defined( vms )
semi = strchr( file, ';' );
/* If found, then select the file name prior to it by replacing
it with a nul. */
if (semi != NULL ) {
*semi = '\0';
}
#endif
/* Find the filename length */
ncf = strlen( file );
/* See if the file is "odd". Check to see if it has the default file
* extension of '.SDF' with at least one character preceding it. */
odd = 1;
if ( ncf >= 5 ) {
if ( strcmp( &file[ncf-DAT__SZFLX], DAT__FLEXT) == 0) {
odd = 0;
} else {
odd = 1;
}
}
/* If the file name is odd, then we must also decide whether to append
* a '.' to the end of it. This is done to counteract the removal of a
* terminating '.' which HDS performs on all Unix file names (to permit
* the creation of files without a '.' in their names if required).
* Initially assume an extra '.' is needed.
*/
if (odd) {
add_dot = 1;
/* If the file name already ends with a '.'. then another '.' will be
* needed to protect it. Otherwise, search backwards through the final
* field of the file name (stopping when a '/' is encountered) to see
* whether there is already a '.' present.
*/
if ( file[ncf-1] != '.' ) {
/* search back through the string */
for ( i = 1; i <= ncf ; i++ ) {
if ( file[ncf-i] == '/' ) break;
/* If a '.' is present, then note that another one need not be added
* (otherwise one must be added to prevent the default ".sdf" extension
* being appended if HDS re-opens the file using this name).
*/
if ( file[ncf-i] == '.' ) {
add_dot = 0;
break;
}
}
/* If an extra '.' is needed, then append it to the file name (note
* that an extra character is reserved in FILE for this purpose).
*/
if (add_dot) {
strcat( file, "." );
}
}
}
/* If the file name is not odd, then omit the file extension. */
if (!odd) file[ncf-4] = '\0';
/* Enter the file name into the buffer, surrounding it in quotes if it
* is odd. */
*buff = '\0';
if (odd) strcat(buff, "\"" );
strcat( buff, file );
if (odd) strcat(buff, "\"" );
/* If the object is not a top-level object, then find the position of
* the first '.' in its pathname, which marks the start of the first
* component name. */
if (nlev > 1 ) {
dot = strchr( path, '.' );
/* If successful, see if the '.' is preceded by a '(' indicating that
* the top-level object is subscripted. Derive the starting position in
* the path name so that the subscript is used if present. */
if (dot != NULL) {
bra = strchr( path, '(' );
if (bra != NULL && bra < dot) {
start = bra;
} else {
start = dot;
}
/* Add the required part of the path name to the buffer. */
strcat( buff, start );
}
} else {
/* If the object is a top-level object, then see if it is subscripted.
* If so, then add the subscript to the buffer. */
start = strchr( path, '(' );
if ( start != NULL ) {
strcat( buff, start );
}
}
/* If the length of the reference name exceeded the length of the output
* argument, then append an ellipsis.
*/
if ( strlen(buff) > reflen -1 ) {
strncpy( ref, buff, reflen - 4 );
ref[reflen-4] = '\0';
strcat(ref, "xyz");
/* Report an error showing the truncated character string */
*status = DAT__TRUNC;
emsSetc( "STRING", ref );
emsRep( "DAT_REF_1",
"Character string truncated: '^STRING'.",
status );
emsRep( "DAT_REF_2",
"Output character variable is too short "
"to accommodate the returned result.",
status );
} else {
strcpy( ref, buff );
}
}
/* If an error occurred report contextual information */
if ( *status != DAT__OK ) {
emsRep( "DAT_REF_ERR",
"DAT_REF: Error obtaining a reference name "
"for an HDS object.", status );
}
return *status;
}
void rec1_get_path( const char *fname, INT fname_len, char **path,
INT *path_len )
{
/*+ */
/* Name: */
/* rec1_get_path */
/* Purpose: */
/* Obtain a full path name for a file (UNIX & POSIX only). */
/* Invocation: */
/* rec1_get_path( fname, fname_len, path, path_len ) */
/* Description: */
/* The routine translates a file name, which may be absolute or relative */
/* and which may contain shell meta-characters, into a full path name. A */
/* default file type extension of ".sdf" is added if appropriate. */
/* Leading and trailing white space is ignored. */
/* Parameters: */
/* const char *fname */
/* Pointer to a char array containing the original file name (not */
/* null terminated). The file need not necessarily exist, although */
/* the file system will be searched to identify it if shell */
/* pattern-matching characters are included. */
/* INT fname_len */
/* Number of characters in the original file name. */
/* char **path */
/* The value of *path will be set by this routine to point at a */
/* null-terminated character string containing the fully-expanded */
/* path name for the file. This path name occupies space dynamically */
/* allocated by rec_alloc_mem. It should be deallocated by the caller */
/* (using rec_deall_mem) when no longer required. The amount of space */
/* allocated is equal to (*path_len + 1) bytes. */
/* INT *path_len */
/* Pointer to an integer which will be set to the number of */
/* characters in the expanded path name, excluding the terminating */
/* null. */
/* Returned Value: */
/* void */
/* Notes: */
/* - If the file specification contains pattern matching characters and */
/* matches more than one file, then the first match will be used. */
/* - A value of NULL will be returned in *path and a value of zero in */
/* *path_len if this routine is called with the global status set, or if */
/* it should fail for any reason. */
/* - This routine is only implemented for UNIX & POSIX systems. */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005 Particle Physics and Astronomy Research Council */
/* Licence: */
/* This program is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU General Public License as */
/* published by the Free Software Foundation; either version 2 of */
/* the License, or (at your option) any later version. */
/* This program is distributed in the hope that it will be */
/* useful, but WITHOUT ANY WARRANTY; without even the implied */
/* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR */
/* PURPOSE. See the GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public */
/* License along with this program; if not, write to the Free */
/* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, */
/* MA 02110-1301, USA */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK, RAL) */
/* PWD: Peter W. Draper (STARLINK, Durham University) */
/* TIMJ: Tim Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 25-NOV-1992 (RFWS): */
/* Original version. */
/* 9-DEC-1992 (RFWS): */
/* Report an error if the file name is completely blank. */
/* 21-JUL-2004 (PWD): */
/* Add changes to support MinGW under Windows (no process control, */
/* plus Windows filename conventions), so that we can build */
/* shareable libraries for JNIHDS. */
/* 28-DEC-2005 (TIMJ): */
/* Use DAT__FLEXT rather than hard-coded ".sdf" */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Constants: */
#if defined( PATH_MAX )
const INT mxbuf0 = PATH_MAX; /* Initial size of file name buffer */
#else
const INT mxbuf0 = _POSIX_PATH_MAX;
#endif
/* Local Variables: */
FILE *stream; /* Stream for reading file name */
INT i; /* Loop counter for file name characters */
INT idot=0; /* Character position of last dot */
INT islash=0; /* Character position of last slash */
INT lcwd; /* Length of working directory string */
INT mxbuf=0; /* Allocated size of buffer */
INT start; /* Array index of first non-blank char */
char *buffer; /* Pointer to buffer for reading file name */
char *cwd; /* Pointer to working directory string */
char c; /* File name character read from stream */
const char *basename=NULL; /* Pointer to base file name */
int absolute; /* Absolute path name? */
int extn; /* File type extension present? */
int lbase=0; /* Number of characters in basename string */
int special=0; /* Special characters in file name? */
int stat_val; /* Shell process status information */
pid_t pid; /* ID of shell process */
#if __MINGW32__
/* Use Windows separator */
#define SLASH '\\'
#else
#define SLASH '/'
#endif
/*. */
/* Set initial null values for the returned results. */
*path = NULL;
*path_len = 0;
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return;
/* Initialise. */
buffer = NULL;
pid = (pid_t) -1;
/* Modify the file name length to omit any trailing white space. */
for ( ; fname_len > 0; fname_len-- )
{
if ( !isspace( fname[ fname_len - 1 ] ) ) break;
}
/* Also strip white space from the start of the file specification. */
for ( start = 0; start < fname_len; start++ )
{
if ( !isspace( fname[ start ] ) ) break;
}
/* If the file name is completely blank, then report an error. */
if ( start == fname_len )
{
hds_gl_status = DAT__FILNF;
emsRep( "REC_GET_PATH_1",
"Invalid blank file name given.",
&hds_gl_status );
}
/* Scan the file name, classifying the characters that appear in it. */
else
{
idot = islash = special = 0;
for ( i = start; i < fname_len; i++ )
{
switch ( fname[ i ] )
{
/* Note where the last dot '.' occurs. */
case '.':
idot = i + 1;
break;
/* Note where the last slash '/' occurs. */
case SLASH:
islash = i + 1;
break;
/* Underscore '_' and hyphen '-' are portable file name characters, so take */
/* no action on these. */
case '_':
case '-':
break;
/* If any other characters which are not in the POSIX.1 portable filename */
/* character set are encountered, then note that the file name contains */
/* special characters. */
default:
if ( !isalnum( fname[ i ] ) )
{
special = 1;
}
break;
}
}
}
/* Ignore the possible presence of special characters if the HDS__SHELL */
/* tuning parameter specifies that shell expansion of such characters is */
/* not to occur. */
#if __MINGW32__
/* MinGW doesn't offer a shell facility so make sure it is disabled */
hds_gl_shell = HDS__NOSHELL;
special = 0;
#else
if ( hds_gl_shell == HDS__NOSHELL ) special = 0;
#endif
/* If there are no speciaal characters present, then the file name can be */
/* used as the basis of the full path name, without further translation. */
if ( !special )
{
basename = fname + start;
/* Note if a file type extension is present, as indicated by a dot '.' in */
/* the final field of the file name (i.e. after the last slash '/'). Find */
/* how much of the file name must be used after omitting exactly one final */
/* dot '.', if present (it is a general rule in HDS that this operation is */
/* performed on file names before use). */
extn = ( idot > islash );
lbase = fname_len - start - ( idot == fname_len );
}
/* If special characters are present in the file name, then we must use a */
/* shell process to interpret them. We only do this if it is really */
/* necessary, since it is slower. Note that file extension information will */
/* be handled and start a shell process for finding files. */
else
{
extn = 1;
rec1_find_file( fname + start, fname_len - start, &pid, &stream );
if ( _ok( hds_gl_status ) )
{
/* Allocate initial space for a buffer to hold the expanded file name. */
rec_alloc_mem( mxbuf0, (void **) &buffer );
if ( _ok( hds_gl_status ) ) mxbuf = mxbuf0;
/* Read the name of the first file found. Loop to read characters one at a */
/* time and append them to the file name until an error or end of file */
/* occurs, or a blank character is read. */
lbase = 0;
while ( _ok( hds_gl_status ) )
{
(void) fread( (void *) &c, sizeof( char ), (size_t) 1,
stream );
/* If an error occurs, then report it and quit reading. */
if ( ferror( stream ) )
{
hds_gl_status = DAT__FATAL;
emsSyser( "MESSAGE", errno );
emsRep( "REC_GET_PATH_2",
"Error reading file names from stream attached \
to shell process - ^MESSAGE",
&hds_gl_status );
break;
}
/* If an end of file occurs, or a blank character is read, then we have */
/* reached the end of the file name, so quit reading. */
else if ( feof( stream ) || isspace( c ) )
{
break;
}
/* The character just read must now be appended to the file name. Check */
/* that the file name buffer is large enough to hold it. If not, then */
/* extend the buffer by doubling its length and record its new size. */
if ( lbase >= mxbuf )
{
rec_reall_mem( mxbuf * 2, (void **) &buffer );
if ( _ok( hds_gl_status ) )
{
mxbuf *= 2;
}
}
/* If OK, append the character to the file name. */
if ( _ok( hds_gl_status ) )
{
buffer[ lbase++ ] = c;
}
}
/* If no file name characters were read, then there was no file name match, */
/* so report an error. */
if ( lbase == 0 )
{
hds_gl_status = DAT__FILNF;
emsSetnc( "FILE", fname + start, fname_len - start );
emsRep( "REC_GET_PATH_3",
"No files found matching the file specification \
\'^FILE\'.",
&hds_gl_status );
}
/* Close the stream and check for errors. Do this inside a new error */
/* reporting environment, since we may be cleaning up after a previous */
/* error. */
emsBegin( &hds_gl_status );
if ( fclose ( stream ) != 0 )
{
hds_gl_status = DAT__FATAL;
emsSyser( "MESSAGE", errno );
emsRep( "REC_GET_PATH_4",
"Error closing stream used to read file names from \
a shell process - ^MESSAGE",
&hds_gl_status );
}
int dat1_alloc_lcp( struct LOC **loc, struct LCP **lcp )
{
/*+ */
/* Name: */
/* dat1_alloc_lcp */
/* Purpose: */
/* Allocate a Locator Control Packet and initialise a locator. */
/* Invocation: */
/* dat1_alloc_lcp( loc, lcp ) */
/* Description: */
/* This function allocates a new Locator Control Packet (LCP) to control */
/* user access to an HDS object and initialises a locator, thereby */
/* associating it with the allocated LCP. */
/* Parameters: */
/* struct LOC **loc */
/* Pointer to a pointer to a struct LOC that is to be filled with the */
/* locator information. Will be malloced by this routine and freed */
/* with a datAnnul. *loc Must be NULL on entry. */
/* struct LCP **lcp */
/* Pointer to a pointer which will be set to identify the */
/* newly-allocated LCP. A null pointer will be returned in *lcp if */
/* this routine is invoked with the global status set, or if it */
/* should fail for any reason. */
/* Returned Value: */
/* int dat1_alloc_lcp */
/* The global status value current on exit. */
/* Notes: */
/* The returned LCP will have its data fields and "primary locator" flag */
/* initialised to zero. Its sequence number will be set to match that of */
/* the locator. */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005-2006 Particle Physics and Astronomy Research Council */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* TIMJ: T. Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 14-OCT-1992 (RFWS): */
/* Substantially new routine based on old original. */
/* 15-NOV-2005 (TIMJ): */
/* Change API to use the struct LOC explcitly */
/* 23-FEB-2006 (TIMJ): */
/* use rec_alloc_mem */
/* {@enter_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
/*. */
/* Set an initial null value for the returned LCP pointer. */
*lcp = NULL;
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return hds_gl_status;
/* Check that the locator is NULL */
if (*loc != NULL ) {
hds_gl_status = DAT__LOCIN;
emsRep( "DAT1_ALLOC_LCP",
"Supplied locator is not a NULL pointer (Possible programming error)",
&hds_gl_status);
return hds_gl_status;
}
/* Ensure that HDS has been initialised. */
if ( !hds_gl_active )
{
dat1_init( );
}
/* If the Free Locator Queue is empty, then refill it. */
if ( dat_ga_flq == NULL )
{
dau_refill_flq( );
}
/* Allocate a new LCP from the free queue. */
if( _ok( hds_gl_status ) )
{
*lcp = dat_ga_flq;
_remque( *lcp, dat_ga_flq );
/* Clear the LCP data fields and the primary LCP flag. */
(void) memset( (void *) &(*lcp)->data, 0, sizeof( struct LCP_DATA ) );
(*lcp)->primary = 0;
/* Insert the LCP at the head of the Working Locator Queue and increment */
/* the Queue size. */
_insque( *lcp, dat_ga_wlq );
dat_gl_wlqsize++;
/* Initialise the locator information, including the locator sequence */
/* number which is duplicated in the LCP. */
if (rec_alloc_mem( sizeof(struct LOC), (void**)loc ) == DAT__OK) {
(*loc)->check = DAT__LOCCHECK;
(*loc)->lcp = *lcp;
(*loc)->seqno = (*lcp)->seqno = ++hds_gl_locseq;
}
}
/* Exit the routine. */
return hds_gl_status;
}
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;
}
void rec1_open_file( int expand, const char *file, INT file_len, char mode,
INT *slot, int *newslot )
{
/*+ */
/* Name: */
/* rec1_open_file */
/* Purpose: */
/* Open an existing file. */
/* Invocation: */
/* rec1_open_file( expand, file, file_len, mode, slot, newslot ) */
/* Description: */
/* This function opens an existing container file for reading or writing */
/* and allocates a new File Control Vector slot (if necessary) to refer */
/* to the file. Any new FCV slot is initialised and its number is */
/* returned. The file's reference count is left unchanged if it is */
/* already in use, or is set to zero if it is being opened for the first */
/* time. */
/* Parameters: */
/* int expand */
/* If expand is non-zero, then the file name supplied will be */
/* regarded as an abbreviated form of the full name of the file and */
/* will be expanded (according to the underlying operating system's */
/* rules) before use. Otherwise, the file name supplied is regarded */
/* as already fully expanded and will be used literally. This */
/* mechanism is provided to allow previously-expanded file names to */
/* be given, while allowing for the fact that expanding a file name */
/* twice may cause the wrong file to be identified (if the underlying */
/* file system has changed and/or the expanded file name contains */
/* special characters, for instance). */
/* const char *file */
/* Pointer to a char array containing the host file-system name of */
/* the container file to be opened. It should not be null terminated. */
/* If expand is non-zero, then leading and trailing white space will */
/* be ignored. If expand is zero, then the file name must be */
/* fully-expanded and white space may be significant. */
/* INT file_len */
/* Number of characters in the file name (excluding any terminating */
/* null, if present). */
/* char mode */
/* A character specifying the required file access mode: 'R' for */
/* read-only access or 'W' for write (or update) access. */
/* INT *slot */
/* Pointer to an integer in which the File Control Vector slot number */
/* allocated to the file will be returned. */
/* int *newslot */
/* Returns 1 if the FCV slot is a new one, otherwise 0 if the slot */
/* was already in use (i.e. the file was already open). */
/* Returned Value: */
/* void */
/* Copyright: */
/* Copyright (C) 1992 Science & Engineering Research Council */
/* Copyright (C) 2005 Particle Physics and Astronomy Research Council */
/* Licence: */
/* This program is free software; you can redistribute it and/or */
/* modify it under the terms of the GNU General Public License as */
/* published by the Free Software Foundation; either version 2 of */
/* the License, or (at your option) any later version. */
/* This program is distributed in the hope that it will be */
/* useful, but WITHOUT ANY WARRANTY; without even the implied */
/* warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR */
/* PURPOSE. See the GNU General Public License for more details. */
/* You should have received a copy of the GNU General Public */
/* License along with this program; if not, write to the Free */
/* Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, */
/* MA 02110-1301, USA */
/* Authors: */
/* RFWS: R.F. Warren-Smith (STARLINK) */
/* TIMJ: Tim Jenness (JAC, Hawaii) */
/* {@enter_new_authors_here@} */
/* History: */
/* 28-MAR-1991 (RFWS): */
/* Added prologue. */
/* 3-APR-1991 (RFWS): */
/* Fixed bug in passing of file name for error message. */
/* 3-MAY-1991 (RFWS): */
/* Re-structured to return an FCV slot number and to initialise the */
/* slot if necessary. */
/* 7-MAY-1991 (RFWS): */
/* Added a portable implementation. */
/* 21-MAY-1991 (RFWS): */
/* Remove trailing blanks from file names (portable version). */
/* 22-MAY-1991 (RFWS): */
/* Added defaulting of ".sdf" file extension in portable version. */
/* 12-JUN-1991 (RFWS): */
/* Fixed bug in testing of access mode. */
/* 28-JUN-1991 (RFWS): */
/* Removed initialisation of the VMS-specific FCV lid field (not */
/* necessary). Added function prototypes for VMS system calls. */
/* 11-SEP-1992 (RFWS): */
/* Do not increment the file reference count. This is now the */
/* caller's responsibility. */
/* 14-OCT-1992 (RFWS): */
/* Changed to a void function and to use separate string pointer and */
/* length arguments. */
/* 24-NOV-1992 (RFWS): */
/* Fixed error in assigning access mode for error message. */
/* 25-NOV-1992 (RFWS): */
/* Changed to extend the File Control Vector when necessary. */
/* 26-NOV-1992 (RFWS): */
/* Enhanced file name handling by using rec1_get_path. */
/* 1-DEC-1992 (RFWS): */
/* Added the expand parameter. */
/* 28-DEC-2005 (TIMJ): */
/* Use DAT__FLEXT rather than hard-coded ".SDF" */
/* 02-FEB-2006 (TIMJ): */
/* Free malloced memory if the slot is reused. */
/* {@enter_further_changes_here@} */
/* Bugs: */
/* {@note_any_bugs_here@} */
/*- */
/* Local Variables: */
#if defined (vms ) /* VMS version local variables: */
char esabuf[ NAM$C_MAXRSS ]; /* Expanded file name string buffer */
char rsabuf[ NAM$C_MAXRSS ]; /* Resultant file name string buffer */
struct FAB fab; /* RMS file access block */
struct NAM nam; /* RMS NAM block */
unsigned int systat; /* System status code */
unsigned short int iochan; /* File I/O channel */
#else /* Portable version local variables: */
FILE *iochan=NULL; /* File I/O stream */
#endif
INT i; /* Loop counter for FCV slots */
INT lfns; /* Length of File Name String */
INT start; /* Array offset of first non-blank char */
char *fns; /* Pointer to file name string */
int mustopen=0; /* File must be opened? */
struct FCV *fcv; /* Pointer to File Control Vector element */
struct FID *fid; /* Pointer to File ID */
/* External References: */
#if defined( vms ) /* VMS version system calls: */
unsigned int SYS$OPEN( struct FAB *fab );
unsigned int SYS$PARSE( struct FAB *fab );
unsigned int SYS$SEARCH( struct FAB *fab );
#endif
/*. */
/* Check the inherited global status. */
if ( !_ok( hds_gl_status ) ) return;
/* Initialise. */
fns = NULL;
fid = NULL;
/* If necessary, modify the file name length to omit any trailing white */
/* space. */
start = 0;
if ( expand )
{
for ( ; file_len > 0; file_len-- )
{
if ( !isspace( file[ file_len - 1 ] ) ) break;
}
/* Also strip white space from the start of the file name (but leave at */
/* least one character, even if the string is completely blank). */
for ( start = 0; start < ( file_len - 1 ); start++ )
{
if ( !isspace( file[ start ] ) ) break;
}
}
/* VMS version: */
/* =========== */
#if defined( vms )
/* Initialise the file FAB and NAM blocks. */
fab = cc$rms_fab;
fab.fab$l_dna = DAT__FLEXT;
fab.fab$b_dns = DAT__SZFLX;
fab.fab$l_fna = file + start;
fab.fab$b_fns = file_len - start;
fab.fab$l_nam = &nam;
nam = cc$rms_nam;
nam.nam$l_esa = esabuf;
nam.nam$b_ess = NAM$C_MAXRSS;
nam.nam$l_rsa = rsabuf;
nam.nam$b_rss = NAM$C_MAXRSS;
/* Parse the file name, reporting any errors. */
systat = SYS$PARSE( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ? DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", file + start, file_len - start );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_1",
"Error in file name \'^FILE\' - ^MESSAGE.",
&hds_gl_status );
}
/* Search for the file, again reporting errors. */
if ( _ok( hds_gl_status ) )
{
systat = SYS$SEARCH( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ? DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", esabuf, nam.nam$b_esl );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_2",
"Error searching for file ^FILE - ^MESSAGE.",
&hds_gl_status );
}
/* If the file was found successfully, then allocate memory to hold the */
/* File Name String and the File ID and copy the relevant information from */
/* the NAM block into this memory (adding a terminating null to the file */
/* name). */
else
{
lfns = nam.nam$b_rsl;
rec_alloc_mem( lfns + 1, (void **) &fns );
rec_alloc_mem( sizeof( struct FID ), (void **) &fid );
if ( _ok( hds_gl_status ) )
{
(void) memcpy( (void *) fns, (const void *) nam.nam$l_rsa,
(size_t) lfns );
fns[ lfns ] = '\0';
(void) memcpy( (void *) fid, (const void *) nam.nam$t_dvi,
sizeof( struct FID ) );
}
}
}
/* Portable version: */
/* ================ */
#else
/* If required, obtain the full path name of the file. */
if ( expand )
{
rec1_get_path( file + start, file_len - start, &fns, &lfns );
}
/* Otherwise, allocate space and copy the file name for use directly. */
else
{
lfns = file_len - start;
rec_alloc_mem( lfns + 1, (void **) &fns );
if ( _ok( hds_gl_status ) )
{
(void) memcpy( (void *) fns, (const void *) ( file + start ),
(size_t) lfns );
fns[ lfns ] = '\0';
}
}
/* Allocate memory to hold the File ID and store file identification */
/* information in it. */
rec_alloc_mem( sizeof( struct FID ), (void **) &fid );
rec1_get_fid( fns, fid );
#endif
/* Loop to search the File Control Vector for any slot which is currently */
/* open and associated with the same file. */
if ( _ok( hds_gl_status ) )
{
*slot = rec_gl_endslot;
*newslot = 1;
for ( i = 0; i < rec_gl_endslot; i++ )
{
/* Remember the number of the last slot which is not being used. */
if ( !rec_ga_fcv[ i ].open )
{
*slot = i;
}
/* If a slot is open and the identification matches, then note that a new */
/* slot is not needed and quit searching */
else if ( !memcmp( (const void *) rec_ga_fcv[ i ].fid,
(const void *) fid, sizeof( struct FID ) ) )
{
*slot = i;
*newslot = 0;
break;
}
}
/* If no File ID match or unused FCV slot was found, then a new slot must */
/* be used. */
if ( *slot == rec_gl_endslot )
{
/* If there is insufficient space for another slot in the File Control */
/* Vector, then extend the FCV by doubling its size. If successful, */
/* initialise the new region to zero and record the new size. */
if ( *slot >= rec_gl_mxslot )
{
rec_reall_mem( rec_gl_mxslot * 2 * sizeof( struct FCV ),
(void **) &rec_ga_fcv );
if ( _ok( hds_gl_status ) )
{
(void) memset( (void *) ( rec_ga_fcv + rec_gl_mxslot ), 0,
sizeof( struct FCV ) *
(size_t) rec_gl_mxslot );
rec_gl_mxslot *= 2;
}
}
/* If OK, increment the count of FCV slots used. */
if ( _ok( hds_gl_status ) )
{
rec_gl_endslot++;
}
}
}
/* See if the file needs opening. This will be necessary if a new FCV slot */
/* is being used or if the file is currently open for read-only access and */
/* write access is now required. */
if ( _ok( hds_gl_status ) )
{
mustopen = *newslot ||
( ( mode != 'R' ) &&
( rec_ga_fcv[ *slot ].write == REC__NOIOCHAN ) );
/* If the file is to be opened... */
if ( mustopen )
{
/* VMS version: */
/* =========== */
#if defined( vms )
/* Initialise the FAB block. */
fab.fab$l_fop = FAB$M_UFO | FAB$M_NAM;
fab.fab$b_shr = FAB$M_SHRPUT | FAB$M_SHRGET | FAB$M_UPI;
fab.fab$b_fac = ( mode == 'R' ) ?
FAB$M_GET : ( FAB$M_GET | FAB$M_PUT );
/* Open the file, reporting any errors. */
systat = SYS$OPEN( &fab );
if ( !( systat & STS$M_SUCCESS ) )
{
hds_gl_status = ( systat == RMS$_PRV ) ?
DAT__FILPR : DAT__FILNF;
emsSetnc( "FILE", rsabuf, nam.nam$b_rsl );
emsSetnc( "ACCESS", ( mode == 'R' ) ?
"reading" : "writing", EMS__SZTOK );
emsSyser( "MESSAGE", systat );
emsRep( "REC1_OPEN_FILE_3",
"Unable to open file ^FILE for ^ACCESS - ^MESSAGE.",
&hds_gl_status );
}
/* If the file was opened successfully, extract its I/O channel from the */
/* FAB block. */
else
{
iochan = (int) fab.fab$l_stv;
}
/* Portable version: */
/* ================ */
#else
/* Open the file, checking for errors. */
iochan = fopen( (const char *) fns,
( mode == 'R' ) ? "rb" : "r+b");
if ( iochan == NULL )
{
/* Categorise the possible error conditions, setting the appropriate status */
/* value. */
switch ( errno )
{
case EACCES:
hds_gl_status = DAT__FILPR; /* Access denied */
break;
case EISDIR:
hds_gl_status = DAT__FILIN; /* File is a directory */
break;
case EROFS:
hds_gl_status = DAT__FILPR; /* Read-only file system */
break;
default: /* All other errors ==> */
hds_gl_status = DAT__FILNF; /* File not found */
break;
}
/* Report the error. */
emsSyser( "MESSAGE", errno );
emsSetnc( "FILE", fns, EMS__SZTOK );
emsSetnc( "ACCESS", ( mode == 'R' ) ? "read" : "read/write",
EMS__SZTOK );
emsRep( "REC1_OPEN_FILE_4",
"Error opening file ^FILE for ^ACCESS access - \
^MESSAGE",
&hds_gl_status );
}
#endif
}
}
/* If the file has been opened successfully but an old slot has been used, */
/* then simply store the new I/O channel in the slot. */
if ( _ok( hds_gl_status ) )
{
if ( mustopen )
{
if ( !*newslot )
{
rec_ga_fcv[ *slot ].write = iochan;
}
/* If a new slot is being used, fill in the File Control Vector fields, */
/* marking the slot as open. */
else
{
fcv = &rec_ga_fcv[ *slot ];
fcv->name = fns;
fcv->fid = fid;
fcv->read = ( mode == 'R' ) ? iochan : REC__NOIOCHAN;
fcv->write = ( mode == 'R' ) ? REC__NOIOCHAN : iochan;
fcv->count = 0;
fcv->dele = 0;
fcv->open = 1;
fcv->locked = 0;
fcv->hcb = NULL;
fcv->hcbmodify = 0;
}
}
}
/* If an error occurred, then deallocate any memory allocated for the File */
/* Name String and File ID. */
/* Also free the memory if we are reusing a slot (since the name is already */
/* stored and the copy is not used. */
if ( !_ok( hds_gl_status ) || !*newslot )
{
rec_deall_mem( lfns + 1, (void **) &fns );
rec_deall_mem( sizeof( struct FID ), (void **) &fid );
}
/* Exit the routine. */
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;
}
void crehds( int argc, IDL_VPTR argv[] ) {
/*
** Declare variables
*/
char *hdsname; /* The name of the HDS container file to create */
char *strucname; /* The name of the top-level structure */
IDL_VPTR var;
int ndims;
hdsdim dims[DAT__MXDIM];
int status; /* Starlink status */
HDSLoc* toploc = NULL; /* Locator to top object */
int numtags; /* Number of tags = 0 if not a structure */
char hdstype[DAT__SZTYP+1]; /* corresponding HDS type */
int fstat; /* Final status (before emsEload) */
char param[EMS__SZPAR+1]; /* Error message parameter name */
int parlen; /* Length of error message parameter name */
char opstr[EMS__SZMSG+1]; /* Error message */
int oplen; /* Length of error message */
char **taglist; /* Pointer to taglist */
char *data; /* Pointer to data */
IDL_LONG nvals; /* Number of values in var */
int elt_len; /* Length of element of structure */
IDL_STRING *IDL_tags;
hdsdim IDL_ntags;
char defname[12]="IDL2HDS_OUT";
/* Start Error context */
status = SAI__OK;
emsMark();
/* Check that the correct number of arguments were passed in */
if ( ( argc == 2 ) | (argc == 3 ) ) {
var = argv[0];
if ( argv[1]->flags & IDL_V_ARR ) {
IDL_tags = (IDL_STRING *)argv[1]->value.arr->data;
IDL_ntags = (hdsdim)argv[1]->value.arr->n_elts;
} else {
IDL_tags = &argv[1]->value.str;
IDL_ntags = 1;
}
taglist = getstringarray( 1, &IDL_ntags, IDL_tags );
if ( argc == 3 )
hdsname = argv[2]->value.str.s;
else
hdsname = defname;
strucname = hdsname;
IDL_VarGetData( var, &nvals, &data, 0 );
getobjectdetails( var, data, taglist,
hdstype, &numtags, &ndims, dims, &elt_len, &status );
hdsNew( hdsname, strucname, hdstype, ndims, dims, &toploc, &status );
if ( numtags ) {
/* is a structure - invoke the structure handler */
hdsstructwrite(
toploc, data, taglist, numtags, ndims, dims, var, &status );
retstringarray( taglist );
} else {
hdsprimwrite( toploc, hdstype, ndims, dims, data, &status );
}
datAnnul( &toploc, &status );
} else {
status = SAI__ERROR;
emsRep( " ", "crehds: Incorrect number of arguments", &status );
}
/* Report any error messages */
/* Adding Starlink-style !! and ! prefix */
if ( status != SAI__OK ) {
fstat = status;
while ( status != SAI__OK ) {
emsEload(
param, &parlen, opstr, &oplen, &status );
if ( status != SAI__OK )
IDL_Message( IDL_M_NAMED_GENERIC, IDL_MSG_INFO, opstr );
}
}
emsRlse();
/* That's it, return to the calling routine */
return;
}