Context Navigation

source: rxutilex/trunk/rxutilex.c@ 36

Last change on this file since 36 was 36, checked in by Alex Taylor, 9 years ago
Add Sys2QueryDriveInfo function and updated documentation.
File size: 121.9 KB

Line
1	/******************************************************************************
2	* REXX Utility Functions - Extended (RXUTILEX.DLL) *
3	* (C) 2011, 2017 Alex Taylor. *
4	* *
5	* LICENSE: *
6	* *
7	* Redistribution and use in source and binary forms, with or without *
8	* modification, are permitted provided that the following conditions are *
9	* met: *
10	* *
11	* 1. Redistributions of source code must retain the above copyright *
12	* notice, this list of conditions and the following disclaimer. *
13	* *
14	* 2. Redistributions in binary form must reproduce the above copyright *
15	* notice, this list of conditions and the following disclaimer in the *
16	* documentation and/or other materials provided with the distribution. *
17	* *
18	* 3. The name of the author may not be used to endorse or promote products *
19	* derived from this software without specific prior written permission. *
20	* *
21	* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ''AS IS'' AND ANY EXPRESS OR *
22	* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED *
23	* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE *
24	* DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, *
25	* INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES *
26	* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR *
27	* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) *
28	* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, *
29	* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN *
30	* ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE *
31	* POSSIBILITY OF SUCH DAMAGE. *
32	* *
33	******************************************************************************/
34
35	// Uncomment to use DosQProcStatus() instead of DosQuerySysState().
36	// -- This was mostly put in place for early testing to see if either function
37	// was more/less reliable than the other. In practice, DosQuerySysState()
38	// should probably be used.
39	// #define USE_DQPS
40
41	// Uncomment to use legacy C style locale data instead of the OS/2 ULS library
42	#define LEGACY_C_LOCALE
43
44	#define INCL_WINATOM
45	#define INCL_WINCLIPBOARD
46	#define INCL_WINERRORS
47	#define INCL_DOS
48	#define INCL_DOSDEVIOCTL
49	#define INCL_DOSERRORS
50	#define INCL_DOSMISC
51	#define INCL_DOSMODULEMGR
52	#define INCL_DOSNMPIPES
53	#define INCL_DOSPROCESS
54	#define INCL_DOSPROFILE
55	#ifndef OS2_INCLUDED
56	#include <os2.h>
57	#endif
58
59	#include <ctype.h>
60	#include <stdio.h>
61	#include <stdlib.h>
62	#include <string.h>
63	#include <time.h>
64
65	#ifdef LEGACY_C_LOCALE
66	#include <locale.h>
67	#include <nl_types.h>
68	#include <langinfo.h>
69	#else
70	#include <unidef.h>
71	#endif
72
73	#define INCL_RXSHV
74	#define INCL_RXFUNC
75	#include <rexxsaa.h>
76
77
78	#include "shfuncs.h"
79
80
81	#pragma import( DosGetPrty, "DosGetPrty", "DOSCALL1", 9 )
82	USHORT APIENTRY16 DosGetPrty( USHORT usScope, PUSHORT pusPriority, USHORT pid );
83
84	#ifdef USE_DQPS
85	#pragma import( DosQProcStatus, "DosQProcStatus", "DOSCALL1", 154 )
86	USHORT APIENTRY16 DosQProcStatus( PVOID pBuf, USHORT cbBuf );
87	#endif
88
89	// CONSTANTS
90
91	#define SZ_LIBRARY_NAME "RXUTILEX" // Name of this library
92	//#define SZ_ERROR_NAME "SYS2ERR" // REXX variable used to store error codes
93	#define SZ_VERSION "0.1.4" // Current version of this library
94
95	// Maximum string lengths...
96	#ifdef NO_SHARED_SOURCE
97	#define US_COMPOUND_MAXZ 250 // ...of a compound variable
98	#define US_ERRSTR_MAXZ 250 // ...of an error string
99
100	static const char *PSZ_ZERO = "0";
101	static const char *PSZ_ONE = "1";
102	#endif
103
104	#define US_INTEGER_MAXZ 12 // ...of a 32-bit integer string
105	#define US_LONGLONG_MAXZ 21 // ...of a 64-bit integer string
106	#define US_STEM_MAXZ ( US_COMPOUND_MAXZ - US_INTEGER_MAXZ ) // ...of a stem
107	#define US_PIDSTR_MAXZ ( CCHMAXPATH + 100 ) // ...of a process information string
108	#define US_TIMESTR_MAXZ 256 // ...of a formatted time string
109	#define US_NUMSTR_MAXZ 64 // ...of a formatted number string
110	#define US_PIPESTATUS_MAXZ 128 // ...of a pipe status string
111	#define US_DISKINFO_MAXZ 128 // ...of a disk information string
112
113	#define UL_SSBUFSIZE 0xFFFF // Buffer size for the DosQuerySysState() data
114
115	// Time string formats
116	#define FL_TIME_DEFAULT 0
117	#define FL_TIME_ISO8601 1
118	#define FL_TIME_LOCALE 2
119
120	// List of functions to be registered by Sys2LoadFuncs or dropped by Sys2DropFuncs
121	// Drop list starts at index 0, load list starts at index 1
122	static PSZ RxFunctionTbl[] = {
123	"Sys2LoadFuncs", // Drop only 2015-05-06 SHL
124	"Sys2DropFuncs",
125	"Sys2GetClipboardText",
126	"Sys2PutClipboardText",
127	"Sys2QueryProcess",
128	"Sys2QueryProcessList",
129	"Sys2KillProcess",
130	"Sys2QueryDriveInfo",
131	"Sys2QueryForegroundProcess",
132	"Sys2QueryPhysicalMemory",
133	"Sys2FormatNumber",
134	"Sys2FormatTime",
135	"Sys2GetEpochTime",
136	"Sys2ReplaceModule",
137	"Sys2LocateDLL",
138	"Sys2CreateNamedPipe",
139	"Sys2ConnectNamedPipe",
140	"Sys2DisconnectNamedPipe",
141	"Sys2CheckNamedPipe",
142	"Sys2Open",
143	"Sys2Close",
144	"Sys2Seek",
145	"Sys2Read",
146	"Sys2SyncBuffer",
147	"Sys2Write",
148	"Sys2Version"
149	};
150
151	// FUNCTION DECLARATIONS
152
153	// Exported REXX functions
154	RexxFunctionHandler Sys2LoadFuncs;
155	RexxFunctionHandler Sys2DropFuncs;
156	RexxFunctionHandler Sys2Version;
157
158	RexxFunctionHandler Sys2FormatNumber;
159	RexxFunctionHandler Sys2FormatTime;
160	RexxFunctionHandler Sys2GetEpochTime;
161
162	RexxFunctionHandler Sys2GetClipboardText;
163	RexxFunctionHandler Sys2PutClipboardText;
164
165	RexxFunctionHandler Sys2QueryProcess;
166	RexxFunctionHandler Sys2QueryProcessList;
167	RexxFunctionHandler Sys2KillProcess;
168	RexxFunctionHandler Sys2QueryForegroundProcess;
169
170	RexxFunctionHandler Sys2QueryDriveInfo;
171
172	RexxFunctionHandler Sys2QueryPhysicalMemory;
173
174	RexxFunctionHandler Sys2LocateDLL;
175	RexxFunctionHandler Sys2ReplaceModule;
176
177	RexxFunctionHandler Sys2CreateNamedPipe;
178	RexxFunctionHandler Sys2ConnectNamedPipe;
179	RexxFunctionHandler Sys2DisconnectNamedPipe;
180	RexxFunctionHandler Sys2CheckNamedPipe;
181
182	RexxFunctionHandler Sys2Open;
183	RexxFunctionHandler Sys2Close;
184	RexxFunctionHandler Sys2Seek;
185	RexxFunctionHandler Sys2Read;
186	RexxFunctionHandler Sys2Write;
187	RexxFunctionHandler Sys2SyncBuffer;
188
189
190	// Private internal functions
191	ULONG GetProcess( PCSZ pszProgram, PSZ pszFullName, PULONG pulPID, PULONG pulPPID, PULONG pulType, PUSHORT pusPriority, PULONG pulCPU ); // 2016-02-20 SHL
192
193	#ifdef NO_SHARED_SOURCE
194	BOOL SaveResultString( PRXSTRING prsResult, PCSZ pchBytes, ULONG ulBytes ); // 2016-02-20 SHL
195	BOOL WriteStemElement( PCSZ pszStem, ULONG ulIndex, PCSZ pszValue ); // 2016-02-20 SHL
196	void WriteErrorCode( ULONG ulError, PCSZ pszContext ); // 2016-02-20 SHL
197	#endif
198
199	// MACROS
200	#define TIME_SECONDS( timeval ) ( timeval / 32 )
201	#define TIME_HUNDREDTHS( timeval ) (( timeval % 32 ) * 100 / 32 )
202
203	/* ------------------------------------------------------------------------- *
204	* Sys2LoadFuncs *
205	* *
206	* Register all Sys2* REXX functions (except this one, obviously). *
207	* *
208	* REXX ARGUMENTS: None *
209	* REXX RETURN VALUE: "" *
210	* ------------------------------------------------------------------------- */
211	ULONG APIENTRY Sys2LoadFuncs( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
212	{
213	int entries,
214	i;
215
216	// Reset the error indicator
217	WriteErrorCode( 0, NULL );
218
219	if ( argc > 0 ) return ( 40 );
220	entries = sizeof(RxFunctionTbl) / sizeof(PSZ);
221	// 2015-05-06 SHL No need to load self (i.e. Sys2LoadFuncs), but do want to drop self
222	for ( i = 1; i < entries; i++ )
223	RexxRegisterFunctionDll( RxFunctionTbl[i], SZ_LIBRARY_NAME, RxFunctionTbl[i] );
224
225	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
226	return ( 0 );
227	}
228
229
230	/* ------------------------------------------------------------------------- *
231	* Sys2DropFuncs *
232	* *
233	* Deregister all Sys2* REXX functions. *
234	* *
235	* REXX ARGUMENTS: None *
236	* REXX RETURN VALUE: "" *
237	* ------------------------------------------------------------------------- */
238	ULONG APIENTRY Sys2DropFuncs( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
239	{
240	int entries,
241	i;
242
243	// Reset the error indicator
244	WriteErrorCode( 0, NULL );
245
246	if ( argc > 0 ) return ( 40 );
247	entries = sizeof(RxFunctionTbl) / sizeof(PSZ);
248	for ( i = 0; i < entries; i++ )
249	RexxDeregisterFunction( RxFunctionTbl[i] );
250
251	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
252	return ( 0 );
253	}
254
255
256	/* ------------------------------------------------------------------------- *
257	* Sys2Version *
258	* *
259	* Returns the current library version. *
260	* *
261	* REXX ARGUMENTS: None *
262	* REXX RETURN VALUE: Current version in the form "major.minor.refresh" *
263	* ------------------------------------------------------------------------- */
264	ULONG APIENTRY Sys2Version( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
265	{
266	CHAR szVersion[ 12 ];
267
268	// Reset the error indicator
269	WriteErrorCode( 0, NULL );
270
271	if ( argc > 0 ) return ( 40 );
272	sprintf( szVersion, "%s", SZ_VERSION );
273
274	SaveResultString( prsResult, szVersion, strlen(szVersion) ); // 2016-02-20 SHL
275	return ( 0 );
276	}
277
278
279	/* ------------------------------------------------------------------------- *
280	* Sys2PutClipboardText *
281	* *
282	* Write a string to the clipboard in plain-text format. Specifying either *
283	* no value or an empty string in the first argument will simply clear the *
284	* clipboard of CF_TEXT data. *
285	* *
286	* REXX ARGUMENTS: *
287	* 1. String to be written to the clipboard (DEFAULT: "") *
288	* 2. Flag indicating whether other clipboard formats should be cleared: *
289	* Y = yes, call WinEmptyClipbrd() before writing text (DEFAULT) *
290	* N = no, leave (non-CF_TEXT) clipboard data untouched *
291	* *
292	* REXX RETURN VALUE: 1 on success, 0 on failure *
293	* ------------------------------------------------------------------------- */
294	ULONG APIENTRY Sys2PutClipboardText( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
295	{
296	PSZ pszShareMem; // text in clipboard
297	ULONG ulRC = 0, // return code
298	ulBytes = 0, // size of input string
299	ulPType = 0; // process-type flag
300	BOOL fEmptyCB = TRUE, // call WinEmptyClipbrd() first?
301	fHabTerm = TRUE; // terminate HAB ourselves?
302	HAB hab; // anchor-block handle (for Win*)
303	HMQ hmq; // message-queue handle
304	PPIB ppib; // process information block
305	PTIB ptib; // thread information block
306
307
308	// Reset the error indicator
309	WriteErrorCode( 0, NULL );
310
311	// Make sure we have at least one valid argument (the input string)
312	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
313
314	// The second argument is optional, but must be correct if specified
315	if ( argc >= 2 ) {
316	// second argument: flag to clear clipboard (Y/N, but also accept 0/1)
317	if ( RXVALIDSTRING(argv[1]) ) {
318	strupr( argv[1].strptr );
319	if ( strcspn(argv[1].strptr, "YN01") > 0 ) return ( 40 );
320	switch ( argv[1].strptr[0] ) {
321	case 'N':
322	case '0': fEmptyCB = FALSE; break;
323	case 'Y':
324	case '1':
325	default : fEmptyCB = TRUE; break;
326	}
327	} else fEmptyCB = TRUE;
328	}
329
330	// Initialize the PM API
331	DosGetInfoBlocks( &ptib, &ppib );
332	ulPType = ppib->pib_ultype;
333	ppib->pib_ultype = 3; // Morph to PM
334	hab = WinInitialize( 0 );
335	if ( !hab ) {
336	fHabTerm = FALSE;
337	hab = 1;
338	}
339
340	/* Try to create a message-queue if one doesn't exist. We don't need to
341	* check the result, because it could fail if a message queue already exists
342	* (in the calling process), which is also OK.
343	*/
344	hmq = WinCreateMsgQueue( hab, 0 );
345
346	// 2016-02-20 SHL Sync return values with docs
347
348	// Place the string on the clipboard as CF_TEXT
349	ulRC = WinOpenClipbrd( hab );
350	if ( ulRC ) {
351
352	if ( fEmptyCB ) WinEmptyClipbrd( hab );
353
354	ulBytes = argv[0].strlength + 1;
355	ulRC = DosAllocSharedMem( (PVOID) &pszShareMem,
356	NULL,
357	ulBytes,
358	PAG_READ \| PAG_WRITE \| PAG_COMMIT \| OBJ_GIVEABLE );
359	if ( ulRC == 0 ) {
360	memset( pszShareMem, 0, ulBytes );
361	strncpy( pszShareMem, argv[0].strptr, ulBytes - 1 );
362	if ( ! WinSetClipbrdData( hab, (ULONG) pszShareMem, CF_TEXT, CFI_POINTER ) ) {
363	WriteErrorCode( ERRORIDERROR(WinGetLastError(hab)), "WinSetClipbrdData" );
364	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
365	}
366	else
367	SaveResultString( prsResult, PSZ_ONE, 1 ); // Success - 2016-02-20 SHL
368	} else {
369	WriteErrorCode( ulRC, "DosAllocSharedMem");
370	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
371	}
372
373	WinCloseClipbrd( hab );
374	} else {
375	// 2016-02-20 SHL Report PM error code
376	WriteErrorCode( ERRORIDERROR(WinGetLastError(hab)), "WinOpenClipbrd" );
377	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
378	}
379
380	if ( hmq != NULLHANDLE ) WinDestroyMsgQueue( hmq );
381	if ( fHabTerm ) WinTerminate( hab );
382	ppib->pib_ultype = ulPType; // Restore
383
384	return ( 0 );
385	}
386
387
388	/* ------------------------------------------------------------------------- *
389	* Sys2GetClipboardText *
390	* *
391	* Retrieve a plain-text string from the clipboard if one is available. *
392	* *
393	* REXX ARGUMENTS: *
394	* None. *
395	* *
396	* REXX RETURN VALUE: The retrieved clipboard string or "" if fails. *
397	* ------------------------------------------------------------------------- */
398	ULONG APIENTRY Sys2GetClipboardText( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
399	{
400	PSZ pszClipText, // pointer to clipboard data
401	pszLocalText; // our copy of the data (to return)
402	ULONG ulRC = 0, // return code
403	ulBytes = 0, // size in bytes of output string
404	ulPType = 0; // process-type flag
405	BOOL fHabTerm = TRUE; // terminate HAB ourselves?
406	HAB hab; // anchor-block handle (for Win*)
407	HMQ hmq; // message-queue handle
408	PPIB ppib; // process information block
409	PTIB ptib; // thread information block
410
411
412	// Reset the error indicator
413	WriteErrorCode( 0, NULL );
414
415	// Initialize the PM API
416	DosGetInfoBlocks( &ptib, &ppib );
417	ulPType = ppib->pib_ultype;
418	ppib->pib_ultype = 3;
419	hab = WinInitialize( 0 );
420	if ( !hab ) {
421	fHabTerm = FALSE;
422	hab = 1;
423	}
424
425	/* Note: A message-queue must exist before we can access the clipboard. We
426	* don't actually use the returned value. In fact, we don't even
427	* verify it, because it could be NULLHANDLE if this function was
428	* called from a PM process (e.g. VX-REXX) - in which case, a message
429	* queue should already exist, and we can proceed anyway.
430	*/
431	hmq = WinCreateMsgQueue( hab, 0 );
432
433	// Open the clipboard
434	ulRC = WinOpenClipbrd( hab );
435	if ( ulRC ) {
436
437	// Read plain text from the clipboard, if available
438	if (( pszClipText = (PSZ) WinQueryClipbrdData( hab, CF_TEXT ) ) != NULL ) {
439
440	ulBytes = strlen(pszClipText) + 1;
441	if ( ( pszLocalText = (PSZ) malloc( ulBytes ) ) != NULL ) {
442	memset( pszLocalText, 0, ulBytes );
443	strncpy( pszLocalText, pszClipText, ulBytes - 1 );
444	SaveResultString( prsResult, pszLocalText, ulBytes - 1 ); // 2016-02-20 SHL
445	free( pszLocalText );
446	} else {
447	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "malloc");
448	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
449	}
450
451	} else {
452	// Either no text exists, or clipboard is not readable
453	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
454	}
455
456	WinCloseClipbrd( hab );
457	} else {
458	// 2016-02-20 SHL Report PM error code
459	WriteErrorCode( ERRORIDERROR(WinGetLastError(hab)), "WinOpenClipbrd" );
460	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
461	}
462
463	if ( hmq != NULLHANDLE ) WinDestroyMsgQueue( hmq );
464	if ( fHabTerm ) WinTerminate( hab );
465
466	ppib->pib_ultype = ulPType;
467
468	return ( 0 );
469	}
470
471
472	/* ------------------------------------------------------------------------- *
473	* Sys2QueryProcess *
474	* *
475	* Queries information about the specified process. *
476	* *
477	* REXX ARGUMENTS: *
478	* 1. The process identifier (program name or process ID) (REQUIRED) *
479	* 2. Flag indicicating the identifier type: *
480	* 'P': decimal process ID *
481	* 'H': hexadecimal process ID *
482	* 'N': executable program name (with or without extension) (DEFAULT) *
483	* *
484	* REXX RETURN VALUE: *
485	* A string of the format *
486	* pid parent-pid process-type priority cpu-time executable-name *
487	* "priority" is in hexadecimal notation, all other numbers are decimal. *
488	* "" is returned if the process was not found or if an internal error *
489	* occurred. *
490	* ------------------------------------------------------------------------- */
491	ULONG APIENTRY Sys2QueryProcess( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
492	{
493	PSZ pszProcName; // Requested process name
494	UCHAR szFullName[ CCHMAXPATH ] = {0}, // Fully-qualified name
495	szReturn[ US_PIDSTR_MAXZ ] = {0}; // Buffer for return value
496	ULONG ulPID = 0, // Process ID
497	ulPPID = 0, // Parent process ID
498	ulType = 0, // Process type
499	ulTime = 0; // Process CPU time
500	USHORT usPrty = 0; // Process priority
501	APIRET rc; // API return code
502
503
504	// Reset the error indicator
505	WriteErrorCode( 0, NULL );
506
507	// Make sure we have at least one valid argument (the input string)
508	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
509
510	// Parse the ID type flag
511	if ( argc >= 2 && RXVALIDSTRING( argv[1] ) ) {
512	strupr( argv[1].strptr );
513	if ( strcspn(argv[1].strptr, "HNP") > 0 ) return ( 40 );
514	switch ( argv[1].strptr[0] ) {
515
516	case 'H': if (( sscanf( argv[0].strptr, "%X", &ulPID )) != 1 ) return ( 40 );
517	pszProcName = NULL;
518	break;
519
520	case 'P': if (( sscanf( argv[0].strptr, "%u", &ulPID )) != 1 ) return ( 40 );
521	pszProcName = NULL;
522	break;
523
524	default : pszProcName = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
525	if ( pszProcName == NULL ) {
526	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
527	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
528	return ( 0 );
529	}
530	strncpy( pszProcName, argv[0].strptr, RXSTRLEN(argv[0]) );
531	break;
532	}
533	} else {
534	pszProcName = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
535	if ( pszProcName == NULL ) {
536	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
537	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
538	return ( 0 );
539	}
540	strncpy( pszProcName, argv[0].strptr, RXSTRLEN(argv[0]) );
541	}
542
543	// See if the requested process is running and get its PID/PPID
544	rc = GetProcess( pszProcName, szFullName, &ulPID, &ulPPID, &ulType, &usPrty, &ulTime );
545	if (( rc != NO_ERROR ) \|\| ( ulPID == 0 )) {
546	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
547	return ( 0 );
548	}
549
550	sprintf( szReturn, "%u %u %u %04X %02u:%02u.%02u %s",
551	ulPID, ulPPID, ulType, usPrty, TIME_SECONDS( ulTime ) / 60,
552	TIME_SECONDS( ulTime ) % 60, TIME_HUNDREDTHS( ulTime ), szFullName );
553
554	SaveResultString( prsResult, szReturn, strlen(szReturn) ); // 2016-02-20 SHL
555
556	return ( 0 );
557	}
558
559
560	/* ------------------------------------------------------------------------- *
561	* Sys2KillProcess *
562	* *
563	* Terminate the (first) running process with the specified executable name *
564	* or process-ID. *
565	* *
566	* REXX ARGUMENTS: *
567	* 1. The process identifier (program name or process ID) (REQUIRED) *
568	* 2. Flag indicicating the identifier type: *
569	* 'P': decimal process ID *
570	* 'H': hexadecimal process ID *
571	* 'N': executable program name (with or without extension) (DEFAULT) *
572	* *
573	* REXX RETURN VALUE: 1 on success or 0 on failure. *
574	* ------------------------------------------------------------------------- */
575	ULONG APIENTRY Sys2KillProcess( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
576	{
577	PSZ pszProcName; // Requested process name
578	UCHAR szFullName[ CCHMAXPATH ] = {0}; // Fully-qualified name
579	ULONG ulPID = 0, // Process ID
580	ulPPID = 0, // Parent process ID (not used)
581	ulType = 0, // Process type (not used)
582	ulTime = 0; // Process CPU time (not used)
583	USHORT usPrty = 0; // Process priority (not used)
584	APIRET rc; // API return code
585
586
587	// Reset the error indicator
588	WriteErrorCode( 0, NULL );
589
590	// Make sure we have at least one valid argument (the input string)
591	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
592
593	// Parse the ID type flag
594	if ( argc >= 2 && RXVALIDSTRING(argv[1]) ) {
595	strupr( argv[1].strptr );
596	if (strcspn(argv[1].strptr, "HNP") > 0 ) return ( 40 );
597	switch ( argv[1].strptr[0] ) {
598
599	case 'H': if (( sscanf( argv[0].strptr, "%X", &ulPID )) != 1 ) return ( 40 );
600	pszProcName = NULL;
601	break;
602
603	case 'P': if (( sscanf( argv[0].strptr, "%u", &ulPID )) != 1 ) return ( 40 );
604	pszProcName = NULL;
605	break;
606
607	default : pszProcName = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
608	if ( pszProcName == NULL ) {
609	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
610	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
611	return ( 0 );
612	}
613	strncpy( pszProcName, argv[0].strptr, RXSTRLEN(argv[0]) );
614	break;
615	}
616	} else {
617	pszProcName = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
618	if ( pszProcName == NULL ) {
619	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
620	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
621	return ( 0 );
622	}
623	strncpy( pszProcName, argv[0].strptr, RXSTRLEN(argv[0]) );
624	}
625
626	if ( pszProcName ) {
627	// Get the process PID
628	rc = GetProcess( pszProcName, szFullName, &ulPID, &ulPPID, &ulType, &usPrty, &ulTime );
629	if (( rc != NO_ERROR ) \|\| ( ulPID == 0 )) {
630	free( pszProcName );
631	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
632	return ( 0 );
633	}
634	}
635
636	// Now attempt to kill the process using DosKillProcess()
637	rc = DosKillProcess( 1, ulPID );
638	if ( rc != NO_ERROR ) {
639	WriteErrorCode( rc, "DosKillProcess");
640	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
641	}
642	else
643	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
644
645	// 2016-02-20 SHL Avoid leak
646	if ( pszProcName )
647	free( pszProcName );
648
649	return ( 0 );
650	}
651
652
653	/* ------------------------------------------------------------------------- *
654	* Sys2QueryProcessList *
655	* *
656	* Gets the process ID of the specified executable, if it is running. *
657	* The results will be returned in a stem variable, where stem.0 contains *
658	* number of items, and each stem item is a string of the form: *
659	* pid parent-pid process-type priority cpu-time executable-name *
660	* "priority" is in hexadecimal notation, all other numbers are decimal. *
661	* *
662	* Notes: *
663	* - "process-type" will be one of: *
664	* 0 Full screen protect-mode session *
665	* 1 Requires real mode. Dos emulation. *
666	* 2 VIO windowable protect-mode session *
667	* 3 Presentation Manager protect-mode session *
668	* 4 Detached protect-mode process. *
669	* - If "priority" is 0 then the priority class could not be determined. *
670	* - If "executable-name" is "--" then the name could not be identified. *
671	* *
672	* REXX ARGUMENTS: *
673	* 1. The name of the stem in which to return the results (REQUIRED) *
674	* *
675	* REXX RETURN VALUE: Number of processes found, or "" in case of error. *
676	* ------------------------------------------------------------------------- */
677	ULONG Sys2QueryProcessList( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
678	{
679	QSPTRREC *pBuf; // Data returned by DosQProcStatus/DosQuerySysState() // 2015-04-23 SHL
680	QSPREC *pPrec; // Pointer to process information block
681	QSTREC *pTrec; // Pointer to thread information block
682	CHAR szStem[ US_STEM_MAXZ ], // Buffers used for building strings ...
683	szNumber[ US_INTEGER_MAXZ ], // ...
684	szName[ CCHMAXPATH ], // Fully-qualified name of process
685	szPInfo[ US_PIDSTR_MAXZ ]; // Stem item string
686	ULONG ulCount, // Number of processes
687	ulCPU; // Process CPU time
688	USHORT usPriority, // Process priority class
689	i; // Loop counter
690	APIRET rc; // Return code
691
692
693	// Reset the error indicator
694	WriteErrorCode( 0, NULL );
695
696	// Do some validity checking on the arguments
697	if (( argc != 1 ) \|\| // Make sure we have exactly one argument...
698	( ! RXVALIDSTRING(argv[0]) ) \|\| // ...which is a valid REXX string...
699	( RXSTRLEN(argv[0]) > US_STEM_MAXZ )) // ...and isn't too long.
700	return ( 40 );
701
702	// Generate the stem variable name from the argument (stripping any final dot)
703	if ( argv[0].strptr[ argv[0].strlength-1 ] == '.') argv[0].strlength--;
704	strncpy( szStem, argv[0].strptr, RXSTRLEN(argv[0]) );
705	szStem[ RXSTRLEN(argv[0]) ] = '\0';
706
707	#ifdef USE_DQPS
708	pBuf = (QSPTRREC *) malloc( UL_SSBUFSIZE );
709	#else
710	pBuf = (QSPTRREC *) malloc( UL_SSBUFSIZE ); // 2015-04-23 SHL
711	#endif
712
713	if ( pBuf == NULL ) {
714	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "malloc");
715	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
716	return ( 0 );
717	}
718
719	#ifdef USE_DQPS
720	// Get running process information using 16-bit DosQProcStatus()
721	rc = DosQProcStatus( pBuf, UL_SSBUFSIZE );
722	if ( rc != NO_ERROR ) {
723	WriteErrorCode( rc, "DosQProcStatus");
724	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
725	return ( 0 );
726	}
727	#else
728	// Get running process information using 32-bit DosQuerySysState()
729	rc = DosQuerySysState( QS_PROCESS, 0L, 0L, 0L, pBuf, UL_SSBUFSIZE );
730	if ( rc != NO_ERROR ) {
731	WriteErrorCode( rc, "DosQuerySysState");
732	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
733	return ( 0 );
734	}
735	#endif
736
737	// Now get the list of processes
738	ulCount = 0;
739	# if 1 // 2016-02-25 SHL FIXME debug bad pointer
740	// 2016-02-26 SHL FIXME to be gone when sure this can not occur
741	if ( (ULONG)pBuf->pProcRec < 0x10000 ) {
742	sprintf( szName, "rxutilex#%u pBuf->pProcRec 0x%x < 0x10000",
743	__LINE__, (ULONG)pBuf->pProcRec );
744	WriteErrorCode( ERROR_INVALID_ADDRESS, szName );
745	SaveResultString( prsResult, NULL, 0 );
746	free( pBuf );
747	return ( 0 );
748	}
749	# endif
750
751	for (pPrec = pBuf->pProcRec;
752	;
753	pPrec = (QSPREC *)(pPrec->pThrdRec + pPrec->cTCB)
754	)
755
756	{
757	# if 0 // 2015-06-19 SHL FIXME debug bad pointer
758	// 2016-02-26 SHL FIMXE to be gone when sure no longer needed
759	if ( (ULONG)pPrec < 0x10000 ) {
760	sprintf( szName, "rxutilex#%u pPrec 0x%x < 0x10000",
761	__LINE__, (ULONG)pPrec );
762	WriteErrorCode( ERROR_INVALID_ADDRESS, szName );
763	SaveResultString( prsResult, NULL, 0 );
764	free( pBuf );
765	return ( 0 );
766	}
767	# endif
768
769	// Check for documented end marker - RecType not QS_PROCESS
770	if ( pPrec->RecType != QS_PROCESS ) {
771	# if 0 // 2016-02-26 SHL FIXME debug
772	fprintf( stderr,
773	"* rxutilex#%u RecType != QS_PROCESS "
774	"ulCount %u pBuf %p pPrec %p ->RecType %x ->pThrdRec %p ->pid %u ->ppid %u ->type %u ->stat %u ->hmte %x ->cTCB %u\n",
775	__LINE__, ulCount, pBuf, pPrec, pPrec->RecType, pPrec->pThrdRec,
776	pPrec->pid, pPrec->ppid,
777	pPrec->type, pPrec->stat, pPrec->hMte, pPrec->cTCB );
778	# endif
779	break; // Must be end of list
780	}
781
782	// Check for alternate end marker - pThredRec NULL
783	// This appears to be an undocumented end marker
784	// Might be a defect - testing says only RecType is non-zero
785	// 2015-06-12 SHL pThrdRec can be 0 - probably when process starting or dieing
786	if ( (PVOID)pPrec->pThrdRec == NULL ) {
787	# if 0 // 2016-02-26 SHL FIXME debug
788	fprintf( stderr,
789	"* rxutilex#%u pThrdRec NULL "
790	"ulCount %u pBuf %p pPrec %p ->pThrdRec %p ->pid %u ->ppid %u ->type %u ->stat %u ->hmte %x ->cTCB %u\n",
791	__LINE__, ulCount, pBuf, pPrec, pPrec->pThrdRec, pPrec->pid, pPrec->ppid,
792	pPrec->type, pPrec->stat, pPrec->hMte, pPrec->cTCB );
793	# endif
794	break; // Must be end of list
795	}
796
797	# if 1 // 2015-07-31 SHL FIXME debug bad pointer
798	// 2016-02-26 SHL FIXME to be gone when sure can not occur
799	if ( (ULONG)(pPrec->pThrdRec) < 0x10000 ) {
800	sprintf( szName,
801	"rxutilex#%u pPrec < 0x10000 "
802	"ulCount %u pBuf %p pPrec %p ->pThrdRec %p ->pid %u ->ppid %u ->type %u ->stat %u ->hmte %x ->cTCB %u\n",
803	__LINE__, ulCount, pBuf, pPrec, pPrec->pThrdRec, pPrec->pid, pPrec->ppid,
804	pPrec->type, pPrec->stat, pPrec->hMte, pPrec->cTCB );
805	WriteErrorCode( ERROR_INVALID_ADDRESS, szName );
806	SaveResultString( prsResult, NULL, 0 );
807	free( pBuf );
808	return ( 0 );
809	}
810	# endif
811	# if 1 // 2016-02-26 SHL FIXME debug bad count
812	// 2016-02-26 SHL FIXME to be gone when sure can not occur
813	// This is probably occurs only when pThrdRec NULL too which is already checked
814	if ( !pPrec->cTCB ) {
815	sprintf( szName, "rxutilex#%u cTCB 0 ulCount %u pBuf %p pPrec %p ->pid %u ->type %u ->stat %u\n",
816	__LINE__, ulCount, pBuf, pPrec, pPrec->pid, pPrec->type, pPrec->stat );
817	WriteErrorCode( ERROR_INVALID_DATA, szName );
818	SaveResultString( prsResult, NULL, 0 );
819	free( pBuf );
820	return ( 0 );
821	}
822	# endif
823
824	ulCount++;
825
826	// Get the program name of each process (including path)
827	if (( rc = DosQueryModuleName( pPrec->hMte, CCHMAXPATH-1, szName )) != NO_ERROR )
828	sprintf( szName, "--");
829	if (( rc = DosGetPrty( PRTYS_PROCESS, &usPriority, pPrec->pid )) != NO_ERROR )
830	usPriority = 0;
831
832	// Get the CPU time of the process by querying each of its threads
833	ulCPU = 0;
834	pTrec = pPrec->pThrdRec;
835	for ( i = 0; i < pPrec->cTCB; i++ ) {
836	ulCPU += ( pTrec->systime + pTrec->usertime );
837	pTrec++;
838	}
839
840	// Now generate the stem item with all of this information
841	sprintf( szPInfo, "%u %u %u %04X %02u:%02u.%02u %s",
842	pPrec->pid, // PID
843	pPrec->ppid, // Parent PID
844	pPrec->type, // Process type
845	usPriority, // Priority class
846	TIME_SECONDS( ulCPU ) / 60, // CPU time (hours)
847	TIME_SECONDS( ulCPU ) % 60, // CPU time (minutes)
848	TIME_HUNDREDTHS( ulCPU ), // CPU time (seconds)
849	szName ); // Executable name & path
850	WriteStemElement( szStem, ulCount, szPInfo );
851
852	# if 0 // 2015-07-31 SHL FIXME debug bad count
853	// 2016-02-26 SHL FIXME to be gone when sure no longer needed
854	if ( !pPrec->cTCB ) {
855	sprintf( szName, "rxutilex#%u: cTCB 0 "
856	"ulCount %u pBuf %p pPrec %p ->pThrdRec %p ->pid %u\n",
857	__LINE__, ulCount, pBuf, pPrec, pPrec->pThrdRec, pPrec->pid );
858	WriteErrorCode( ERROR_INVALID_DATA, szName );
859	SaveResultString( prsResult, NULL, 0 );
860	free( pBuf );
861	return ( 0 );
862	}
863	# endif
864	# if 0 // 2015-07-31 SHL FIXME debug bad pointer
865	// 2016-02-26 SHL FIXME to be gone when sure no longer needed
866	if ( (ULONG)pPrec->pThrdRec < 0x10000 ) {
867	sprintf( szName,
868	"rxutilex#%u: pBuf->pThrdRec < 0x10000 "
869	"ulCount %u pBuf %p pPrec %p ->pThrdRec %p ->pid %u ->cTCB %u\n",
870	__LINE__, ulCount, pBuf, pPrec, pPrec->pThrdRec, pPrec->pid, pPrec->cTCB );
871	WriteErrorCode( rc, szName );
872	SaveResultString( prsResult, NULL, 0 );
873	free( pBuf );
874	return ( 0 );
875	}
876	# endif
877	} // for
878
879	// Create the stem.0 element with the number of processes found
880	sprintf( szNumber, "%d", ulCount );
881	WriteStemElement( szStem, 0, szNumber );
882
883	// And also return the number of processes as the REXX return string
884	SaveResultString( prsResult, szNumber, strlen(szNumber) ); // 2016-02-20 SHL
885
886	free( pBuf );
887	return ( 0 );
888	}
889
890
891	/* ------------------------------------------------------------------------- *
892	* Sys2QueryPhysicalMemory *
893	* *
894	* Queries the amount of physical memory (RAM) installed in the system. *
895	* *
896	* REXX ARGUMENTS: None *
897	* *
898	* REXX RETURN VALUE: *
899	* Integer representing the amount of installed memory, in KiB, or 0 if an *
900	* error occurred. *
901	* ------------------------------------------------------------------------- */
902	ULONG APIENTRY Sys2QueryPhysicalMemory( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
903	{
904	CHAR szMemSize[ US_INTEGER_MAXZ ];
905	ULONG ulMemBytes = 0,
906	ulMemKBytes = 0;
907	APIRET rc = 0;
908
909	// Reset the error indicator
910	WriteErrorCode( 0, NULL );
911
912	// Make sure we have no arguments
913	if ( argc > 0 ) return ( 40 );
914
915	// Query installed memory in bytes
916	rc = DosQuerySysInfo( QSV_TOTPHYSMEM, QSV_TOTPHYSMEM,
917	&ulMemBytes, sizeof(ulMemBytes) );
918	if ( rc != NO_ERROR ) {
919	WriteErrorCode( rc, "DosQuerySysInfo");
920	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
921	return ( 0 );
922	}
923
924	// Convert to binary kilobytes (any remainder is discarded)
925	ulMemKBytes = ulMemBytes / 1024;
926	sprintf( szMemSize, "%u", ulMemKBytes );
927
928	// Return the memory size as the REXX return string
929	SaveResultString( prsResult, szMemSize, strlen(szMemSize) ); // 2016-02-20 SHL
930
931	return ( 0 );
932	}
933
934
935	/* ------------------------------------------------------------------------- *
936	* Sys2QueryForegroundProcess *
937	* *
938	* Queries the PID of the current foreground process. *
939	* *
940	* REXX ARGUMENTS: None *
941	* *
942	* REXX RETURN VALUE: *
943	* Integer representing the process ID (in decimal), or 0 if an error *
944	* occurred. *
945	* ------------------------------------------------------------------------- */
946	ULONG APIENTRY Sys2QueryForegroundProcess( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
947	{
948	CHAR szPID[ US_INTEGER_MAXZ ];
949	ULONG ulPID = 0;
950	APIRET rc = 0;
951
952	// Reset the error indicator
953	WriteErrorCode( 0, NULL );
954
955	// Make sure we have no arguments
956	if ( argc > 0 ) return ( 40 );
957
958	// Query installed memory in bytes
959	rc = DosQuerySysInfo( QSV_FOREGROUND_PROCESS,
960	QSV_FOREGROUND_PROCESS,
961	&ulPID, sizeof(ulPID) );
962	if ( rc != NO_ERROR ) {
963	WriteErrorCode( rc, "DosQuerySysInfo");
964	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
965	return ( 0 );
966	}
967	sprintf( szPID, "%u", ulPID );
968
969	// Return the PID as the REXX return string
970	SaveResultString( prsResult, szPID, strlen(szPID) ); // 2016-02-20 SHL
971
972	return ( 0 );
973	}
974
975
976	/* ------------------------------------------------------------------------- *
977	* Sys2ReplaceModule *
978	* *
979	* Unlocks and optionally replaces an in-use (locked) DLL or EXE. *
980	* *
981	* REXX ARGUMENTS: *
982	* 1. The filespec of the module to be replaced. (REQUIRED) *
983	* 2. The filespec of the new module to replace it with. (DEFAULT: none) *
984	* 3. The filespec of the backup file to be created. (DEFAULT: none) *
985	* *
986	* REXX RETURN VALUE: *
987	* 1 on success, or 0 if an error occurred. *
988	* ------------------------------------------------------------------------- */
989	ULONG APIENTRY Sys2ReplaceModule( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
990	{
991	PSZ pszOldModule = NULL,
992	pszNewModule = NULL,
993	pszBackup = NULL;
994	APIRET rc = 0;
995
996	// Reset the error indicator
997	WriteErrorCode( 0, NULL );
998
999	// Make sure we have at least one valid argument (the module name)
1000	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
1001	pszOldModule = calloc( argv[0].strlength + 1, sizeof(UCHAR) );
1002	if ( pszOldModule == NULL ) {
1003	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
1004	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1005	return ( 0 );
1006	}
1007	strncpy( pszOldModule, argv[0].strptr, argv[0].strlength );
1008
1009	// Second argument: new module name (optional, but must be correct if specified)
1010	if ( argc >= 2 ) {
1011	if ( RXVALIDSTRING(argv[1]) ) {
1012	pszNewModule = calloc( argv[1].strlength + 1, sizeof(char) );
1013	if ( pszNewModule == NULL ) {
1014	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
1015	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1016	return ( 0 );
1017	}
1018	strncpy( pszNewModule, argv[1].strptr, argv[1].strlength );
1019	} else return ( 40 );
1020	}
1021
1022	// Third argument: backup filename (optional, but must be correct if specified)
1023	if ( argc >= 3 ) {
1024	if ( RXVALIDSTRING(argv[2]) ) {
1025	pszBackup = calloc( argv[2].strlength + 1, sizeof(char) );
1026	if ( pszBackup == NULL ) {
1027	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
1028	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1029	return ( 0 );
1030	}
1031	strncpy( pszBackup, argv[2].strptr, argv[2].strlength );
1032	} else return ( 40 );
1033	}
1034
1035	// Now replace the module using DosReplaceModule
1036	rc = DosReplaceModule( pszOldModule, pszNewModule, pszBackup );
1037	if ( rc != NO_ERROR ) {
1038	WriteErrorCode( rc, "DosReplaceModule");
1039	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1040	return ( 0 );
1041	}
1042
1043	// Return 1 on success
1044	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
1045
1046	return ( 0 );
1047	}
1048
1049
1050	/* ------------------------------------------------------------------------- *
1051	* Sys2FormatNumber *
1052	* *
1053	* Format a number using locale-specific thousands separators. The input *
1054	* number may be a positive or negative integer or floating point value. It *
1055	* must not contain any separators already, and any decimal point which it *
1056	* contains must be a period (rather than any localized decimal symbol). *
1057	* *
1058	* REXX ARGUMENTS: *
1059	* 1. Number to be formatted. (REQUIRED) *
1060	* 2. Number of decimal places to use for floating point *
1061	* values. Ignored for integer values. (DEFAULT: 2) *
1062	* *
1063	* REXX RETURN VALUE: The formatted number, or "" on error. *
1064	* ------------------------------------------------------------------------- */
1065	ULONG APIENTRY Sys2FormatNumber( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1066	{
1067	CHAR achNumber[ US_NUMSTR_MAXZ ]; // Formatted output string
1068	float fVal; // Input value as floating point
1069	int iVal; // Input value as integer
1070	int iPrec; // Requested decimal precision
1071	PSZ pszSep = NULL; // Separator string
1072	#ifndef LEGACY_C_LOCALE
1073	CHAR achTemp[ US_NUMSTR_MAXZ ]; // Temporary buffer
1074	LocaleObject locale = NULL; // ULS locale object
1075	struct UniLconv *punilc = NULL; // ULS locale conventions structure
1076	CHAR *p = NULL; // Moving pointers within buffers
1077	CHAR *q = NULL; // ...
1078	int rc = 0;
1079	#endif
1080
1081	// Make sure we have at least one valid argument (the input number)
1082	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
1083
1084	#ifdef LEGACY_C_LOCALE
1085
1086	// Use the locale settings from the environment
1087	pszSep = nl_langinfo( THOUSEP );
1088	if ( !pszSep \|\| !strlen(pszSep) ) {
1089	/* If the current locale isn't known to the C runtime, use a common
1090	* known locale for the same language, if possible.
1091	*/
1092	PSZ pszLang, p;
1093	if ( DosScanEnv( "LANG", &pszLang ) == NO_ERROR &&
1094	pszLang &&
1095	strlen(pszLang) >= 2 )
1096	{
1097	p = strdup( pszLang );
1098	if ( !strnicmp( p, "en_us", 2 )) setlocale( LC_NUMERIC, "EN_US");
1099	else if ( !strnicmp( p, "en_uk", 2 )) setlocale( LC_NUMERIC, "EN_GB");
1100	else if ( !strnicmp( p, "de", 2 )) setlocale( LC_NUMERIC, "DE_DE");
1101	else if ( !strnicmp( p, "es", 2 )) setlocale( LC_NUMERIC, "ES_ES");
1102	else if ( !strnicmp( p, "fr", 2 )) setlocale( LC_NUMERIC, "FR_FR");
1103	else if ( !strnicmp( p, "it", 2 )) setlocale( LC_NUMERIC, "IT_IT");
1104	else if ( !strnicmp( p, "ja", 2 )) setlocale( LC_NUMERIC, "JA_JP");
1105	/*
1106	else if ( !strnicmp( p, "ar", 2 )) setlocale( LC_NUMERIC, "ar_AA");
1107	else if ( !strnicmp( p, "be", 2 )) setlocale( LC_NUMERIC, "be_BY");
1108	else if ( !strnicmp( p, "bg", 2 )) setlocale( LC_NUMERIC, "bg_BG");
1109	else if ( !strnicmp( p, "be", 2 )) setlocale( LC_NUMERIC, "be_BY");
1110	else if ( !strnicmp( p, "ca", 2 )) setlocale( LC_NUMERIC, "ca_ES");
1111	else if ( !strnicmp( p, "cs", 2 )) setlocale( LC_NUMERIC, "cs_CZ");
1112	else if ( !strnicmp( p, "da", 2 )) setlocale( LC_NUMERIC, "da_DK");
1113	else if ( !strnicmp( p, "de", 2 )) setlocale( LC_NUMERIC, "de_DE");
1114	else if ( !strnicmp( p, "el", 2 )) setlocale( LC_NUMERIC, "el_GR");
1115	else if ( !strnicmp( p, "es", 2 )) setlocale( LC_NUMERIC, "es_ES");
1116	else if ( !strnicmp( p, "fi", 2 )) setlocale( LC_NUMERIC, "fi_FI");
1117	else if ( !strnicmp( p, "fr", 2 )) setlocale( LC_NUMERIC, "fr_FR");
1118	else if ( !strnicmp( p, "hr", 2 )) setlocale( LC_NUMERIC, "hr_HR");
1119	else if ( !strnicmp( p, "hu", 2 )) setlocale( LC_NUMERIC, "hu_HU");
1120	else if ( !strnicmp( p, "is", 2 )) setlocale( LC_NUMERIC, "is_IS");
1121	else if ( !strnicmp( p, "it", 2 )) setlocale( LC_NUMERIC, "it_IT");
1122	else if ( !strnicmp( p, "iw", 2 )) setlocale( LC_NUMERIC, "iw_IL");
1123	else if ( !strnicmp( p, "ja", 2 )) setlocale( LC_NUMERIC, "ja_JP");
1124	else if ( !strnicmp( p, "ko", 2 )) setlocale( LC_NUMERIC, "ko_KR");
1125	else if ( !strnicmp( p, "mk", 2 )) setlocale( LC_NUMERIC, "mk_MK");
1126	else if ( !strnicmp( p, "nl", 2 )) setlocale( LC_NUMERIC, "nl_NL");
1127	else if ( !strnicmp( p, "no", 2 )) setlocale( LC_NUMERIC, "no_NO");
1128	else if ( !strnicmp( p, "pl", 2 )) setlocale( LC_NUMERIC, "pl_PL");
1129	else if ( !strnicmp( p, "pt", 2 )) setlocale( LC_NUMERIC, "pt_PT");
1130	else if ( !strnicmp( p, "ro", 2 )) setlocale( LC_NUMERIC, "ro_RO");
1131	else if ( !strnicmp( p, "ru", 2 )) setlocale( LC_NUMERIC, "ru_RU");
1132	else if ( !strnicmp( p, "sh", 2 )) setlocale( LC_NUMERIC, "sh_SP");
1133	else if ( !strnicmp( p, "sk", 2 )) setlocale( LC_NUMERIC, "sk_SK");
1134	else if ( !strnicmp( p, "sl", 2 )) setlocale( LC_NUMERIC, "sl_SI");
1135	else if ( !strnicmp( p, "sq", 2 )) setlocale( LC_NUMERIC, "sq_AL");
1136	else if ( !strnicmp( p, "sv", 2 )) setlocale( LC_NUMERIC, "sv_SE");
1137	else if ( !strnicmp( p, "th", 2 )) setlocale( LC_NUMERIC, "th_TH");
1138	else if ( !strnicmp( p, "tr", 2 )) setlocale( LC_NUMERIC, "tr_TR");
1139	else if ( !strnicmp( p, "uk", 2 )) setlocale( LC_NUMERIC, "uk_UA");
1140	else if ( !strnicmp( p, "zh", 2 )) setlocale( LC_NUMERIC, "zh_TW");
1141	*/
1142	else setlocale( LC_NUMERIC, "EN_US");
1143	free(p);
1144	}
1145	else setlocale( LC_NUMERIC, "en_us");
1146	}
1147	else setlocale( LC_NUMERIC, "");
1148
1149	// Check for a decimal place and treat as float or integer accordingly
1150	if ( strchr( argv[0].strptr, '.') != NULL ) {
1151	if (( sscanf( argv[0].strptr, "%f", &fVal )) != 1 ) return ( 40 );
1152	if ( argc >= 2 && ( RXVALIDSTRING(argv[1]) ) &&
1153	(( sscanf( argv[1].strptr, "%d", &iPrec )) == 1 ))
1154	{
1155	// Use user-specified precision
1156	sprintf( achNumber, "%'.*f", iPrec, fVal );
1157	}
1158	else
1159	sprintf( achNumber, "%'.2f", fVal );
1160	}
1161	else {
1162	if (( sscanf( argv[0].strptr, "%d", &iVal )) != 1 ) return ( 40 );
1163	sprintf( achNumber, "%'d", iVal );
1164	}
1165
1166	#else
1167	rc = UniCreateLocaleObject( UNI_MBS_STRING_POINTER, "", &locale );
1168	if ( rc != ULS_SUCCESS ) {
1169	WriteErrorCode( rc, "UniCreateLocaleObject");
1170	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1171	return ( 0 );
1172	}
1173	rc = UniQueryLocaleInfo(locale_object, &puni_lconv);
1174	if ( rc != ULS_SUCCESS ) {
1175	WriteErrorCode( rc, "UniQueryLocaleInfo");
1176	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1177	return ( 0 );
1178	}
1179
1180	// Check for a decimal place and treat as float or integer accordingly
1181	if ( strchr( argv[0].strptr, '.') != NULL ) {
1182	if (( sscanf( argv[0].strptr, "%f", &fVal )) != 1 ) return ( 40 );
1183	if ( argc >= 2 && ( RXVALIDSTRING(argv[1]) ) &&
1184	(( sscanf( argv[1].strptr, "%d", &iPrec )) == 1 ))
1185	{
1186	// Use user-specified precision
1187	sprintf( achNumber, "%.*f", iPrec, fVal );
1188	}
1189	else
1190	sprintf( achNumber, "%.2f", fVal );
1191	}
1192	else {
1193	if (( sscanf( argv[0].strptr, "%d", &iVal )) != 1 ) return ( 40 );
1194	sprintf( achNumber, "%d", iVal );
1195	}
1196
1197	#endif
1198
1199	// Return the formatted number
1200	SaveResultString( prsResult, achNumber, strlen(achNumber) ); // 2016-02-20 SHL
1201
1202	return ( 0 );
1203	}
1204
1205
1206	/* ------------------------------------------------------------------------- *
1207	* Sys2FormatTime *
1208	* *
1209	* Convert a number of seconds from the epoch (1970-01-01 0:00:00 UTC) into *
1210	* a formatted date and time string. *
1211	* *
1212	* REXX ARGUMENTS: *
1213	* 1. Number of seconds (a positive integer) to be converted. (REQUIRED) *
1214	* 2. Format type, one of: *
1215	* D = return in the form 'yyyy-mm-dd hh:mm:ss (w)' where w *
1216	* represents the weekday (0-6 where 0=Sunday) (DEFAULT) *
1217	* I = return in ISO8601 combined form 'yyyy-mm-ddThh:mm:ss[Z]' *
1218	* L = return in the form 'day month year (weekday) time' where month *
1219	* and weekday are language-dependent abbreviations *
1220	* Note: With D and I, time is returned in 24-hour format; L may vary. *
1221	* 3. TZ conversion flag (indicates whether to convert to UTC from local *
1222	* time), one of: *
1223	* U = return in Coordinated Universal Time *
1224	* L = convert to local time using the current TZ (DEFAULT) *
1225	* *
1226	* REXX RETURN VALUE: The formatted time string, or "" on error. *
1227	* ------------------------------------------------------------------------- */
1228	ULONG APIENTRY Sys2FormatTime( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1229	{
1230	UCHAR szFormat[ US_TIMESTR_MAXZ ] = {0}, // strftime() format specifier
1231	szTime[ US_TIMESTR_MAXZ ] = {0}; // Formatted time string
1232	BYTE flFormat = FL_TIME_DEFAULT; // Time format flag
1233	BOOL fUTC = FALSE; // UTC/local conversion flag
1234	PSZ pszTZ, // Pointer to TZ environment var
1235	pszSetTZ;
1236	int iEpoch; // Input epoch time
1237	time_t ttSeconds; // Input timestamp (seconds)
1238	struct tm *timeptr; // Timestamp structure
1239	size_t stRC; // return code from strftime()
1240
1241	// Reset the error indicator
1242	WriteErrorCode( 0, NULL );
1243
1244	// All arguments are optional but must be correct if specified
1245
1246	if ( argc >= 1 && RXVALIDSTRING(argv[0]) ) {
1247	// first argument: epoch time value
1248	if (( sscanf( argv[0].strptr, "%d", &iEpoch )) != 1 ) return ( 40 );
1249	ttSeconds = (time_t) iEpoch;
1250	}
1251
1252	if ( argc >= 2 ) {
1253	// second argument: format flag
1254	if ( RXVALIDSTRING(argv[1]) ) {
1255	strupr( argv[1].strptr );
1256	if ( strcspn(argv[1].strptr, "DIL") > 0 ) return ( 40 );
1257	switch ( argv[1].strptr[0] ) {
1258	case 'I': flFormat = FL_TIME_ISO8601; break;
1259	case 'L': flFormat = FL_TIME_LOCALE; break;
1260	default : flFormat = FL_TIME_DEFAULT; break;
1261	}
1262	}
1263	}
1264
1265	if ( argc >= 3 ) {
1266	// third argument: conversion flag
1267	if ( RXVALIDSTRING(argv[2]) ) {
1268	strupr( argv[2].strptr );
1269	if ( strcspn(argv[2].strptr, "UL") > 0 ) return ( 40 );
1270	switch ( argv[2].strptr[0] ) {
1271	case 'U': fUTC = TRUE; break;
1272	default : fUTC = FALSE; break;
1273	}
1274	}
1275	}
1276
1277	/* These next 4 lines really shouldn't be necessary, but without them
1278	* getenv() and (apparently) tzset() may see the value of TZ as NULL
1279	* if the environment variable was changed in the REXX script.
1280	*/
1281	DosScanEnv("TZ", &pszTZ );
1282	pszSetTZ = (PSZ) malloc( strlen(pszTZ) + 5 );
1283	if ( pszSetTZ ) {
1284	sprintf( pszSetTZ, "TZ=%s", pszTZ );
1285	putenv( pszSetTZ );
1286	}
1287
1288	// Use the locale and timezone settings from the environment
1289	tzset();
1290	setlocale( LC_TIME, "");
1291
1292	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) {
1293	ttSeconds = time( NULL );
1294	if ( ttSeconds == -1 ) {
1295	WriteErrorCode( ttSeconds, "time");
1296	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1297	if ( pszSetTZ ) free( pszSetTZ );
1298	return 0;
1299	}
1300	}
1301
1302	if ( fUTC ) {
1303	timeptr = gmtime( &ttSeconds );
1304	if ( !timeptr ) {
1305	WriteErrorCode( 1, "gmtime");
1306	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL // 2016-02-20 SHL
1307	if ( pszSetTZ ) free( pszSetTZ );
1308	return 0;
1309	}
1310	}
1311	else {
1312	timeptr = localtime( &ttSeconds );
1313	if ( !timeptr ) {
1314	WriteErrorCode( 1, "localtime");
1315	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1316	if ( pszSetTZ ) free( pszSetTZ );
1317	return 0;
1318	}
1319	}
1320
1321	switch ( flFormat ) {
1322	default:
1323	case FL_TIME_DEFAULT:
1324	sprintf( szFormat, "%%Y-%%m-%%d %%T (%%w)");
1325	break;
1326
1327	case FL_TIME_ISO8601:
1328	sprintf( szFormat, "%%Y-%%m-%%dT%%T");
1329	if ( fUTC ) strcat( szFormat, "Z");
1330	break;
1331
1332	case FL_TIME_LOCALE:
1333	sprintf( szFormat, "%%e %%b %%Y (%%a) %%X");
1334	break;
1335	}
1336
1337	stRC = strftime( szTime, US_TIMESTR_MAXZ-1, szFormat, timeptr );
1338	if ( stRC == NO_ERROR ) {
1339	WriteErrorCode( stRC, "strftime");
1340	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1341	if ( pszSetTZ ) free( pszSetTZ );
1342	return ( 0 );
1343	}
1344
1345	// Return the formatted time string
1346	SaveResultString( prsResult, szTime, strlen(szTime) ); // 2016-02-20 SHL
1347
1348	if ( pszSetTZ ) free( pszSetTZ );
1349	return ( 0 );
1350	}
1351
1352
1353	/* ------------------------------------------------------------------------- *
1354	* Sys2GetEpochTime *
1355	* *
1356	* Convert formatted date and time into a number of seconds (UTC) from the *
1357	* epoch (defined as 1970-01-01 0:00:00). The input time is assumed to *
1358	* refer to the current timezone as defined in the TZ environment variable. *
1359	* *
1360	* If no parameters are specified, the current system time is used. If at *
1361	* least one parameter is specified, then any missing parameter is assumed *
1362	* to be its minimum possible value. *
1363	* *
1364	* Due to limitations in time_t, dates later than 2037 are not supported; *
1365	* the IBM library seems to convert them all to January 1 1970 00:00:00 UTC. *
1366	* *
1367	* REXX ARGUMENTS: *
1368	* 1. The year (0-99 or 1970+) (value <70 is assumed to be 20xx) *
1369	* 2. The month (1-12) *
1370	* 3. The day (1-31) *
1371	* 4. Hours (0-23) *
1372	* 5. Minutes (0-59) *
1373	* 6. Seconds (0-61) *
1374	* *
1375	* REXX RETURN VALUE: The number of seconds since the epoch, or 0 on error. *
1376	* ------------------------------------------------------------------------- */
1377	ULONG APIENTRY Sys2GetEpochTime( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1378	{
1379	ULONG ulYear = 1970, // Input year
1380	ulMonth = 1, // Input month
1381	ulDay = 1, // Input day
1382	ulHour = 0, // Input hours
1383	ulMin = 0, // Input minutes
1384	ulSec = 0; // Input seconds
1385	BOOL fYear = FALSE, // Year parameter specified?
1386	fMonth = FALSE, // Month parameter specified?
1387	fDay = FALSE, // Day parameter specified?
1388	fHour = FALSE, // Hours parameter specified?
1389	fMin = FALSE, // Minutes parameter specified?
1390	fSec = FALSE; // Seconds parameter specified?
1391	//SHORT sDST = 0; // Input time is DST?
1392	time_t timeval; // Calculated epoch time
1393	struct tm tsTime = {0}; // Time structure for mktime()
1394	UCHAR szEpochTime[ US_INTEGER_MAXZ ]; // Output string
1395	PSZ pszTZ,
1396	pszSetTZ;
1397
1398
1399	// Reset the error indicator
1400	WriteErrorCode( 0, NULL );
1401
1402	// Parse the various time items
1403	if ( argc >= 1 && RXVALIDSTRING(argv[0]) ) {
1404	if (( sscanf( argv[0].strptr, "%u", &ulYear )) != 1 ) return ( 40 );
1405	if ( ulYear < 100 ) {
1406	ulYear += (ulYear < 70) ? 2000 : 1900;
1407	}
1408	if ( ulYear < 1970 ) return ( 40 );
1409	fYear = TRUE;
1410	}
1411	if ( argc >= 2 && RXVALIDSTRING(argv[1]) ) {
1412	if (( sscanf( argv[1].strptr, "%u", &ulMonth )) != 1 ) return ( 40 );
1413	if ( ulMonth < 1 \|\| ulMonth > 12 ) return ( 40 );
1414	fMonth = TRUE;
1415	}
1416	if ( argc >= 3 && RXVALIDSTRING(argv[2]) ) {
1417	if (( sscanf( argv[2].strptr, "%u", &ulDay )) != 1 ) return ( 40 );
1418	if ( ulDay < 1 \|\| ulDay > 31 ) return ( 40 );
1419	fDay = TRUE;
1420	}
1421	if ( argc >= 4 && RXVALIDSTRING(argv[3]) ) {
1422	if (( sscanf( argv[3].strptr, "%u", &ulHour )) != 1 ) return ( 40 );
1423	if ( ulHour > 23 ) return ( 40 );
1424	fHour = TRUE;
1425	}
1426	if ( argc >= 5 && RXVALIDSTRING(argv[4]) ) {
1427	if (( sscanf( argv[4].strptr, "%u", &ulMin )) != 1 ) return ( 40 );
1428	if ( ulMin > 59 ) return ( 40 );
1429	fMin = TRUE;
1430	}
1431	if ( argc >= 6 && RXVALIDSTRING(argv[5]) ) {
1432	if (( sscanf( argv[5].strptr, "%u", &ulSec )) != 1 ) return ( 40 );
1433	if ( ulSec > 61 ) return ( 40 );
1434	fSec = TRUE;
1435	}
1436	if ( argc >= 7 ) return ( 40 );
1437	/*
1438	// Parse the conversion flag
1439	if ( argc >= 7 && RXVALIDSTRING(argv[6]) ) {
1440	strupr( argv[6].strptr );
1441	if ( strcspn(argv[6].strptr, "SD") > 0 ) return ( 40 );
1442	switch ( argv[6].strptr[0] ) {
1443	case 'S': sDST = 0; break;
1444	case 'D': sDST = 1; break;
1445	default : sDST = -1; break;
1446	}
1447	}
1448	*/
1449
1450	/* These next 4 lines really shouldn't be necessary, but without them
1451	* getenv() and (apparently) tzset() may see the value of TZ as NULL
1452	* if the environment variable was changed in the REXX script.
1453	*/
1454	DosScanEnv("TZ", &pszTZ );
1455	pszSetTZ = (PSZ) malloc( strlen(pszTZ) + 5 );
1456	sprintf( pszSetTZ, "TZ=%s", pszTZ );
1457	putenv( pszSetTZ );
1458
1459	// This seems to conflict with time() under some shells -AT
1460	tzset();
1461
1462	// Use the locale settings from the environment
1463	setlocale( LC_TIME, "");
1464
1465	if ( !fYear && !fMonth && !fDay && !fHour && !fMin && !fSec ) {
1466	timeval = time( NULL );
1467	if ( timeval == -1 ) {
1468	WriteErrorCode( timeval, "time");
1469	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1470	free( pszSetTZ );
1471	return 0;
1472	}
1473	}
1474	else {
1475	//printf("TZ=%s\n", getenv("TZ"));
1476	tsTime.tm_sec = ulSec;
1477	tsTime.tm_min = ulMin;
1478	tsTime.tm_hour = ulHour;
1479	tsTime.tm_mday = ulDay;
1480	tsTime.tm_mon = ulMonth - 1;
1481	tsTime.tm_year = ulYear - 1900;
1482	tsTime.tm_isdst = -1;
1483	timeval = mktime( &tsTime );
1484	if ( timeval == -1 ) {
1485	WriteErrorCode( timeval, "mktime");
1486	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1487	free( pszSetTZ );
1488	return 0;
1489	}
1490	}
1491
1492	// Return the calculated time value
1493	#if __IBMC__ >= 360 \|\| __IBMCPP__ >= 360
1494	sprintf( szEpochTime, "%.0f", timeval );
1495	#else
1496	sprintf( szEpochTime, "%d", timeval );
1497	#endif
1498	SaveResultString( prsResult, szEpochTime, strlen(szEpochTime) ); // 2016-02-20 SHL
1499
1500	free( pszSetTZ );
1501	return ( 0 );
1502	}
1503
1504
1505	/* ------------------------------------------------------------------------- *
1506	* Sys2LocateDLL *
1507	* *
1508	* Search for an installed or loaded DLL by module name. *
1509	* Code derived from 'whichdll' by Alessandro Cantatore (public domain). *
1510	* *
1511	* REXX ARGUMENTS: *
1512	* 1. The name of the DLL to search for. (REQUIRED) *
1513	* 2. Flag to limit search context, must be one of: *
1514	* ALL : Search for both loaded and loadable DLLs (DEFAULT) *
1515	* LOADEDONLY: Search only for currently-loaded DLLs *
1516	* Only the first letter (A/L) is significant. *
1517	* *
1518	* REXX RETURN VALUE: *
1519	* The fully-qualified path of the DLL, if found (or "" if not found). *
1520	* ------------------------------------------------------------------------- */
1521	ULONG APIENTRY Sys2LocateDLL( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1522	{
1523	HMODULE hmod;
1524	CHAR achModuleName[ CCHMAXPATH ];
1525	BOOL bLoadedOnly = FALSE,
1526	bUnload = FALSE;
1527	APIRET rc;
1528
1529	// Reset the error indicator
1530	WriteErrorCode( 0, NULL );
1531
1532	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) )) return ( 40 );
1533
1534	// Second argument: flag
1535	if ( argc >= 2 && RXVALIDSTRING(argv[1]) ) {
1536	strupr( argv[1].strptr );
1537	if ( strcspn(argv[1].strptr, "AL") > 0 ) return ( 40 );
1538	switch ( argv[1].strptr[0] ) {
1539	case 'A': bLoadedOnly = FALSE; break;
1540	case 'L': bLoadedOnly = TRUE; break;
1541	default : return ( 40 );
1542	}
1543	}
1544
1545	// See if the DLL is already loaded
1546	rc = DosQueryModuleHandle( argv[0].strptr, &hmod );
1547	if ( rc ) {
1548	// Guess not...
1549	if ( bLoadedOnly ) {
1550	// Just return
1551	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1552	return 0;
1553	}
1554	// Try to load it now
1555	rc = DosLoadModule( NULL, 0, argv[0].strptr, &hmod );
1556	if ( rc ) {
1557	WriteErrorCode( rc, "DosLoadModule");
1558	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1559	return 0;
1560	}
1561	bUnload = TRUE;
1562	}
1563
1564	// Get the full path name of the DLL
1565	rc = DosQueryModuleName( hmod, CCHMAXPATH, achModuleName );
1566	if ( rc ) {
1567	WriteErrorCode( rc, "DosQueryModuleName");
1568	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1569	if ( bUnload ) DosFreeModule( hmod );
1570	return 0;
1571	}
1572
1573	// Free the module if we loaded it ourselves
1574	if ( bUnload ) DosFreeModule( hmod );
1575
1576	// Return the full path name
1577	SaveResultString( prsResult, achModuleName, strlen(achModuleName) ); // 2016-02-20 SHL
1578
1579	return 0;
1580	}
1581
1582
1583	/* ------------------------------------------------------------------------- *
1584	* Sys2CreateNamedPipe *
1585	* *
1586	* Create a named pipe with the specified name and parameters. Only byte *
1587	* mode is supported; message mode is not. *
1588	* *
1589	* REXX ARGUMENTS: *
1590	* 1. The name of the pipe, in the form "\PIPE\something". (REQUIRED) *
1591	* 2. The size of the outbound buffer, in bytes. (REQUIRED) *
1592	* 3. The size of the inbound buffer, in bytes. (REQUIRED) *
1593	* 4. The pipe's timeout value, in milliseconds. (DEFAULT: 3000) *
1594	* 5. The number of simultaneous instances of this pipe which are allowed. *
1595	* Must be between 1 and 254, or 0 indicating no limit. (DEFAULT: 1) *
1596	* 6. Pipe blocking mode, one of: *
1597	* W = WAIT mode, read and write block waiting for data. (DEFAULT) *
1598	* N = NOWAIT mode, read and write return immediately. *
1599	* 7. Pipe mode, one of: *
1600	* I = Inbound pipe (DEFAULT) *
1601	* O = Outbound pipe *
1602	* D = Duplex (inbound/outbound) pipe *
1603	* 8. Privacy/inheritance flag, one of: *
1604	* 0 = The pipe handle is inherited by child processes. (DEFAULT) *
1605	* 1 = The pipe handle is private to the current process. *
1606	* 9. Write-through flag, one of: *
1607	* 0 = Allow delayed writes (write-behind) to remote pipes. (DEFAULT) *
1608	* 1 = Force immediate writes (write-through) to remote pipes. *
1609	* *
1610	* REXX RETURN VALUE: *
1611	* A four-byte pipe handle or 0 if create fails *
1612	* ------------------------------------------------------------------------- */
1613	ULONG APIENTRY Sys2CreateNamedPipe( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1614	{
1615	HPIPE hp;
1616	PSZ pszNPName;
1617	LONG iLimit;
1618	ULONG ulBufOut,
1619	ulBufIn,
1620	ulTimeout = 3000,
1621	flOpen = 0,
1622	flPipe = 1;
1623	CHAR achHandle[ 9 ];
1624	APIRET rc;
1625
1626	// Reset the error indicator
1627	WriteErrorCode( 0, NULL );
1628
1629	// Make sure we have at least three valid arguments (pipe name and sizes)
1630	if ( argc < 3 \|\| ( !RXVALIDSTRING(argv[0]) ) \|\|
1631	( !RXVALIDSTRING(argv[1]) ) \|\| ( !RXVALIDSTRING(argv[2]) ))
1632	return ( 40 );
1633
1634	// (Validate the first argument last to simplify error processing)
1635
1636	// Second argument: pipe outbound buffer size
1637	if (( sscanf( argv[1].strptr, "%u", &ulBufOut )) != 1 ) return ( 40 );
1638
1639	// Third argument: pipe outbound buffer size
1640	if (( sscanf( argv[2].strptr, "%u", &ulBufIn )) != 1 ) return ( 40 );
1641
1642	// Fourth argument: pipe timeout value
1643	if ( argc >= 4 && RXVALIDSTRING(argv[3]) ) {
1644	if (( sscanf( argv[3].strptr, "%u", &ulTimeout )) != 1 ) return ( 40 );
1645	}
1646
1647	// Fifth argument: instances limit
1648	if ( argc >= 5 && RXVALIDSTRING(argv[4]) ) {
1649	if (( sscanf( argv[4].strptr, "%d", &iLimit )) != 1 ) return ( 40 );
1650	if (( iLimit > 1 ) && ( iLimit < 255 ))
1651	flPipe = iLimit;
1652	else if ( !iLimit \|\| ( iLimit == -1 ))
1653	flPipe = NP_UNLIMITED_INSTANCES;
1654	else
1655	return ( 40 );
1656	}
1657
1658	// Sixth argument: blocking mode
1659	if ( argc >= 6 && RXVALIDSTRING(argv[5]) ) {
1660	strupr( argv[5].strptr );
1661	if ( argv[5].strptr[0] == 'N' )
1662	flPipe \|= NP_NOWAIT;
1663	else if ( argv[5].strptr[0] != 'W' )
1664	return ( 40 );
1665	}
1666
1667	// Seventh argument: pipe mode (direction)
1668	if ( argc >= 7 && RXVALIDSTRING(argv[6]) ) {
1669	strupr( argv[6].strptr );
1670	if (strcspn(argv[6].strptr, "IOD") > 0 ) return ( 40 );
1671	switch ( argv[6].strptr[0] ) {
1672	case 'O': flOpen \|= NP_ACCESS_OUTBOUND; break;
1673	case 'D': flOpen \|= NP_ACCESS_DUPLEX; break;
1674	default : break; // default is 0
1675	}
1676	}
1677
1678	// Eighth argument: inheritance mode
1679	if ( argc >= 8 && RXVALIDSTRING(argv[7]) ) {
1680	strupr( argv[7].strptr );
1681	if ( argv[7].strptr[0] == '1' )
1682	flOpen \|= NP_NOINHERIT;
1683	else if ( argv[7].strptr[0] != '0' )
1684	return ( 40 );
1685	}
1686
1687	// Ninth argument: write mode
1688	if ( argc >= 9 && RXVALIDSTRING(argv[8]) ) {
1689	strupr( argv[8].strptr );
1690	if ( argv[8].strptr[0] == '1' )
1691	flOpen \|= NP_NOWRITEBEHIND;
1692	else if ( argv[8].strptr[0] != '0' )
1693	return ( 40 );
1694	}
1695
1696	// Now the first argument: pipe name
1697	pszNPName = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
1698	if ( pszNPName == NULL ) {
1699	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
1700	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1701	return ( 0 );
1702	}
1703	strncpy( pszNPName, argv[0].strptr, RXSTRLEN(argv[0]) );
1704
1705	// All good, now create the pipe
1706	rc = DosCreateNPipe( pszNPName, &hp, flOpen, flPipe, ulBufOut, ulBufIn, ulTimeout );
1707	if (rc) {
1708	WriteErrorCode( rc, "DosCreateNPipe");
1709	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1710	return 0;
1711	}
1712
1713	// Return the handle as the REXX result string
1714	sprintf( achHandle, "%8X", hp );
1715	SaveResultString( prsResult, achHandle, strlen(achHandle) ); // 2016-02-20 SHL
1716
1717	free( pszNPName );
1718	return ( 0 );
1719	}
1720
1721
1722	/* ------------------------------------------------------------------------- *
1723	* Sys2ConnectNamedPipe *
1724	* *
1725	* Start 'listening' by allowing clients to connect to a previously-created *
1726	* named pipe. *
1727	* *
1728	* REXX ARGUMENTS: *
1729	* 1. The pipe handle, as returned by Sys2CreateNamedPipe. (REQUIRED) *
1730	* *
1731	* REXX RETURN VALUE: *
1732	* 1 on success, or 0 if an error occurred. *
1733	* ------------------------------------------------------------------------- */
1734	ULONG APIENTRY Sys2ConnectNamedPipe( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1735	{
1736	HPIPE hp;
1737	ULONG ulState = 0;
1738	APIRET rc;
1739
1740	// Reset the error indicator
1741	WriteErrorCode( 0, NULL );
1742
1743	// Parse the handle
1744	if ( !(argc == 1 && RXVALIDSTRING(argv[0])) ) return ( 40 );
1745	if (( sscanf( argv[0].strptr, "%8X", &hp )) != 1 ) return ( 40 );
1746
1747	// Determine the pipe mode
1748	DosQueryNPHState( hp, &ulState );
1749
1750	// Connect the pipe
1751	rc = DosConnectNPipe( hp );
1752
1753	// A non-blocking pipe returns ERROR_PIPE_NOT_CONNECTED on success
1754	if ((( ulState & NP_NOWAIT ) && ( rc != ERROR_PIPE_NOT_CONNECTED )) \|\|
1755	( rc != NO_ERROR ))
1756	{
1757	WriteErrorCode( rc, "DosConnectNPipe");
1758	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1759	return ( 0 );
1760	}
1761
1762	// Return 1 on success
1763	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
1764	return ( 0 );
1765	}
1766
1767
1768	/* ------------------------------------------------------------------------- *
1769	* Sys2DisconnectNamedPipe *
1770	* *
1771	* Unlocks a named pipe after a client has closed its connection. *
1772	* *
1773	* REXX ARGUMENTS: *
1774	* 1. The pipe handle, as returned by Sys2CreateNamedPipe. (REQUIRED) *
1775	* *
1776	* REXX RETURN VALUE: *
1777	* 1 on success, or 0 if an error occurred. *
1778	* ------------------------------------------------------------------------- */
1779	ULONG APIENTRY Sys2DisconnectNamedPipe( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1780	{
1781	HPIPE hp;
1782	APIRET rc;
1783
1784	// Reset the error indicator
1785	WriteErrorCode( 0, NULL );
1786
1787	// Parse the handle
1788	if ( !(argc == 1 && RXVALIDSTRING(argv[0])) ) return ( 40 );
1789	if (( sscanf( argv[0].strptr, "%8X", &hp )) != 1 ) return ( 40 );
1790
1791	// Connect the pipe
1792	rc = DosDisConnectNPipe( hp );
1793	if ( rc != NO_ERROR ) {
1794	WriteErrorCode( rc, "DosDisConnectNPipe");
1795	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
1796	return ( 0 );
1797	}
1798
1799	// Return 1 on success
1800	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
1801	return ( 0 );
1802	}
1803
1804
1805	/* ------------------------------------------------------------------------- *
1806	* Sys2CheckNamedPipe *
1807	* *
1808	* Check the status of a named pipe. *
1809	* *
1810	* REXX ARGUMENTS: *
1811	* 1. The pipe handle (from Sys2CreateNamedPipe or DosOpen). (REQUIRED) *
1812	* *
1813	* REXX RETURN VALUE: *
1814	* String of the format "bytes status", where bytes is the number of bytes *
1815	* currently waiting in the pipe, and status is one of: DISCONNECTED, *
1816	* LISTENING, CONNECTED, or CLOSING or "" if API error *
1817	* ------------------------------------------------------------------------- */
1818	ULONG APIENTRY Sys2CheckNamedPipe( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1819	{
1820	HPIPE hp;
1821	ULONG cbActual, ulState;
1822	AVAILDATA avd;
1823	CHAR szStatus[ US_PIPESTATUS_MAXZ ];
1824	APIRET rc;
1825
1826	// Reset the error indicator
1827	WriteErrorCode( 0, NULL );
1828
1829	// Parse the handle
1830	if ( !(argc == 1 && RXVALIDSTRING(argv[0])) ) return ( 40 );
1831	if (( sscanf( argv[0].strptr, "%8X", &hp )) != 1 ) return ( 40 );
1832
1833	rc = DosPeekNPipe( hp, NULL, 0, &cbActual, &avd, &ulState );
1834	if ( rc != NO_ERROR ) {
1835	WriteErrorCode( rc, "DosPeekNPipe");
1836	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
1837	return ( 0 );
1838	}
1839	sprintf( szStatus, "%u ", avd.cbpipe );
1840	switch ( ulState ) {
1841	case NP_STATE_DISCONNECTED: strncat( szStatus, "DISCONNECTED", US_PIPESTATUS_MAXZ-1 ); break;
1842	case NP_STATE_LISTENING: strncat( szStatus, "LISTENING", US_PIPESTATUS_MAXZ-1 ); break;
1843	case NP_STATE_CONNECTED: strncat( szStatus, "CONNECTED", US_PIPESTATUS_MAXZ-1 ); break;
1844	case NP_STATE_CLOSING: strncat( szStatus, "CLOSING", US_PIPESTATUS_MAXZ-1 ); break;
1845	default: strncat( szStatus, "UNKNOWN", US_PIPESTATUS_MAXZ-1 ); break;
1846	}
1847
1848	SaveResultString( prsResult, szStatus, strlen(szStatus) ); // 2016-02-20 SHL
1849
1850	return ( 0 );
1851	}
1852
1853
1854	/* ------------------------------------------------------------------------- *
1855	* Sys2Open *
1856	* *
1857	* Wrapper to DosOpenL: open a file or stream (with >2GB support). *
1858	* Direct-DASD mode is not supported by this function, nor is setting the *
1859	* initial extended attributes. *
1860	* *
1861	* REXX ARGUMENTS: *
1862	* 1. Name of file or stream to open. (REQUIRED) *
1863	* 2. Open action flags, must be either "O" (open if exists), "R" (replace *
1864	* if exists), or nothing (fail if exists), optionally followed by "C" *
1865	* (create if file does not exist). If "C" is not specified, the *
1866	* operation will fail if the file does not exist. Note that a value *
1867	* of "" alone will therefore fail automatically. (DEFAULT: "O") *
1868	* In summary, the possible combinations are: *
1869	* O = Open only (if file exists, open it; if not, fail) *
1870	* OC= Open/create (if file exists, open it; if not, create it) *
1871	* R = Replace only (if file exists, replace it; if not, fail) *
1872	* RC= Replace/create (if file exists, replace it; if not, create it) *
1873	* C = Create only (if file exists, fail; if not, create it) *
1874	* (empty) = No-op (if file exists, fail; if not, fail) *
1875	* 3. Access mode flags, one or both of: (DEFAULT: "RW") *
1876	* R = Open file with read access. *
1877	* W = Open file with write access. *
1878	* 4. Sharing mode flags, any combination of: (DEFAULT: "W") *
1879	* R = Deny read access to other processes *
1880	* W = Deny write access to other processes *
1881	* 5. Deny legacy DosOpen access, one of: *
1882	* 0 = Allow DosOpen to access the file (DEFAULT) *
1883	* 1 = Deny access using the DosOpen API *
1884	* 6. Privacy/inheritance flag, one of: *
1885	* 0 = The file handle is inherited by child processes. (DEFAULT) *
1886	* 1 = The file handle is private to the current process. *
1887	* 7. Initial file attributes when creating a file: (DEFAULT: "") *
1888	* A = Archive attribute set *
1889	* D = Directory attribute set *
1890	* S = System attribute set *
1891	* H = Hidden attribute set *
1892	* R = Read-only attribute set *
1893	* 8. Initial file size when creating or replacing a file; ignored if *
1894	* access mode is read-only. (DEFAULT: 0) *
1895	* 9. I/O mode flags, any or all of: (DEFAULT: "") *
1896	* T = Write-through mode (default is normal write) *
1897	* N = No-cache mode (default is to use filesystem cache) *
1898	* S = Sequential access *
1899	* R = Random access *
1900	* * S and R can combine as follows: *
1901	* Neither: No locality known (default) *
1902	* S only: Mainly sequential access *
1903	* R only: Mainly random access *
1904	* Both: Random/sequential (i.e. random with some locality) *
1905	* *
1906	* REXX RETURN VALUE: *
1907	* File handle, or "" in case of error. *
1908	* ------------------------------------------------------------------------- */
1909	ULONG APIENTRY Sys2Open( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
1910	{
1911	PSZ pszFile;
1912	HFILE hf;
1913	ULONG fsAction = 0,
1914	fsMode = 0,
1915	ulResult = 0,
1916	ulAttr = FILE_NORMAL;
1917	LONGLONG llSize = {0};
1918	CHAR achHandle[ 9 ];
1919	APIRET rc;
1920
1921
1922	// Reset the error indicator
1923	WriteErrorCode( 0, NULL );
1924
1925	// Make sure we have at least one valid argument (the file name)
1926	if ( argc < 1 \|\| ( !RXVALIDSTRING(argv[0]) ))
1927	return ( 40 );
1928
1929	// (Validate the first argument last to simplify error processing)
1930
1931	// Second argument: open action
1932	if ( argc >= 2 && RXVALIDSTRING(argv[1]) ) {
1933	strupr( argv[1].strptr );
1934	if ( strcspn(argv[1].strptr, "OCR") > 0 ) return ( 40 );
1935	if ( strchr(argv[1].strptr, 'O'))
1936	fsAction \|= OPEN_ACTION_OPEN_IF_EXISTS;
1937	else if ( strchr(argv[1].strptr, 'R'))
1938	fsAction \|= OPEN_ACTION_REPLACE_IF_EXISTS;
1939	if ( strchr(argv[1].strptr, 'C'))
1940	fsAction \|= OPEN_ACTION_CREATE_IF_NEW;
1941	}
1942	else
1943	fsAction = OPEN_ACTION_OPEN_IF_EXISTS;
1944
1945	// Third argument: access mode
1946	if ( argc >= 3 && RXVALIDSTRING(argv[2]) ) {
1947	strupr( argv[2].strptr );
1948	if ( strcspn(argv[2].strptr, "RW") > 0 ) return ( 40 );
1949	if ( strchr(argv[2].strptr, 'R')) {
1950	if (strchr(argv[2].strptr, 'W'))
1951	fsMode = OPEN_ACCESS_READWRITE;
1952	else
1953	fsMode = OPEN_ACCESS_READONLY;
1954	}
1955	else if (strchr(argv[2].strptr, 'W'))
1956	fsMode = OPEN_ACCESS_WRITEONLY;
1957	else
1958	return ( 40 );
1959	}
1960	else
1961	fsMode = OPEN_ACCESS_READWRITE;
1962
1963	// Fourth argument: sharing mode
1964	if ( argc >= 4 && RXVALIDSTRING(argv[3]) ) {
1965	strupr( argv[3].strptr );
1966	if ( strcspn(argv[3].strptr, "RW") > 0 ) return ( 40 );
1967	if ( strchr(argv[3].strptr, 'R')) {
1968	if (strchr(argv[3].strptr, 'W'))
1969	fsMode \|= OPEN_SHARE_DENYREADWRITE;
1970	else
1971	fsMode \|= OPEN_SHARE_DENYREAD;
1972	}
1973	else if (strchr(argv[3].strptr, 'W'))
1974	fsMode \|= OPEN_SHARE_DENYWRITE;
1975	else
1976	fsMode \|= OPEN_SHARE_DENYNONE;
1977	}
1978	else
1979	fsMode \|= OPEN_SHARE_DENYWRITE;
1980
1981	// Fifth argument: deny legacy mode
1982	if ( argc >= 5 && RXVALIDSTRING(argv[4]) ) {
1983	strupr( argv[4].strptr );
1984	if ( argv[4].strptr[0] == '1' )
1985	fsMode \|= OPEN_SHARE_DENYLEGACY;
1986	else if ( argv[4].strptr[0] != '0' )
1987	return ( 40 );
1988	}
1989
1990	// Sixth argument: inheritance mode
1991	if ( argc >= 6 && RXVALIDSTRING(argv[5]) ) {
1992	strupr( argv[5].strptr );
1993	if ( argv[5].strptr[0] == '1' )
1994	fsMode \|= OPEN_FLAGS_NOINHERIT;
1995	else if ( argv[5].strptr[0] != '0' )
1996	return ( 40 );
1997	}
1998
1999	// Seventh argument: attributes
2000	if ( argc >= 7 && RXVALIDSTRING(argv[6]) ) {
2001	strupr( argv[6].strptr );
2002	if (strcspn(argv[6].strptr, "ADSHR") > 0 ) return ( 40 );
2003	if ( strchr(argv[6].strptr, 'A')) ulAttr \|= FILE_ARCHIVED;
2004	if ( strchr(argv[6].strptr, 'D')) ulAttr \|= FILE_DIRECTORY;
2005	if ( strchr(argv[6].strptr, 'S')) ulAttr \|= FILE_SYSTEM;
2006	if ( strchr(argv[6].strptr, 'H')) ulAttr \|= FILE_HIDDEN;
2007	if ( strchr(argv[6].strptr, 'R')) ulAttr \|= FILE_READONLY;
2008	}
2009
2010	// Eighth argument: initial size
2011	if ( argc >= 8 && RXVALIDSTRING(argv[7]) ) {
2012	if (( sscanf( argv[7].strptr, "%lld", &llSize )) != 1 ) return ( 40 );
2013	}
2014
2015	// Ninth argument: I/O mode flags
2016	if ( argc >= 9 && RXVALIDSTRING(argv[8]) ) {
2017	strupr( argv[8].strptr );
2018	if (strcspn(argv[8].strptr, "TNSR") > 0 ) return ( 40 );
2019	if ( strchr(argv[8].strptr, 'T')) fsMode \|= OPEN_FLAGS_WRITE_THROUGH;
2020	if ( strchr(argv[8].strptr, 'N')) fsMode \|= OPEN_FLAGS_NO_CACHE;
2021	if ( strchr(argv[8].strptr, 'S')) fsMode \|= OPEN_FLAGS_SEQUENTIAL;
2022	if ( strchr(argv[8].strptr, 'R')) fsMode \|= OPEN_FLAGS_RANDOM;
2023	}
2024
2025	// Now the first argument: file name
2026	pszFile = (PSZ) calloc( RXSTRLEN(argv[0]) + 1, sizeof(UCHAR) );
2027	if ( pszFile == NULL ) {
2028	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "calloc");
2029	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
2030	return ( 0 );
2031	}
2032	strncpy( pszFile, argv[0].strptr, RXSTRLEN(argv[0]) );
2033
2034	// Try and open the file
2035	rc = DosOpenL( pszFile, &hf, &ulResult, llSize, ulAttr, fsAction, fsMode, NULL );
2036	if (rc) {
2037	WriteErrorCode( rc, "DosOpenL");
2038	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
2039	free( pszFile );
2040	return ( 0 );
2041	}
2042
2043	// Return the handle as the REXX result string
2044	sprintf( achHandle, "%8X", hf );
2045	SaveResultString( prsResult, achHandle, strlen(achHandle) ); // 2016-02-20 SHL
2046
2047	free( pszFile );
2048	return ( 0 );
2049	}
2050
2051
2052	/* ------------------------------------------------------------------------- *
2053	* Sys2Close *
2054	* *
2055	* Wrapper to DosClose: close a file/stream. *
2056	* *
2057	* REXX ARGUMENTS: *
2058	* 1. File handle (returned by Sys2Open) (REQUIRED) *
2059	* *
2060	* REXX RETURN VALUE: *
2061	* 1 on success, or 0 if an error occurred. *
2062	* ------------------------------------------------------------------------- */
2063	ULONG APIENTRY Sys2Close( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2064	{
2065	HFILE hf;
2066	APIRET rc;
2067
2068	// Reset the error indicator
2069	WriteErrorCode( 0, NULL );
2070
2071	// Make sure we have exactly one valid argument (the file handle)
2072	if ( argc != 1 \|\| ( !RXVALIDSTRING(argv[0]) ))
2073	return ( 40 );
2074	if (( sscanf( argv[0].strptr, "%8X", &hf )) != 1 ) return ( 40 );
2075
2076	// Close the file
2077	rc = DosClose( hf );
2078	if ( rc != NO_ERROR ) {
2079	WriteErrorCode( rc, "DosClose");
2080	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
2081	}
2082	else {
2083	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
2084	}
2085
2086	return ( 0 );
2087	}
2088
2089
2090	/* ------------------------------------------------------------------------- *
2091	* Sys2Seek *
2092	* *
2093	* Wrapper to DosSetFilePtrL: move the read/write pointer to the specified *
2094	* location in a stream. *
2095	* *
2096	* REXX ARGUMENTS: *
2097	* 1. File handle (returned by Sys2Open) (REQUIRED) *
2098	* 2. The signed distance in bytes to move (REQUIRED) *
2099	* 3. Move method, one of: *
2100	* B = Beginning of file *
2101	* C = Current position (DEFAULT) *
2102	* E = End of file *
2103	* *
2104	* REXX RETURN VALUE: *
2105	* The new file position, in bytes or "" if error *
2106	* ------------------------------------------------------------------------- */
2107	ULONG APIENTRY Sys2Seek( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2108	{
2109	HFILE hf;
2110	LONGLONG llPos,
2111	llActual;
2112	ULONG ulMethod = FILE_CURRENT;
2113	CHAR achActual[ US_LONGLONG_MAXZ ];
2114	APIRET rc;
2115
2116	// Reset the error indicator
2117	WriteErrorCode( 0, NULL );
2118
2119	// Make sure we have at least two valid arguments
2120	if ( argc < 2 \|\| ( !RXVALIDSTRING(argv[0]) ) \|\| ( !RXVALIDSTRING(argv[1]) ))
2121	return ( 40 );
2122
2123	// First argument: file handle
2124	if (( sscanf( argv[0].strptr, "%8X", &hf )) != 1 ) return ( 40 );
2125
2126	// Second argument: requested offset
2127	if (( sscanf( argv[1].strptr, "%lld", &llPos )) != 1 ) return ( 40 );
2128
2129	// Third argument: starting position
2130	if ( argc >= 3 && RXVALIDSTRING(argv[2]) ) {
2131	strupr( argv[2].strptr );
2132	if ( strcspn(argv[2].strptr, "BCE") > 0 ) return ( 40 );
2133	switch ( argv[2].strptr[0] ) {
2134	case 'B': ulMethod = FILE_BEGIN; break;
2135	case 'E': ulMethod = FILE_END; break;
2136	default : ulMethod = FILE_CURRENT; break;
2137	}
2138	}
2139
2140	rc = DosSetFilePtrL( hf, llPos, ulMethod, &llActual );
2141	if ( rc != NO_ERROR ) {
2142	WriteErrorCode( rc, "DosSetFilePtrL");
2143	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
2144	return ( 0 );
2145	}
2146
2147	// Return the new position as the REXX result string
2148	sprintf( achActual, "%lld", llActual );
2149	SaveResultString( prsResult, achActual, strlen(achActual) ); // 2016-02-20 SHL
2150
2151	return ( 0 );
2152	}
2153
2154
2155	/* ------------------------------------------------------------------------- *
2156	* Sys2Read *
2157	* *
2158	* Wrapper to DosRead: read bytes from a previously-opened stream. *
2159	* *
2160	* REXX ARGUMENTS: *
2161	* 1. File handle (returned by Sys2Open or Sys2CreateNamedPipe) (REQUIRED) *
2162	* 2. Number of bytes to read (REQUIRED) *
2163	* *
2164	* REXX RETURN VALUE: *
2165	* String containing the bytes read, or "" in case of error. *
2166	* ------------------------------------------------------------------------- */
2167	ULONG APIENTRY Sys2Read( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2168	{
2169	HFILE hf;
2170	ULONG cb,
2171	cbActual;
2172	PSZ pszData;
2173	APIRET rc;
2174
2175	// Reset the error indicator
2176	WriteErrorCode( 0, NULL );
2177
2178	// Make sure we have two valid arguments
2179	if ( argc != 2 \|\| ( !RXVALIDSTRING(argv[0]) ) \|\| ( !RXVALIDSTRING(argv[1]) ))
2180	return ( 40 );
2181
2182	// First argument: handle
2183	if (( sscanf( argv[0].strptr, "%8X", &hf )) != 1 ) return ( 40 );
2184
2185	// Second argument: number of bytes to read
2186	if (( sscanf( argv[1].strptr, "%u", &cb )) != 1 ) return ( 40 );
2187	if ( cb < 1 ) return ( 40 );
2188	pszData = (PSZ) malloc( cb );
2189
2190	rc = DosRead( hf, pszData, cb, &cbActual );
2191	if ( rc \|\| !cbActual ) {
2192	WriteErrorCode( rc, "DosRead");
2193	SaveResultString( prsResult, NULL, 0 ); // 2016-02-20 SHL
2194	goto cleanup;
2195	}
2196	SaveResultString( prsResult, pszData, cbActual ); // 2016-02-20 SHL
2197
2198	cleanup:
2199	free( pszData );
2200	return ( 0 );
2201	}
2202
2203
2204	/* ------------------------------------------------------------------------- *
2205	* Sys2Write *
2206	* *
2207	* Wrapper to DosWrite: write bytes to a previously-opened stream. *
2208	* *
2209	* REXX ARGUMENTS: *
2210	* 1. File handle (returned by Sys2Open or Sys2CreateNamedPipe) (REQUIRED) *
2211	* 2. Data to be written (REQUIRED) *
2212	* *
2213	* REXX RETURN VALUE: *
2214	* Number of bytes written. *
2215	* ------------------------------------------------------------------------- */
2216	ULONG APIENTRY Sys2Write( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2217	{
2218	HFILE hf;
2219	ULONG cbActual;
2220	CHAR szActual[ US_INTEGER_MAXZ ];
2221	APIRET rc;
2222
2223	// Reset the error indicator
2224	WriteErrorCode( 0, NULL );
2225
2226	// Make sure we have two valid arguments
2227	if ( argc != 2 \|\| ( !RXVALIDSTRING(argv[0]) ) \|\| ( !RXVALIDSTRING(argv[1]) ))
2228	return ( 40 );
2229
2230	// First argument: handle
2231	if (( sscanf( argv[0].strptr, "%8X", &hf )) != 1 ) return ( 40 );
2232
2233	// (Second argument can be left in standard RXSTRING form)
2234
2235	rc = DosWrite( hf, argv[1].strptr, argv[1].strlength, &cbActual );
2236	if ( rc != NO_ERROR ) {
2237	WriteErrorCode( rc, "DosWrite");
2238	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
2239	return ( 0 );
2240	}
2241
2242	sprintf( szActual, "%d", cbActual );
2243	SaveResultString( prsResult, szActual, strlen(szActual) ); // 2016-02-20 SHL
2244	return ( 0 );
2245	}
2246
2247
2248	/* ------------------------------------------------------------------------- *
2249	* Sys2SyncBuffer *
2250	* *
2251	* Wrapper to DosResetBuffer: for external files, write the buffer to disk; *
2252	* for pipes, block until the far end of the pipe has read the contents. *
2253	* *
2254	* REXX ARGUMENTS: *
2255	* 1. File handle (returned by Sys2Open) (REQUIRED) *
2256	* *
2257	* REXX RETURN VALUE: *
2258	* 1 on success, or 0 if an error occurred. *
2259	* ------------------------------------------------------------------------- */
2260	ULONG APIENTRY Sys2SyncBuffer( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2261	{
2262	HFILE hf;
2263	APIRET rc;
2264
2265	// Reset the error indicator
2266	WriteErrorCode( 0, NULL );
2267
2268	// Make sure we have exactly one valid argument (the file handle)
2269	if ( argc != 1 \|\| ( !RXVALIDSTRING(argv[0]) ))
2270	return ( 40 );
2271	if (( sscanf( argv[0].strptr, "%8X", &hf )) != 1 ) return ( 40 );
2272
2273	// Sync the buffer
2274	rc = DosResetBuffer( hf );
2275	if ( rc != NO_ERROR ) {
2276	WriteErrorCode( rc, "DosResetBuffer");
2277	SaveResultString( prsResult, PSZ_ZERO, 1 ); // 2016-02-20 SHL
2278	}
2279	else {
2280	SaveResultString( prsResult, PSZ_ONE, 1 ); // 2016-02-20 SHL
2281	}
2282
2283	return ( 0 );
2284	}
2285
2286
2287	/* ------------------------------------------------------------------------- *
2288	* Sys2QueryDriveInfo *
2289	* *
2290	* Get non-filesystem-dependent information about a logical drive (volume). *
2291	* *
2292	* REXX ARGUMENTS: *
2293	* 1. Drive/volume letter to query, trailing colon optional. (REQUIRED) *
2294	* *
2295	* REXX RETURN VALUE: *
2296	* On success, returns a string in the format *
2297	* <drive> <size> <type> <flag> *
2298	* where <drive> is the uppercase drive letter followed by a colon, *
2299	* <size> is the total size of the drive/volume in binary kilobytes,*
2300	* <type> is one of: *
2301	* FLOPPY_5L - 48 TPI low-density diskette drive *
2302	* FLOPPY_5H - 96 TPI high-density diskette drive *
2303	* FLOPPY_3L - 3.5-inch 720KB drive *
2304	* FLOPPY_3H - 3.5-inch high-density 1.44MB diskette drive *
2305	* FLOPPY_3X - 3.5-inch ext-density 2.88MB diskette drive *
2306	* FLOPPY_8L - 8-inch single-density diskette drive *
2307	* FLOPPY_8H - 8-inch double-density diskette drive *
2308	* OTHER - other (including CD drive with no media) *
2309	* HDD - hard disk drive (including PRM) *
2310	* TAPE - tape drive *
2311	* OPTICAL - read/write optical drive *
2312	* and <flag> is 1 for non-partitionable removable media (e.g. floppies) *
2313	* or 0 otherwise (including both fixed and PRM disks) *
2314	* ------------------------------------------------------------------------- */
2315	ULONG APIENTRY Sys2QueryDriveInfo( PSZ pszName, ULONG argc, RXSTRING argv[], PSZ pszQueue, PRXSTRING prsResult )
2316	{
2317	BIOSPARAMETERBLOCK data;
2318	CHAR szDiskInfo[ US_DISKINFO_MAXZ ];
2319	UCHAR achPP[ 2 ],
2320	chVol;
2321	ULONG cbPP,
2322	cbData,
2323	ulSectors,
2324	ulSize;
2325	BOOL bRemovable;
2326	APIRET rc;
2327
2328
2329	// Reset the error indicator
2330	WriteErrorCode( 0, NULL );
2331
2332	// Make sure we have exactly one valid argument (the drive letter)
2333	if ( argc != 1 \|\| ( !RXVALIDSTRING(argv[0]) ))
2334	return ( 40 );
2335	chVol = toupper( argv[0].strptr[0] );
2336	if (( chVol < 'A') \|\| ( chVol > 'Z'))
2337	return ( 40 );
2338
2339	cbPP = 2;
2340	achPP[ 0 ] = 0;
2341	achPP[ 1 ] = chVol - 65;
2342	cbData = sizeof( data );
2343	rc = DosDevIOCtl( (HFILE) -1, IOCTL_DISK, DSK_GETDEVICEPARAMS,
2344	(PVOID) achPP, 2, &cbPP, &data, cbData, &cbData );
2345	if ( rc != NO_ERROR ) {
2346	WriteErrorCode( rc, "DosDevIOCtl");
2347	SaveResultString( prsResult, NULL, 0 );
2348	return ( 0 );
2349	}
2350
2351	ulSectors = data.cSectors? data.cSectors: data.cLargeSectors;
2352	ulSize = (data.usBytesPerSector > 1024) ?
2353	(ULONG) (ulSectors * ( data.usBytesPerSector / 1024 )) :
2354	(ULONG) (ulSectors / ( 1024 / data.usBytesPerSector ));
2355	bRemovable = !( data.fsDeviceAttr & 1 );
2356
2357	sprintf( szDiskInfo, "%c: %u ", chVol, ulSize );
2358	switch( data.bDeviceType ) {
2359	case 0: // 48 TPI low-density diskette drive
2360	strncat( szDiskInfo, "FLOPPY_5L", US_DISKINFO_MAXZ-1 );
2361	break;
2362	case 1: // 96 TPI high-density diskette drive
2363	strncat( szDiskInfo, "FLOPPY_5H", US_DISKINFO_MAXZ-1 );
2364	break;
2365	case 2: // Small (3.5-inch) 720KB drive
2366	strncat( szDiskInfo, "FLOPPY_3L", US_DISKINFO_MAXZ-1 );
2367	break;
2368	case 3: // 8-inch single-density diskette drive
2369	strncat( szDiskInfo, "FLOPPY_8L", US_DISKINFO_MAXZ-1 );
2370	break;
2371	case 4: // 8-inch double-density diskette drive
2372	strncat( szDiskInfo, "FLOPPY_8H", US_DISKINFO_MAXZ-1 );
2373	break;
2374	case 5: // Fixed disk
2375	strncat( szDiskInfo, "HDD", US_DISKINFO_MAXZ-1 );
2376	break;
2377	case 6: // Tape drive
2378	strncat( szDiskInfo, "TAPE", US_DISKINFO_MAXZ-1 );
2379	break;
2380	case 7: // Other (includes 1.44MB 3.5-inch diskette drive)
2381	if ( ulSize == 1440 )
2382	strncat( szDiskInfo, "FLOPPY_3H", US_DISKINFO_MAXZ-1 );
2383	else
2384	strncat( szDiskInfo, "OTHER", US_DISKINFO_MAXZ-1 );
2385	break;
2386	case 8: // R/W optical disk
2387	strncat( szDiskInfo, "OPTICAL", US_DISKINFO_MAXZ-1 );
2388	break;
2389	case 9: // 3.5-inch 4.0MB diskette drive (2.88MB formatted)
2390	strncat( szDiskInfo, "FLOPPY_3X", US_DISKINFO_MAXZ-1 );
2391	break;
2392	default:
2393	strncat( szDiskInfo, "UNKNOWN", US_DISKINFO_MAXZ-1 );
2394	break;
2395	}
2396	strncat( szDiskInfo, ( bRemovable? " 1": " 0" ), US_DISKINFO_MAXZ-1 );
2397
2398	SaveResultString( prsResult, szDiskInfo, strlen(szDiskInfo) );
2399	return ( 0 );
2400	}
2401
2402
2403
2404	// -------------------------------------------------------------------------
2405	// INTERNAL FUNCTIONS
2406	// -------------------------------------------------------------------------
2407
2408
2409	/* ------------------------------------------------------------------------- *
2410	* GetProcess *
2411	* *
2412	* Gets information about the specified process (if found). If pszProgram *
2413	* is NULL, the search is done on the process ID in pulPID; otherwise, the *
2414	* search is done on the executable name in pszProgram (which may or may not *
2415	* include the extension). *
2416	* *
2417	* ARGUMENTS: *
2418	* PSZ pszProgram : The requested executable (process name). (I) *
2419	* PSZ pszFullName: The returned fully-qualified process name. (O) *
2420	* PULONG pulPID : The process ID. (IO) *
2421	* PULONG pulPPID : The returned process parent ID. (O) *
2422	* PULONG pulType : The returned process type. (O) *
2423	* PUSHORT pusPriority: The returned process priority. (O) *
2424	* PULONG pulCPU : The returned process CPU time. (O) *
2425	* *
2426	* RETURNS: ULONG *
2427	* 0 on success, or a non-zero API return code in the case of an error. *
2428	* ------------------------------------------------------------------------- */
2429	// 2016-02-20 SHL Rework to avoid traps
2430	ULONG GetProcess( PCSZ pszProgram,
2431	PSZ pszFullName,
2432	PULONG pulPID,
2433	PULONG pulPPID,
2434	PULONG pulType,
2435	PUSHORT pusPriority,
2436	PULONG pulCPU )
2437	{
2438	#ifdef USE_DQPS
2439	QSPTRREC *pBuf; // Data returned by DosQProcStatus()
2440	#else
2441	QSPTRREC *pBuf; // Data returned by DosQuerySysState() // 2015-04-23 SHL
2442	#endif
2443	QSPREC *pPrec; // Pointer to process information block
2444	QSTREC *pTrec; // Pointer to thread information block
2445	CHAR szName[ CCHMAXPATH ] = {0}, // Fully-qualified name of process
2446	szNoExt[ CCHMAXPATH ] = {0}; // Program name without extension
2447	PPIB ppib; // pointer to current process info block
2448	PSZ pszCurrent, // Program name of a queried process
2449	c; // Pointer to substring
2450	ULONG ulCPU; // Process CPU time
2451	USHORT usPriority, // Process priority class
2452	i; // index
2453	BOOL fMatch = FALSE; // The current process is a match?
2454	APIRET rc; // Return code
2455
2456	// Use current process when PID is 0 and program name is not specified
2457	if (( pszProgram == NULL ) && ( *pulPID == 0 )) {
2458	rc = DosGetInfoBlocks( NULL, &ppib );
2459	if ( rc != NO_ERROR ) {
2460	WriteErrorCode( rc, "DosGetInfoBlocks");
2461	return ( rc );
2462	}
2463	*pulPID = ppib->pib_ulpid;
2464	}
2465
2466	#ifdef USE_DQPS
2467	pBuf = (QSPTRREC *) malloc( UL_SSBUFSIZE );
2468	#else
2469	pBuf = (QSPTRREC *) malloc( UL_SSBUFSIZE ); // 2015-04-23 SHL
2470	#endif
2471
2472	if ( pBuf == NULL ) {
2473	WriteErrorCode( ERROR_NOT_ENOUGH_MEMORY, "malloc");
2474	return ( ERROR_NOT_ENOUGH_MEMORY );
2475	}
2476
2477	#ifdef USE_DQPS
2478	// Get running process information using DosQProcStatus()
2479	rc = DosQProcStatus( pBuf, UL_SSBUFSIZE );
2480	if ( rc != NO_ERROR ) {
2481	WriteErrorCode( rc, "DosQProcStatus");
2482	return ( rc );
2483	}
2484	pPrec = pBuf->pProcRec;
2485	#else
2486	// Get running process information using DosQuerySysState()
2487	rc = DosQuerySysState( QS_PROCESS, 0L, 0L, 0L, pBuf, UL_SSBUFSIZE );
2488	if ( rc != NO_ERROR ) {
2489	WriteErrorCode( rc, "DosQuerySysState");
2490	free( pBuf );
2491	return ( rc );
2492	}
2493	pPrec = (QSPREC )(((QSPTRREC)pBuf) -> pProcRec); // 2015-04-23 SHL
2494	#endif
2495
2496	*pulPPID = 0;
2497	*pulType = 0;
2498	*pusPriority = 0;
2499	*pulCPU = 0;
2500	if ( pszProgram != NULL ) *pulPID = 0;
2501	else if ( *pulPID == 0 ) return 0;
2502
2503	# if 1 // 2016-02-25 SHL FIXME debug bad pointer
2504	// 2016-02-26 SHL FIXME to be gone when sure can not occur
2505	if ( (ULONG)pPrec < 0x10000 ) {
2506	sprintf( szName, "rxutilex#%u pPrec 0x%x < 0x10000", __LINE__, (ULONG)pPrec );
2507	WriteErrorCode( ERROR_INVALID_ADDRESS, szName);
2508	free( pBuf );
2509	return ( 0 );
2510	}
2511	# endif
2512
2513	// Now look for the specified process
2514	// List ends with RecType not QS_PROCESS or pThrdRec NULL
2515	while ( pPrec->RecType == QS_PROCESS && pPrec->pThrdRec != NULL && !fMatch ) {
2516
2517	if ( pszProgram == NULL ) {
2518	// Match by pid
2519	if ( pPrec->pid == *pulPID ) {
2520	fMatch = TRUE;
2521	// Get the program name
2522	if (( rc = DosQueryModuleName( pPrec->hMte, CCHMAXPATH-1, szName )) != NO_ERROR )
2523	sprintf( pszFullName, "--");
2524	else
2525	strcpy( pszFullName, szName );
2526
2527	// Get the process priority
2528	if (( rc = DosGetPrty( PRTYS_PROCESS, &usPriority, pPrec->pid )) != NO_ERROR )
2529	usPriority = 0;
2530
2531	// Get the CPU time of the process by querying each of its threads
2532	ulCPU = 0;
2533	pTrec = pPrec->pThrdRec;
2534	for ( i = 0; i < pPrec->cTCB; i++ ) {
2535	ulCPU += ( pTrec->systime + pTrec->usertime );
2536	pTrec++;
2537	}
2538
2539	*pulPPID = pPrec->ppid;
2540	*pulType = pPrec->type;
2541	*pusPriority = usPriority;
2542	*pulCPU = ulCPU;
2543	}
2544	}
2545	else {
2546	// Get the program name (without the path)
2547	if (( rc = DosQueryModuleName( pPrec->hMte, CCHMAXPATH-1, szName )) != NO_ERROR )
2548	sprintf( pszCurrent, "--");
2549	else
2550	pszCurrent = strrchr( szName, '\\') + 1;
2551
2552	// Create a copy without the extension
2553	strcpy( szNoExt, pszCurrent );
2554	if ( ( c = strrchr( szNoExt, '.') ) != NULL )
2555	memset( c, 0, strlen(c) );
2556	if ( pszCurrent != NULL &&
2557	( stricmp(pszCurrent, pszProgram) == 0 \|\| stricmp(szNoExt, pszProgram) == 0 ) )
2558	{
2559	fMatch = TRUE;
2560
2561	// Get the process priority
2562	if (( rc = DosGetPrty( PRTYS_PROCESS, &usPriority, pPrec->pid )) != NO_ERROR )
2563	usPriority = 0;
2564
2565	// Get the CPU time of the process by querying each of its threads
2566	ulCPU = 0;
2567	pTrec = pPrec->pThrdRec;
2568	for ( i = 0; i < pPrec->cTCB; i++ ) {
2569	ulCPU += ( pTrec->systime + pTrec->usertime );
2570	pTrec++;
2571	}
2572
2573	*pulPID = pPrec->pid;
2574	*pulPPID = pPrec->ppid;
2575	*pulType = pPrec->type;
2576	*pusPriority = usPriority;
2577	*pulCPU = ulCPU;
2578	strcpy( pszFullName, szName );
2579	}
2580	}
2581	pPrec = (QSPREC *)(pPrec->pThrdRec + pPrec->cTCB);
2582
2583	# if 1 // 2016-02-25 SHL FIXME debug pointer - can this occur?
2584	// 2016-02-26 SHL FIXME to be gone when sure can not occur
2585	if ( (ULONG)pPrec < 0x10000 ) {
2586	sprintf( szName, "rxutilex#%u pPrec 0x%x < 0x10000", __LINE__, (ULONG)pPrec );
2587	WriteErrorCode( ERROR_INVALID_ADDRESS, szName);
2588	free( pBuf );
2589	return ( 0 );
2590	}
2591	# endif
2592
2593	} // while
2594	if ( !fMatch ) *pulPID = 0;
2595
2596	free( pBuf );
2597	return ( 0 );
2598	}
2599
2600
2601
2602
2603	#ifdef NO_SHARED_SOURCE
2604
2605	/****
2606	**** MOVED TO shfuncs.c
2607	****/
2608
2609	/* ------------------------------------------------------------------------- *
2610	* SaveResultString *
2611	* *
2612	* Writes new string contents to the specified RXSTRING, allocating any *
2613	* additional memory that may be required. *
2614	* *
2615	* ARGUMENTS: *
2616	* PRXSTRING prsResult: Pointer to an existing RXSTRING for writing. *
2617	* PCH pchBytes : The string contents to write to prsResult or NULL *
2618	* ULONG ulBytes : The number of bytes in pchBytes to write 0..N. *
2619	* *
2620	* RETURNS: BOOL *
2621	* TRUE if prsResult was successfully updated. FALSE otherwise. *
2622	* ------------------------------------------------------------------------- */
2623	BOOL SaveResultString( PRXSTRING prsResult, PCSZ pchBytes, ULONG ulBytes )
2624	{
2625	ULONG ulRC;
2626	PCH pchNew;
2627
2628	// 2016-02-20 SHL Rework for easier usage
2629	if (!pchBytes)
2630	ulBytes = 0; // Sync for caller
2631	if ( ulBytes > 256 ) {
2632	// REXX provides 256 bytes by default; allocate more if necessary
2633	ulRC = DosAllocMem( (PVOID) &pchNew, ulBytes, PAG_WRITE \| PAG_COMMIT );
2634	if ( ulRC != 0 ) {
2635	WriteErrorCode( ulRC, "DosAllocMem");
2636	prsResult->strlength = 0; // 2016-02-20 SHL Force result to empty string
2637	return ( FALSE );
2638	}
2639	// 2015-06-03 SHL dropped DosFreeMem(prsResult->strptr);
2640	// 2015-06-03 SHL Pointer not allocated by DosAllocMem
2641	prsResult->strptr = pchNew;
2642	}
2643	if (ulBytes)
2644	memcpy( prsResult->strptr, pchBytes, ulBytes );
2645	prsResult->strlength = ulBytes;
2646
2647	return ( TRUE );
2648	}
2649
2650
2651	/* ------------------------------------------------------------------------- *
2652	* WriteStemElement *
2653	* *
2654	* Creates a stem element (compound variable) in the calling REXX program *
2655	* using the REXX shared variable pool interface. *
2656	* *
2657	* ARGUMENTS: *
2658	* PSZ pszStem : The name of the stem (before the '.') *
2659	* ULONG ulIndex : The number of the stem element (after the '.') *
2660	* PSZ pszValue : The value to write to the compound variable. *
2661	* *
2662	* RETURNS: BOOL *
2663	* TRUE on success, FALSE on failure. *
2664	* ------------------------------------------------------------------------- */
2665	// 2016-02-20 SHL
2666	BOOL WriteStemElement( PCSZ pszStem, ULONG ulIndex, PCSZ pszValue )
2667	{
2668	SHVBLOCK shvVar; // REXX shared variable pool block
2669	ULONG ulRc,
2670	ulBytes;
2671	CHAR szCompoundName[ US_COMPOUND_MAXZ ];
2672
2673	sprintf( szCompoundName, "%s.%d", pszStem, ulIndex );
2674	if ( pszValue == NULL ) {
2675	pszValue = "";
2676	ulBytes = 0;
2677	} else {
2678	// 2015-06-03 SHL Was using DosAllocMem and leaking memory
2679	// REXX API does not free this kind of buffer
2680	ulBytes = strlen(pszValue);
2681	}
2682	MAKERXSTRING( shvVar.shvname, szCompoundName, strlen(szCompoundName) );
2683	shvVar.shvvalue.strptr = (PCH)pszValue;
2684	shvVar.shvvalue.strlength = ulBytes;
2685	shvVar.shvnamelen = RXSTRLEN( shvVar.shvname );
2686	shvVar.shvvaluelen = RXSTRLEN( shvVar.shvvalue );
2687	shvVar.shvcode = RXSHV_SYSET;
2688	shvVar.shvnext = NULL;
2689	ulRc = RexxVariablePool( &shvVar );
2690	if ( ulRc > 1 ) {
2691	WriteErrorCode( shvVar.shvret, "RexxVariablePool (SHVBLOCK.shvret)");
2692	return FALSE;
2693	}
2694	return TRUE;
2695
2696	}
2697
2698
2699	/* ------------------------------------------------------------------------- *
2700	* WriteErrorCode *
2701	* *
2702	* Writes an error code to a special variable in the calling REXX program *
2703	* using the REXX shared variable pool interface. This is used to return *
2704	* API error codes to the REXX program, since the REXX functions themselves *
2705	* normally return string values. *
2706	* *
2707	* ARGUMENTS: *
2708	* ULONG ulError : The error code returned by the failing API call. *
2709	* PSZ pszContext: A string describing the API call that failed. *
2710	* *
2711	* RETURNS: N/A *
2712	* ------------------------------------------------------------------------- */
2713	void WriteErrorCode( ULONG ulError, PCSZ pszContext )
2714	{
2715	SHVBLOCK shvVar; // REXX shared variable pool block
2716	ULONG ulRc;
2717	CHAR szErrorText[ US_ERRSTR_MAXZ ];
2718
2719	if ( pszContext == NULL )
2720	sprintf( szErrorText, "%u", ulError );
2721	else
2722	sprintf( szErrorText, "%u: %s", ulError, pszContext );
2723	MAKERXSTRING( shvVar.shvname, SZ_ERROR_NAME, strlen(SZ_ERROR_NAME) );
2724	MAKERXSTRING( shvVar.shvvalue, szErrorText, strlen(szErrorText) );
2725	shvVar.shvnamelen = RXSTRLEN( shvVar.shvname );
2726	shvVar.shvvaluelen = RXSTRLEN( shvVar.shvvalue );
2727	shvVar.shvcode = RXSHV_SYSET;
2728	shvVar.shvnext = NULL;
2729	shvVar.shvret = 0; // 2016-02-26 SHL
2730	ulRc = RexxVariablePool( &shvVar );
2731	// 2016-02-26 SHL Correct if
2732	if ( ulRc & ~RXSHV_NEWV )
2733	printf("* Unable to set %s: shvret = 0x%x, apiret = 0x%x\n", shvVar.shvname.strptr, (UCHAR)shvVar.shvret, ulRc ); // 2016-02-26 SHL Correct formatting
2734	}
2735
2736	#endif // NO_SHARED_SOURCE
2737

Note: See TracBrowser for help on using the repository browser.

Download in other formats: