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 datAnnul( HDSLoc **locator, int * status ) {
/* Attempts to run even if status is bad */
int lstat = SAI__OK;
/* Sanity check argument */
if (!locator) return *status;
if (! *locator) return *status;
/* Begin an entirely new error context as we need to run this
regardless of external errors */
lstat = *status;
emsBegin( &lstat );
emsMark();
/* Free file resources */
dat1Annul( *locator, &lstat );
/* Free the memory associated with this locator */
*locator = dat1FreeLoc( *locator, &lstat );
/* End the error context and return the final status */
emsRlse();
emsEnd( &lstat );
*status = lstat;
return *status;
}
void errClear( int * status ) {
int level; /* Error context level */
int tstlev = 0; /* Test level variable */
/* Initialise the error context level. */
emsLevel( &level );
/* Loop to return the Error Reporting System to the default context
* level. We assume we're there when emsRlse will go no lower. */
while ( level != tstlev) {
tstlev = level;
emsRlse();
emsLevel( &level );
}
/* Check if there are any error messages pending output in the error
* table. */
emsStat( status );
if (*status != SAI__OK) {
/* There are error messages pending output, so call ERR_FLUSH to
* deliver them to the user. */
errFlush( status );
/* Check the returned status for output errors: if they have
* occurred, annul the error table at the current (default) context. */
if (*status != SAI__OK) emsAnnul( status );
} else {
/* There are no pending error messages, so just reset the status to
* SAI__OK. (the if statement guarantees this but it was done this
* way in Fortran) */
*status = SAI__OK;
}
}
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;
}
int
datErmsg(int status, size_t *len, char *msg_str)
{
/* Local Variables: */
const char *trans = NULL; /* Pointer to translation text */
int lstat; /* Local status variable */
int emslen; /* Length from EMS */
/*. */
/* Test for each DAT__ error code, obtaining a pointer to the textual */
/* translation. */
switch ( status )
{
default:
trans = NULL;
break;
case SAI__OK:
trans = "OK, no error (SAI__OK)";
break;
case DAT__LOCIN:
trans = "Locator invalid (DAT__LOCIN)";
break;
case DAT__TYPIN:
trans = "Type invalid (DAT__TYPIN)";
break;
case DAT__NAMIN:
trans = "Name invalid (DAT__NAMIN)";
break;
case DAT__MODIN:
trans = "Mode invalid (DAT__MODIN)";
break;
case DAT__DELIN:
trans = "Deletion invalid (DAT__DELIN)";
break;
case DAT__DIMIN:
trans = "Dimensions invalid (DAT__DIMIN)";
break;
case DAT__FILIN:
trans = "File invalid (DAT__FILIN)";
break;
case DAT__OBJIN:
trans = "Object invalid (DAT__OBJIN)";
break;
case DAT__GRPIN:
trans = "Group invalid (DAT__GRPIN)";
break;
case DAT__SUBIN:
trans = "Subscripts invalid (DAT__SUBIN)";
break;
case DAT__COMEX:
trans = "Component already exists (DAT__COMEX)";
break;
case DAT__OBJNF:
trans = "Object not found (DAT__OBJNF)";
break;
case DAT__TRUNC:
trans = "Text truncated (DAT__TRUNC)";
break;
case DAT__ACCON:
trans = "Access conflict (DAT__ACCON)";
break;
case DAT__CONER:
trans = "Conversion error (DAT__CONER)";
break;
case DAT__UNSET:
trans = "Primitive data undefined (DAT__UNSET)";
break;
case DAT__VERMM:
trans = "Version mismatch (DAT__VERMM)";
break;
case DAT__PRMAP:
trans = "Primitive data mapped (DAT__PRMAP)";
break;
case DAT__FILCK:
trans = "File lock error (DAT__FILCK)";
break;
case DAT__FILNF:
trans = "File not found (DAT__FILNF)";
break;
case DAT__FILPR:
trans = "File protected (DAT__FILPR)";
break;
case DAT__INCHK:
trans = "Integrity check (DAT__INCHK)";
break;
case DAT__FATAL:
trans = "Fatal internal error (DAT__FATAL)";
break;
case DAT__ISMAP:
trans = "Data currently mapped (DAT__ISMAP)";
break;
case DAT__BOUND:
trans = "Outside bounds of object (DAT__BOUND)";
break;
case DAT__FILCL:
trans = "File close error (DAT__FILCL)";
break;
case DAT__FILCR:
trans = "File create error (DAT__FILCR)";
break;
case DAT__FILMP:
trans = "File mapping error (DAT__FILMP)";
break;
case DAT__FILND:
trans = "File not deleted (DAT__FILND)";
break;
case DAT__FILNX:
trans = "File not extended (DAT__FILNX)";
break;
case DAT__FILRD:
trans = "File read error (DAT__FILRD)";
break;
case DAT__FILWR:
trans = "File write error (DAT__FILWR)";
break;
case DAT__NOMEM:
trans = "Memory allocation error (DAT__NOMEM)";
break;
case DAT__WLDIN:
trans = "Wild card search context invalid (DAT__WLDIN)";
break;
}
/* If translation text was found, then determine the number of significant */
/* characters to be returned and copy them to the output string. */
if ( trans != NULL )
{
strcpy( msg_str, trans );
*len = strlen( msg_str );
}
/* If the error code is not a DAT__ error code, then use ems_ to translate */
/* it as a system error code, and copy the resulting text to the output */
/* string. */
else
{
lstat = SAI__OK;
emsMark( );
emsSyser( "MESSAGE", status );
emsMload( " ", "^MESSAGE", msg_str, &emslen, &lstat );
*len = emslen;
emsRlse( );
}
/* Exit the routine. */
return SAI__OK;
}
void datMsg( const char * token, const HDSLoc * loc ) {
/* Local Variables: */
char buff[EMS__SZMSG+EMS__SZMSG+2]; /* Buffer for file+path */
char file[EMS__SZMSG+1]; /* Container file name */
char path[EMS__SZMSG+1]; /* Object path name */
char *bra; /* Position of '(' character */
char *dot; /* Position of '.' */
size_t ncf; /* Number of characters in filename */
int nlev; /* Object level in HDS */
#if defined( vms )
char *semi; /* Position of ';' */
#endif
char *start; /* Position to start in path name */
int status = DAT__OK; /* local status variable */
int odd; /* Is the filename odd? */
int ok; /* No error occurred? */
/* Mark the error stack */
emsMark();
/* Obtain the data object path and container file name. */
hdsTrace( loc, &nlev, path, file, &status, sizeof(path), sizeof(file) );
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 not odd, then omit the file extension. */
if (!odd) file[ncf-DAT__SZFLX] = '\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 );
}
}
}
/* Note if any error has occurred. */
ok = ( status == DAT__OK ? 1 : 0 );
/* If an error occurred, then annul it. Release the error stack. */
if ( status != DAT__OK ) emsAnnul( &status );
emsRlse();
/* If no error occurred, then assign the resulting buffer contents to
* the message token. */
if (ok) emsSetc( token, buff );
}
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;
}
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;
}