Context Navigation

Nwmain.c

Visit:

Last change on this file was 3181, checked in by bird, 18 years ago
perl 5.8.8
File size: 34.4 KB

Line
1
2	/*
3	* Copyright © 2001 Novell, Inc. All Rights Reserved.
4	*
5	* You may distribute under the terms of either the GNU General Public
6	* License or the Artistic License, as specified in the README file.
7	*
8	*/
9
10	/*
11	* FILENAME : NWMain.c
12	* DESCRIPTION : Main function, Commandline handlers and shutdown for NetWare implementation of Perl.
13	* Author : HYAK, SGP
14	* Date : January 2001.
15	*
16	*/
17
18
19
20	#ifdef NLM
21	#define N_PLAT_NLM
22	#endif
23
24	#undef BYTE
25	#define BYTE char
26
27
28	#include <nwadv.h>
29	#include <signal.h>
30	#include <nwdsdefs.h>
31
32	#include "perl.h"
33	#include "nwutil.h"
34	#include "stdio.h"
35	#include "clibstuf.h"
36
37	#ifdef MPK_ON
38	#include <mpktypes.h>
39	#include <mpkapis.h>
40	#endif //MPK_ON
41
42
43	// Thread group ID for this NLM. Set only by main when the NLM is initially loaded,
44	// so it should be okay for this to be global.
45	//
46	#ifdef MPK_ON
47	THREAD gThreadHandle;
48	#else
49	int gThreadGroupID = -1;
50	#endif //MPK_ON
51
52
53	// Global to kill all running scripts during NLM unload.
54	//
55	bool gKillAll = FALSE;
56
57
58	// Global structure needed by OS to register command parser.
59	// fnRegisterCommandLineHandler gets called only when the NLM is initially loaded,
60	// so it should be okay for this structure to be a global.
61	//
62	static struct commandParserStructure gCmdParser = {0,0,0};
63
64
65	// True if the command-line parsing procedure has been registered with the OS.
66	// Altered only during initial NLM loading or unloading so it should be okay as a global.
67	//
68	BOOL gCmdProcInit = FALSE;
69
70
71	// Array to hold the screen name for all new screens.
72	//
73	char sPerlScreenName[MAX_DN_BYTES * sizeof(char)] = {'\0'};
74
75
76	// Structure to pass data when spawning new threadgroups to run scripts.
77	//
78	typedef struct tagScriptData
79	{
80	char *m_commandLine;
81	BOOL m_fromConsole;
82	}ScriptData;
83
84
85	#define CS_CMD_NOT_FOUND -1 // Console command not found
86	#define CS_CMD_FOUND 0 // Console command found
87
88	/**
89	The stack size is make 256k from the earlier 64k since complex scripts (charnames.t and complex.t)
90	were failing with the lower stack size. In fact, we tested with 128k and it also failed
91	for the complexity of the script used. In case the complexity of a script is increased,
92	then this might warrant an increase in the stack size. But instead of simply giving a very large stack,
93	a trade off was required and we stopped at 256k!
94	**/
95	#define PERL_COMMAND_STACK_SIZE (256*1024L) // Stack size of thread that runs a perl script from command line
96
97	#define MAX_COMMAND_SIZE 512
98
99
100	#define kMaxValueLen 1024 // Size of the Environment variable value limited/truncated to 1024 characters.
101	#define kMaxVariableNameLen 256 // Size of the Environment variable name.
102
103
104	typedef void (*PFUSEACCURATECASEFORPATHS) (int);
105	typedef LONG (*PFGETFILESERVERMAJORVERSIONNUMBER) (void);
106	typedef void (*PFUCSTERMINATE) (); // For ucs terminate.
107	typedef void (*PFUNAUGMENTASTERISK)(BOOL); // For longfile support.
108	typedef int (PFFSETMODE) (FILE , char *);
109
110
111	// local function prototypes
112	//
113	void fnSigTermHandler(int sig);
114	void fnRegisterCommandLineHandler(void);
115	void fnLaunchPerl(void* context);
116	void fnSetUpEnvBlock(char*** penv);
117	void fnDestroyEnvBlock(char** env);
118	int fnFpSetMode(FILE* fp, int mode, int *err);
119
120	void fnGetPerlScreenName(char *sPerlScreenName);
121
122	void fnGetPerlScreenName(char *sPerlScreenName);
123	void fnSetupNamespace(void);
124	char *getcwd(char [], int);
125	void fnRunScript(ScriptData* psdata);
126	void nw_freeenviron();
127
128
129	/*============================================================================================
130
131	Function : main
132
133	Description : Called when the NLM is first loaded. Registers the command-line handler
134	and then terminates-stay-resident.
135
136	Parameters : argc (IN) - No of Input strings.
137	argv (IN) - Array of Input strings.
138
139	Returns : Nothing.
140
141	==============================================================================================*/
142
143	void main(int argc, char *argv[])
144	{
145	char sysCmdLine[MAX_COMMAND_SIZE] = {'\0'};
146	char cmdLineCopy[sizeof(PERL_COMMAND_NAME)+sizeof(sysCmdLine)+2] = {'\0'};
147
148	ScriptData* psdata = NULL;
149
150
151	// Keep this thread alive, since we use the thread group id of this thread to allocate memory on.
152	// When we unload the NLM, clib will tear the thread down.
153	//
154	#ifdef MPK_ON
155	gThreadHandle = kCurrentThread();
156	#else
157	gThreadGroupID = GetThreadGroupID ();
158	#endif //MPK_ON
159
160	signal (SIGTERM, fnSigTermHandler);
161	fnInitGpfGlobals(); // For importing the CLIB calls in place of the Watcom calls
162	fnInitializeThreadInfo();
163
164
165	// Ensure that we have a "temp" directory
166	fnSetupNamespace();
167	if (access(NWDEFPERLTEMP, 0) != 0)
168	mkdir(NWDEFPERLTEMP);
169
170	// Create the file NUL if not present. This is done only once per NLM load.
171	// This is required for -e.
172	// Earlier verions were creating temporary files (in perl.c file) for -e.
173	// Now, the technique of creating temporary files are removed since they were
174	// fragile or insecure or slow. It now uses the memory by setting
175	// the BIT_BUCKET to "nul" on Win32, which is equivalent to /dev/nul of Unix.
176	// Since there is no equivalent of /dev/nul on NetWare, the work-around is that
177	// we create a file called "nul" and the BIT_BUCKET is set to "nul".
178	// This makes sure that -e works on NetWare too without the creation of temporary files
179	// in -e code in perl.c
180	{
181	char sNUL[MAX_DN_BYTES] = {'\0'};
182
183	strcpy(sNUL, NWDEFPERLROOT);
184	strcat(sNUL, "\\nwnul");
185	if (access((const char *)sNUL, 0) != 0)
186	{
187	// The file, "nul" is not found and so create the file.
188	FILE *fp = NULL;
189
190	fp = fopen((const char )sNUL, (const char )"w");
191	fclose(fp);
192	}
193	}
194
195	fnRegisterCommandLineHandler(); // Register the command line handler
196	SynchronizeStart(); // Restart the NLM startup process when using synchronization mode.
197
198	fnGetPerlScreenName(sPerlScreenName); // Get the screen name. Done only once per NLM load.
199
200
201	// If the command line has two strings, then the first has to be "Perl" and the second is assumed
202	// to be a script to be run. If only one string (i.e., Perl) is input, then there is nothing to do!
203	//
204	if ((argc > 1) && getcmd(sysCmdLine))
205	{
206	strcpy(cmdLineCopy, PERL_COMMAND_NAME);
207	strcat(cmdLineCopy, (char *)" "); // Space between the Perl Command and the input script name.
208	strcat(cmdLineCopy, sysCmdLine); // The command line parameters built into
209
210	// Create a safe copy of the command line and pass it to the
211	// new thread for parsing. The new thread will be responsible
212	// to delete it when it is finished with it.
213	//
214	psdata = (ScriptData *) malloc(sizeof(ScriptData));
215	if (psdata)
216	{
217	psdata->m_commandLine = NULL;
218	psdata->m_commandLine = (char ) malloc(MAX_DN_BYTES sizeof(char));
219	if(psdata->m_commandLine)
220	{
221	strcpy(psdata->m_commandLine, cmdLineCopy);
222	psdata->m_fromConsole = TRUE;
223
224	#ifdef MPK_ON
225	// kStartThread((char )"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void )psdata);
226	// Establish a new thread within a new thread group.
227	BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
228	#else
229	// Start a new thread in its own thread group
230	BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
231	#endif //MPK_ON
232	}
233	else
234	{
235	free(psdata);
236	psdata = NULL;
237	return;
238	}
239	}
240	else
241	return;
242	}
243
244
245	// Keep this thread alive, since we use the thread group id of this thread to allocate memory on.
246	// When we unload the NLM, clib will tear the thread down.
247	//
248	#ifdef MPK_ON
249	kSuspendThread(gThreadHandle);
250	#else
251	SuspendThread(GetThreadID());
252	#endif //MPK_ON
253
254
255	return;
256	}
257
258
259
260	/*============================================================================================
261
262	Function : fnSigTermHandler
263
264	Description : Called when the NLM is unloaded; used to unregister the console command handler.
265
266	Parameters : sig (IN)
267
268	Returns : Nothing.
269
270	==============================================================================================*/
271
272	void fnSigTermHandler(int sig)
273	{
274	int k = 0;
275
276
277	#ifdef MPK_ON
278	kResumeThread(gThreadHandle);
279	#endif //MPK_ON
280
281	// Unregister the command line handler.
282	//
283	if (gCmdProcInit)
284	{
285	UnRegisterConsoleCommand (&gCmdParser);
286	gCmdProcInit = FALSE;
287	}
288
289	// Free the global environ buffer
290	nw_freeenviron();
291
292	// Kill running scripts.
293	//
294	if (!fnTerminateThreadInfo())
295	{
296	ConsolePrintf("Terminating Perl scripts...\n");
297	gKillAll = TRUE;
298
299	// fnTerminateThreadInfo will be run for 5 threads. If more threads/scripts are run,
300	// then the NLM will unload without terminating the thread info and leaks more memory.
301	// If this number is increased to reduce memory leaks, then it will unnecessarily take more time
302	// to unload when there are a smaller no of threads. Since this is a rare case, the no is kept as 5.
303	//
304	while (!fnTerminateThreadInfo() && k < 5)
305	{
306	nw_sleep(1);
307	k++;
308	}
309	}
310
311	// Delete the file, "nul" if present since the NLM is unloaded.
312	{
313	char sNUL[MAX_DN_BYTES] = {'\0'};
314
315	strcpy(sNUL, NWDEFPERLROOT);
316	strcat(sNUL, "\\nwnul");
317	if (access((const char *)sNUL, 0) == 0)
318	{
319	// The file, "nul" is found and so delete it.
320	unlink((const char *)sNUL);
321	}
322	}
323	}
324
325
326
327	/*============================================================================================
328
329	Function : fnCommandLineHandler
330
331	Description : Gets called by OS when someone enters an unknown command at the system console,
332	after this routine is registered by RegisterConsoleCommand.
333	For the valid command we just spawn a thread with enough stack space
334	to actually run the script.
335
336	Parameters : screenID (IN) - id for the screen.
337	cmdLine (IN) - Command line string.
338
339	Returns : Long.
340
341	==============================================================================================*/
342
343	LONG fnCommandLineHandler (LONG screenID, BYTE * cmdLine)
344	{
345	ScriptData* psdata=NULL;
346	int OsThrdGrpID = -1;
347	LONG retCode = CS_CMD_FOUND;
348	char* cptr = NULL;
349
350
351	#ifdef MPK_ON
352	// Initialisation for MPK_ON
353	#else
354	OsThrdGrpID = -1;
355	#endif //MPK_ON
356
357
358	#ifdef MPK_ON
359	// For MPK_ON
360	#else
361	if (gThreadGroupID != -1)
362	OsThrdGrpID = SetThreadGroupID (gThreadGroupID);
363	#endif //MPK_ON
364
365
366	cptr = fnSkipWhite(cmdLine); // Skip white spaces.
367	if ((strnicmp(cptr, PERL_COMMAND_NAME, strlen(PERL_COMMAND_NAME)) == 0) &&
368	((cptr[strlen(PERL_COMMAND_NAME)] == ' ') \|\|
369	(cptr[strlen(PERL_COMMAND_NAME)] == '\t') \|\|
370	(cptr[strlen(PERL_COMMAND_NAME)] == '\0')))
371	{
372	// Create a safe copy of the command line and pass it to the new thread for parsing.
373	// The new thread will be responsible to delete it when it is finished with it.
374	//
375	psdata = (ScriptData *) malloc(sizeof(ScriptData));
376	if (psdata)
377	{
378	psdata->m_commandLine = NULL;
379	psdata->m_commandLine = (char ) malloc(MAX_DN_BYTES sizeof(char));
380	if(psdata->m_commandLine)
381	{
382	strcpy(psdata->m_commandLine, (char *)cmdLine);
383	psdata->m_fromConsole = TRUE;
384
385	#ifdef MPK_ON
386	// kStartThread((char )"ConsoleHandlerThread", fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void )psdata);
387	// Establish a new thread within a new thread group.
388	BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
389	#else
390	// Start a new thread in its own thread group
391	BeginThreadGroup(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
392	#endif //MPK_ON
393	}
394	else
395	{
396	free(psdata);
397	psdata = NULL;
398	retCode = CS_CMD_NOT_FOUND;
399	}
400	}
401	else
402	retCode = CS_CMD_NOT_FOUND;
403	}
404	else
405	retCode = CS_CMD_NOT_FOUND;
406
407
408	#ifdef MPK_ON
409	// For MPK_ON
410	#else
411	if (OsThrdGrpID != -1)
412	SetThreadGroupID (OsThrdGrpID);
413	#endif //MPK_ON
414
415
416	return retCode;
417	}
418
419
420
421	/*============================================================================================
422
423	Function : fnRegisterCommandLineHandler
424
425	Description : Registers the console command-line parsing function with the OS.
426
427	Parameters : None.
428
429	Returns : Nothing.
430
431	==============================================================================================*/
432
433	void fnRegisterCommandLineHandler(void)
434	{
435	// Allocates resource tag for Console Command
436	if ((gCmdParser.RTag =
437	AllocateResourceTag (GetNLMHandle(), (char *)"Console Command", ConsoleCommandSignature)) != 0)
438	{
439	gCmdParser.parseRoutine = fnCommandLineHandler; // Set the Console Command parsing routine.
440	RegisterConsoleCommand (&gCmdParser); // Registers the Console Command parsing function
441	gCmdProcInit = TRUE;
442	}
443
444	return;
445	}
446
447
448
449	/*============================================================================================
450
451	Function : fnSetupNamespace
452
453	Description : Sets the name space of the current threadgroup to the long name space.
454
455	Parameters : None.
456
457	Returns : Nothing.
458
459	==============================================================================================*/
460
461	void fnSetupNamespace(void)
462	{
463	SetCurrentNameSpace(NWOS2_NAME_SPACE);
464
465
466	//LATER: call SetTargetNameSpace(NWOS2_NAME_SPACE)? Currently, if
467	// I make this call, then CPerlExe::Rename fails in certain cases,
468	// and it isn't clear why. Looks like a CLIB bug...
469	// SetTargetNameSpace(NWOS2_NAME_SPACE);
470
471	//Uncommented that above call, retaining the comment so that it will be easy
472	//to revert back if there is any problem - sgp - 10th May 2000
473
474	//Commented again, since Perl debugger had some problems because of
475	//the above call - sgp - 20th June 2000
476
477	{
478	// if running on Moab, call UseAccurateCaseForPaths. This API
479	// does bad things on 4.11 so we call only for Moab.
480	PFGETFILESERVERMAJORVERSIONNUMBER pf_getfileservermajorversionnumber = NULL;
481	pf_getfileservermajorversionnumber = (PFGETFILESERVERMAJORVERSIONNUMBER)
482	ImportSymbol(GetNLMHandle(), (char *)"GetFileServerMajorVersionNumber");
483	if (pf_getfileservermajorversionnumber && ((*pf_getfileservermajorversionnumber)() > 4))
484	{
485	PFUSEACCURATECASEFORPATHS pf_useaccuratecaseforpaths = NULL;
486	pf_useaccuratecaseforpaths = (PFUSEACCURATECASEFORPATHS)
487	ImportSymbol(GetNLMHandle(), (char *)"UseAccurateCaseForPaths");
488	if (pf_useaccuratecaseforpaths)
489	(*pf_useaccuratecaseforpaths)(TRUE);
490	{
491	PFUNAUGMENTASTERISK pf_unaugmentasterisk = NULL;
492	pf_unaugmentasterisk = (PFUNAUGMENTASTERISK)
493	ImportSymbol(GetNLMHandle(), (char *)"UnAugmentAsterisk");
494	if (pf_unaugmentasterisk)
495	(*pf_unaugmentasterisk)(TRUE);
496	}
497	}
498	}
499
500	return;
501	}
502
503
504
505	/*============================================================================================
506
507	Function : fnLaunchPerl
508
509	Description : Parse the command line into argc/argv style parameters and then run the script.
510
511	Parameters : context (IN) - void* that will be typecasted to ScriptDate structure.
512
513	Returns : Nothing.
514
515	==============================================================================================*/
516
517	void fnLaunchPerl(void* context)
518	{
519	char* defaultDir = NULL;
520	char curdir[_MAX_PATH] = {'\0'};
521	ScriptData* psdata = (ScriptData *) context;
522
523	unsigned int moduleHandle = 0;
524	int currentThreadGroupID = -1;
525
526	#ifdef MPK_ON
527	kExitNetWare();
528	#endif //MPK_ON
529
530	errno = 0;
531
532	if (psdata->m_fromConsole)
533	{
534	// get the default working directory name
535	//
536	defaultDir = fnNwGetEnvironmentStr("PERL_ROOT", NWDEFPERLROOT);
537	}
538	else
539	defaultDir = getcwd(curdir, sizeof(curdir)-1);
540
541	// set long name space
542	//
543	fnSetupNamespace();
544
545	// make the working directory the current directory if from console
546	//
547	if (psdata->m_fromConsole)
548	chdir(defaultDir);
549
550	// run the script
551	//
552	fnRunScript(psdata);
553
554	// May have to check this, I am blindly calling UCSTerminate, irrespective of
555	// whether it is initialized or not
556	// Copied from the previous Perl - sgp - 31st Oct 2000
557	moduleHandle = FindNLMHandle("UCSCORE.NLM");
558	if (moduleHandle)
559	{
560	PFUCSTERMINATE ucsterminate = (PFUCSTERMINATE)ImportSymbol(moduleHandle, "therealUCSTerminate");
561	if (ucsterminate!=NULL)
562	(*ucsterminate)();
563	}
564
565	if (psdata->m_fromConsole)
566	{
567	// change thread groups for the call to free the memory
568	// allocated before the new thread group was started
569	#ifdef MPK_ON
570	// For MPK_ON
571	#else
572	if (gThreadGroupID != -1)
573	currentThreadGroupID = SetThreadGroupID (gThreadGroupID);
574	#endif //MPK_ON
575	}
576
577	// Free memory
578	if (psdata)
579	{
580	if(psdata->m_commandLine)
581	{
582	free(psdata->m_commandLine);
583	psdata->m_commandLine = NULL;
584	}
585
586	free(psdata);
587	psdata = NULL;
588	context = NULL;
589	}
590
591	#ifdef MPK_ON
592	// For MPK_ON
593	#else
594	if (currentThreadGroupID != -1)
595	SetThreadGroupID (currentThreadGroupID);
596	#endif //MPK_ON
597
598	#ifdef MPK_ON
599	// kExitThread(NULL);
600	#else
601	// just let the thread terminate by falling off the end of the
602	// function started by BeginThreadGroup
603	// ExitThread(EXIT_THREAD, 0);
604	#endif
605
606	return;
607	}
608
609
610
611	/*============================================================================================
612
613	Function : fnRunScript
614
615	Description : Parses and runs a perl script.
616
617	Parameters : psdata (IN) - ScriptData structure.
618
619	Returns : Nothing.
620
621	==============================================================================================*/
622
623	void fnRunScript(ScriptData* psdata)
624	{
625	char **av=NULL;
626	char **en=NULL;
627	int exitstatus = 1;
628	int i=0, j=0;
629	int *dummy = 0;
630
631	PCOMMANDLINEPARSER pclp = NULL;
632
633	// Set up the environment block. This will only work on
634	// on Moab; on 4.11 the environment block will be empty.
635	char** env = NULL;
636
637	BOOL use_system_console = TRUE;
638	BOOL newscreen = FALSE;
639	int newscreenhandle = 0;
640
641	// redirect stdin or stdout and run the script
642	FILE* redirOut = NULL;
643	FILE* redirIn = NULL;
644	FILE* redirErr = NULL;
645	FILE* stderr_fp = NULL;
646
647	int stdin_fd=-1, stdin_fd_dup=-1;
648	int stdout_fd=-1, stdout_fd_dup=-1;
649	int stderr_fd=-1, stderr_fd_dup=-1;
650
651
652	// Main callback instance
653	//
654	if (fnRegisterWithThreadTable() == FALSE)
655	return;
656
657	// parse the command line into argc/argv style:
658	// number of params and char array of params
659	//
660	pclp = (PCOMMANDLINEPARSER) malloc(sizeof(COMMANDLINEPARSER));
661	if (!pclp)
662	{
663	fnUnregisterWithThreadTable();
664	return;
665	}
666
667	// Initialise the variables
668	pclp->m_isValid = TRUE;
669	pclp->m_redirInName = NULL;
670	pclp->m_redirOutName = NULL;
671	pclp->m_redirErrName = NULL;
672	pclp->m_redirBothName = NULL;
673	pclp->nextarg = NULL;
674	pclp->sSkippedToken = NULL;
675	pclp->m_argv = NULL;
676	pclp->new_argv = NULL;
677
678	#ifdef MPK_ON
679	pclp->m_qSemaphore = NULL;
680	#else
681	pclp->m_qSemaphore = 0L;
682	#endif //MPK_ON
683
684	pclp->m_noScreen = 0;
685	pclp->m_AutoDestroy = 0;
686	pclp->m_argc = 0;
687	pclp->m_argv_len = 1;
688
689	// Allocate memory
690	pclp->m_argv = (char *) malloc(pclp->m_argv_len sizeof(char *));
691	if (pclp->m_argv == NULL)
692	{
693	free(pclp);
694	pclp = NULL;
695
696	fnUnregisterWithThreadTable();
697	return;
698	}
699
700	pclp->m_argv[0] = (char ) malloc(MAX_DN_BYTES sizeof(char));
701	if (pclp->m_argv[0] == NULL)
702	{
703	free(pclp->m_argv);
704	pclp->m_argv=NULL;
705
706	free(pclp);
707	pclp = NULL;
708
709	fnUnregisterWithThreadTable();
710	return;
711	}
712
713	// Parse the command line
714	fnCommandLineParser(pclp, (char *)psdata->m_commandLine, FALSE);
715	if (!pclp->m_isValid)
716	{
717	if(pclp->m_argv)
718	{
719	for(i=0; i<pclp->m_argv_len; i++)
720	{
721	if(pclp->m_argv[i] != NULL)
722	{
723	free(pclp->m_argv[i]);
724	pclp->m_argv[i] = NULL;
725	}
726	}
727
728	free(pclp->m_argv);
729	pclp->m_argv = NULL;
730	}
731
732	if(pclp->nextarg)
733	{
734	free(pclp->nextarg);
735	pclp->nextarg = NULL;
736	}
737	if(pclp->sSkippedToken != NULL)
738	{
739	free(pclp->sSkippedToken);
740	pclp->sSkippedToken = NULL;
741	}
742
743	if(pclp->m_redirInName)
744	{
745	free(pclp->m_redirInName);
746	pclp->m_redirInName = NULL;
747	}
748	if(pclp->m_redirOutName)
749	{
750	free(pclp->m_redirOutName);
751	pclp->m_redirOutName = NULL;
752	}
753	if(pclp->m_redirErrName)
754	{
755	free(pclp->m_redirErrName);
756	pclp->m_redirErrName = NULL;
757	}
758	if(pclp->m_redirBothName)
759	{
760	free(pclp->m_redirBothName);
761	pclp->m_redirBothName = NULL;
762	}
763
764	// Signal a semaphore, if indicated by "-{" option, to indicate that
765	// the script has terminated and files are closed
766	//
767	if (pclp->m_qSemaphore != 0)
768	{
769	#ifdef MPK_ON
770	kSemaphoreSignal(pclp->m_qSemaphore);
771	#else
772	SignalLocalSemaphore(pclp->m_qSemaphore);
773	#endif //MPK_ON
774	}
775
776	free(pclp);
777	pclp = NULL;
778
779	fnUnregisterWithThreadTable();
780	return;
781	}
782
783	// Simulating a shell on NetWare can be difficult. If you don't
784	// create a new screen for the script to run in, you can output to
785	// the console but you can't get any input from the console. Therefore,
786	// every invocation of perl potentially needs its own screen unless
787	// you are running either "perl -h" or "perl -v" or you are redirecting
788	// stdin from a file.
789	//
790	// So we need to create a new screen and set that screen as the current
791	// screen when running any script launched from the console that is not
792	// "perl -h" or "perl -v" and is not redirecting stdin from a file.
793	//
794	// But it would be a little weird if we didn't create a new screen only
795	// in the case when redirecting stdin from a file; in only that case,
796	// stdout would be the console instead of a new screen.
797	//
798	// There is also the issue of standard err. In short, we might as well
799	// create a new screen no matter what is going on with redirection, just
800	// for the sake of consistency.
801	//
802	// In summary, we should a create a new screen and make that screen the
803	// current screen unless one of the following is true:
804	// * The command is "perl -h"
805	// * The command is "perl -v"
806	// * The script was launched by another perl script. In this case,
807	// the screen belonging to the parent perl script should probably be
808	// the same screen for this process. And it will be if use BeginThread
809	// instead of BeginThreadGroup when launching Perl from within a Perl
810	// script.
811	//
812	// In those cases where we create a new screen we should probably also display
813	// that screen.
814	//
815
816	use_system_console = pclp->m_noScreen \|\|
817	((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-h") == 0)) \|\|
818	((pclp->m_argc == 2) && (strcmp(pclp->m_argv[1], (char *)"-v") == 0));
819
820	newscreen = (!use_system_console) && psdata->m_fromConsole;
821
822	if (newscreen)
823	{
824	newscreenhandle = CreateScreen(sPerlScreenName, 0);
825	if (newscreenhandle)
826	DisplayScreen(newscreenhandle);
827	}
828	else if (use_system_console)
829	CreateScreen((char *)"System Console", 0);
830
831	if (pclp->m_redirInName)
832	{
833	if ((stdin_fd = fileno(stdin)) != -1)
834	{
835	stdin_fd_dup = dup(stdin_fd);
836	if (stdin_fd_dup != -1)
837	{
838	redirIn = fdopen (stdin_fd_dup, (char const *)"r");
839	if (redirIn)
840	stdin = freopen (pclp->m_redirInName, (char const *)"r", redirIn);
841	if (!stdin)
842	{
843	redirIn = NULL;
844	// undo the redirect, if possible
845	stdin = fdopen(stdin_fd, (char const *)"r");
846	}
847	}
848	}
849	}
850
851	/**
852	The below code stores the handle for the existing stdout to be used later and the existing stdout is closed.
853	stdout is then initialised to the new File pointer where the operations are done onto that.
854	Later (look below for the code), the saved stdout is restored back.
855	**/
856	if (pclp->m_redirOutName)
857	{
858	if ((stdout_fd = fileno(stdout)) != -1) // Handle of the existing stdout.
859	{
860	stdout_fd_dup = dup(stdout_fd);
861	if (stdout_fd_dup != -1)
862	{
863	// Close the existing stdout.
864	fflush(stdout); // Write any unwritten data to the file.
865
866	// New stdout
867	redirOut = fdopen (stdout_fd_dup, (char const *)"w");
868	if (redirOut)
869	stdout = freopen (pclp->m_redirOutName, (char const *)"w", redirOut);
870	if (!stdout)
871	{
872	redirOut = NULL;
873	// Undo the redirection.
874	stdout = fdopen(stdout_fd, (char const *)"w");
875	}
876	setbuf(stdout, NULL); // Unbuffered file pointer.
877	}
878	}
879	}
880
881	if (pclp->m_redirErrName)
882	{
883	if ((stderr_fd = fileno(stderr)) != -1)
884	{
885	stderr_fd_dup = dup(stderr_fd);
886	if (stderr_fd_dup != -1)
887	{
888	fflush(stderr);
889
890	redirErr = fdopen (stderr_fd_dup, (char const *)"w");
891	if (redirErr)
892	stderr = freopen (pclp->m_redirErrName, (char const *)"w", redirErr);
893	if (!stderr)
894	{
895	redirErr = NULL;
896	// undo the redirect, if possible
897	stderr = fdopen(stderr_fd, (char const *)"w");
898	}
899	setbuf(stderr, NULL); // Unbuffered file pointer.
900	}
901	}
902	}
903
904	if (pclp->m_redirBothName)
905	{
906	if ((stdout_fd = fileno(stdout)) != -1)
907	{
908	stdout_fd_dup = dup(stdout_fd);
909	if (stdout_fd_dup != -1)
910	{
911	fflush(stdout);
912
913	redirOut = fdopen (stdout_fd_dup, (char const *)"w");
914	if (redirOut)
915	stdout = freopen (pclp->m_redirBothName, (char const *)"w", redirOut);
916	if (!stdout)
917	{
918	redirOut = NULL;
919	// undo the redirect, if possible
920	stdout = fdopen(stdout_fd, (char const *)"w");
921	}
922	setbuf(stdout, NULL); // Unbuffered file pointer.
923	}
924	}
925	if ((stderr_fd = fileno(stderr)) != -1)
926	{
927	stderr_fp = stderr;
928	stderr = stdout;
929	}
930	}
931
932	env = NULL;
933	fnSetUpEnvBlock(&env); // Set up the ENV block
934
935	// Run the Perl script
936	exitstatus = RunPerl(pclp->m_argc, pclp->m_argv, env);
937
938	// clean up any redirection
939	//
940	if (pclp->m_redirInName && redirIn)
941	{
942	fclose(stdin);
943	stdin = fdopen(stdin_fd, (char const *)"r"); // Put back the old handle for stdin.
944	}
945
946	if (pclp->m_redirOutName && redirOut)
947	{
948	// Close the new stdout.
949	fflush(stdout);
950	fclose(stdout);
951
952	// Put back the old handle for stdout.
953	stdout = fdopen(stdout_fd, (char const *)"w");
954	setbuf(stdout, NULL); // Unbuffered file pointer.
955	}
956
957	if (pclp->m_redirErrName && redirErr)
958	{
959	fflush(stderr);
960	fclose(stderr);
961
962	stderr = fdopen(stderr_fd, (char const *)"w"); // Put back the old handle for stderr.
963	setbuf(stderr, NULL); // Unbuffered file pointer.
964	}
965
966	if (pclp->m_redirBothName && redirOut)
967	{
968	stderr = stderr_fp;
969
970	fflush(stdout);
971	fclose(stdout);
972
973	stdout = fdopen(stdout_fd, (char const *)"w"); // Put back the old handle for stdout.
974	setbuf(stdout, NULL); // Unbuffered file pointer.
975	}
976
977
978	if (newscreen && newscreenhandle)
979	{
980	//added for --autodestroy switch
981	if(!pclp->m_AutoDestroy)
982	{
983	if ((redirOut == NULL) && (redirIn == NULL) && (!gKillAll))
984	{
985	printf((char *)"\n\nPress any key to exit\n");
986	getch();
987	}
988	}
989	DestroyScreen(newscreenhandle);
990	}
991
992	/**
993	// Commented since a few abends were happening in fnFpSetMode
994	// Set the mode for stdin and stdout
995	fnFpSetMode(stdin, O_TEXT, dummy);
996	fnFpSetMode(stdout, O_TEXT, dummy);
997	**/
998	setmode(stdin, O_TEXT);
999	setmode(stdout, O_TEXT);
1000
1001	// Cleanup
1002	if(pclp->m_argv)
1003	{
1004	for(i=0; i<pclp->m_argv_len; i++)
1005	{
1006	if(pclp->m_argv[i] != NULL)
1007	{
1008	free(pclp->m_argv[i]);
1009	pclp->m_argv[i] = NULL;
1010	}
1011	}
1012
1013	free(pclp->m_argv);
1014	pclp->m_argv = NULL;
1015	}
1016
1017	if(pclp->nextarg)
1018	{
1019	free(pclp->nextarg);
1020	pclp->nextarg = NULL;
1021	}
1022	if(pclp->sSkippedToken != NULL)
1023	{
1024	free(pclp->sSkippedToken);
1025	pclp->sSkippedToken = NULL;
1026	}
1027
1028	if(pclp->m_redirInName)
1029	{
1030	free(pclp->m_redirInName);
1031	pclp->m_redirInName = NULL;
1032	}
1033	if(pclp->m_redirOutName)
1034	{
1035	free(pclp->m_redirOutName);
1036	pclp->m_redirOutName = NULL;
1037	}
1038	if(pclp->m_redirErrName)
1039	{
1040	free(pclp->m_redirErrName);
1041	pclp->m_redirErrName = NULL;
1042	}
1043	if(pclp->m_redirBothName)
1044	{
1045	free(pclp->m_redirBothName);
1046	pclp->m_redirBothName = NULL;
1047	}
1048
1049	// Signal a semaphore, if indicated by -{ option, to indicate that
1050	// the script has terminated and files are closed
1051	//
1052	if (pclp->m_qSemaphore != 0)
1053	{
1054	#ifdef MPK_ON
1055	kSemaphoreSignal(pclp->m_qSemaphore);
1056	#else
1057	SignalLocalSemaphore(pclp->m_qSemaphore);
1058	#endif //MPK_ON
1059	}
1060
1061	if(pclp)
1062	{
1063	free(pclp);
1064	pclp = NULL;
1065	}
1066
1067	if(env)
1068	{
1069	fnDestroyEnvBlock(env);
1070	env = NULL;
1071	}
1072
1073	fnUnregisterWithThreadTable();
1074	// Remove the thread context set during Perl_set_context
1075	Remove_Thread_Ctx();
1076
1077	return;
1078	}
1079
1080
1081
1082	/*============================================================================================
1083
1084	Function : fnSetUpEnvBlock
1085
1086	Description : Sets up the initial environment block.
1087
1088	Parameters : penv (IN) - ENV variable as char***.
1089
1090	Returns : Nothing.
1091
1092	==============================================================================================*/
1093
1094	void fnSetUpEnvBlock(char*** penv)
1095	{
1096	char** env = NULL;
1097
1098	int sequence = 0;
1099	char var[kMaxVariableNameLen+1] = {'\0'};
1100	char val[kMaxValueLen+1] = {'\0'};
1101	char both[kMaxVariableNameLen + kMaxValueLen + 5] = {'\0'};
1102	size_t len = kMaxValueLen;
1103	int totalcnt = 0;
1104
1105	while(scanenv( &sequence, var, &len, val ))
1106	{
1107	totalcnt++;
1108	len = kMaxValueLen;
1109	}
1110	// add one for null termination
1111	totalcnt++;
1112
1113	env = (char *) malloc (totalcnt sizeof(char *));
1114	if (env)
1115	{
1116	int cnt = 0;
1117	int i = 0;
1118
1119	sequence = 0;
1120	len = kMaxValueLen;
1121
1122	while( (cnt < (totalcnt-1)) && scanenv( &sequence, var, &len, val ) )
1123	{
1124	val[len] = '\0';
1125	strcpy( both, var );
1126	strcat( both, (char *)"=" );
1127	strcat( both, val );
1128
1129	env[cnt] = (char ) malloc((sizeof(both)+1) sizeof(char));
1130	if (env[cnt])
1131	{
1132	strcpy(env[cnt], both);
1133	cnt++;
1134	}
1135	else
1136	{
1137	for(i=0; i<cnt; i++)
1138	{
1139	if(env[i])
1140	{
1141	free(env[i]);
1142	env[i] = NULL;
1143	}
1144	}
1145
1146	free(env);
1147	env = NULL;
1148
1149	return;
1150	}
1151
1152	len = kMaxValueLen;
1153	}
1154
1155	for(i=cnt; i<=(totalcnt-1); i++)
1156	env[i] = NULL;
1157	}
1158	else
1159	return;
1160
1161	*penv = env;
1162
1163	return;
1164	}
1165
1166
1167
1168	/*============================================================================================
1169
1170	Function : fnDestroyEnvBlock
1171
1172	Description : Frees resources used by the ENV block.
1173
1174	Parameters : env (IN) - ENV variable as char**.
1175
1176	Returns : Nothing.
1177
1178	==============================================================================================*/
1179
1180	void fnDestroyEnvBlock(char** env)
1181	{
1182	// It is assumed that this block is entered only if env is TRUE. So, the calling function
1183	// must check for this condition before calling fnDestroyEnvBlock.
1184	// If no check is made by the calling function, then the server abends.
1185	int k = 0;
1186	while (env[k] != NULL)
1187	{
1188	free(env[k]);
1189	env[k] = NULL;
1190	k++;
1191	}
1192
1193	free(env);
1194	env = NULL;
1195
1196	return;
1197	}
1198
1199
1200
1201	/*============================================================================================
1202
1203	Function : fnFpSetMode
1204
1205	Description : Sets the mode for a file.
1206
1207	Parameters : fp (IN) - FILE pointer for the input file.
1208	mode (IN) - Mode to be set
1209	e (OUT) - Error.
1210
1211	Returns : Integer which is the set value.
1212
1213	==============================================================================================*/
1214
1215	int fnFpSetMode(FILE* fp, int mode, int *err)
1216	{
1217	int ret = -1;
1218
1219	PFFSETMODE pf_fsetmode;
1220
1221	if (mode == O_BINARY \|\| mode == O_TEXT)
1222	{
1223	if (fp)
1224	{
1225	errno = 0;
1226	// the setmode call is not implemented (correctly) on NetWare,
1227	// but the CLIB guys were kind enough to provide another
1228	// call, fsetmode, which does a similar thing. It only works
1229	// on Moab
1230	pf_fsetmode = (PFFSETMODE) ImportSymbol(GetNLMHandle(), (char *)"fsetmode");
1231	if (pf_fsetmode)
1232	ret = (*pf_fsetmode) (fp, ((mode == O_BINARY) ? "b" : "t"));
1233	else
1234	{
1235	// we are on 4.11 instead of Moab, so we just return an error
1236	errno = ESERVER;
1237	err = &errno;
1238	}
1239	if (errno)
1240	err = &errno;
1241	}
1242	else
1243	{
1244	errno = EBADF;
1245	err = &errno;
1246	}
1247	}
1248	else
1249	{
1250	errno = EINVAL;
1251	err = &errno;
1252	}
1253
1254	return ret;
1255	}
1256
1257
1258
1259	/*============================================================================================
1260
1261	Function : fnInternalPerlLaunchHandler
1262
1263	Description : Gets called by perl to spawn a new instance of perl.
1264
1265	Parameters : cndLine (IN) - Command Line string.
1266
1267	Returns : Nothing.
1268
1269	==============================================================================================*/
1270
1271	void fnInternalPerlLaunchHandler(char* cmdLine)
1272	{
1273	int currentThreadGroup = -1;
1274
1275	ScriptData* psdata=NULL;
1276
1277	// Create a safe copy of the command line and pass it to the
1278	// new thread for parsing. The new thread will be responsible
1279	// to delete it when it is finished with it.
1280	psdata = (ScriptData *) malloc(sizeof(ScriptData));
1281	if (psdata)
1282	{
1283	psdata->m_commandLine = NULL;
1284	psdata->m_commandLine = (char ) malloc(MAX_DN_BYTES sizeof(char));
1285
1286	if(psdata->m_commandLine)
1287	{
1288	strcpy(psdata->m_commandLine, cmdLine);
1289	psdata->m_fromConsole = FALSE;
1290
1291	#ifdef MPK_ON
1292	BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
1293	#else
1294	// Start a new thread in its own thread group
1295	BeginThread(fnLaunchPerl, NULL, PERL_COMMAND_STACK_SIZE, (void*)psdata);
1296	#endif //MPK_ON
1297	}
1298	else
1299	{
1300	free(psdata);
1301	psdata = NULL;
1302	return;
1303	}
1304	}
1305	else
1306	return;
1307
1308	return;
1309	}
1310
1311
1312
1313	/*============================================================================================
1314
1315	Function : fnGetPerlScreenName
1316
1317	Description : This function creates the Perl screen name.
1318	Gets called from main only once when the Perl NLM loads.
1319
1320	Parameters : sPerlScreenName (OUT) - Resultant Perl screen name.
1321
1322	Returns : Nothing.
1323
1324	==============================================================================================*/
1325
1326	void fnGetPerlScreenName(char *sPerlScreenName)
1327	{
1328	// HYAK:
1329	// The logic for using 32 in the below array sizes is like this:
1330	// The NetWare CLIB SDK documentation says that for base 2 conversion,
1331	// this number must be minimum 8. Also, in the example of the documentation,
1332	// 20 is used as the size and testing is done for bases from 2 upto 16.
1333	// So, to simply chose a number above 20 and also keeping in mind not to reserve
1334	// unnecessary big array sizes, I have chosen 32 !
1335	// Less than that may also suffice.
1336	char sPerlRevision[32 * sizeof(char)] = {'\0'};
1337	char sPerlVersion[32 * sizeof(char)] = {'\0'};
1338	char sPerlSubVersion[32 * sizeof(char)] = {'\0'};
1339
1340	// The defines for PERL_REVISION, PERL_VERSION, PERL_SUBVERSION are available in
1341	// patchlevel.h under root and gets included when perl.h is included.
1342	// The number 10 below indicates base 10.
1343	itoa(PERL_REVISION, sPerlRevision, 10);
1344	itoa(PERL_VERSION, sPerlVersion, 10);
1345	itoa(PERL_SUBVERSION, sPerlSubVersion, 10);
1346
1347	// Concatenate substrings to get a string like Perl5.6.1 which is used as the screen name.
1348	sprintf(sPerlScreenName, "%s%s.%s.%s", PERL_COMMAND_NAME,
1349	sPerlRevision, sPerlVersion, sPerlSubVersion);
1350
1351	return;
1352	}
1353
1354
1355
1356	// Global variable to hold the environ information.
1357	// First time it is accessed, it will be created and initialized and
1358	// next time onwards, the pointer will be returned.
1359
1360	// Improvements - Dynamically read env everytime a request comes - Is this required?
1361	char** genviron = NULL;
1362
1363
1364	/*============================================================================================
1365
1366	Function : nw_getenviron
1367
1368	Description : Gets the environment information.
1369
1370	Parameters : None.
1371
1372	Returns : Nothing.
1373
1374	==============================================================================================*/
1375
1376	char ***
1377	nw_getenviron()
1378	{
1379	if (genviron)
1380	return (&genviron); // This might leak memory upto 11736 bytes on some versions of NetWare.
1381	// return genviron; // Abending on some versions of NetWare.
1382	else
1383	fnSetUpEnvBlock(&genviron);
1384
1385	return (&genviron);
1386	}
1387
1388
1389
1390	/*============================================================================================
1391
1392	Function : nw_freeenviron
1393
1394	Description : Frees the environment information.
1395
1396	Parameters : None.
1397
1398	Returns : Nothing.
1399
1400	==============================================================================================*/
1401
1402	void
1403	nw_freeenviron()
1404	{
1405	if (genviron)
1406	{
1407	fnDestroyEnvBlock(genviron);
1408	genviron=NULL;
1409	}
1410	}
1411

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

Context Navigation

source: trunk/essentials/dev-lang/perl/NetWare/Nwmain.c

Download in other formats: