Context Navigation

source: rxutilex/trunk/rxutilex.c@ 24

Last change on this file since 24 was 24, checked in by Alex Taylor, 10 years ago
Makefile improvements, some fixes to memory allocation in stem variable handling (from SHL)
File size: 105.3 KB

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

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

Download in other formats: