source: vendor/perl/5.8.8/NetWare/Nwmain.c@ 3181

Last change on this file since 3181 was 3181, checked in by bird, 19 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//
55bool 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//
62static 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//
68BOOL gCmdProcInit = FALSE;
69
70
71// Array to hold the screen name for all new screens.
72//
73char sPerlScreenName[MAX_DN_BYTES * sizeof(char)] = {'\0'};
74
75
76// Structure to pass data when spawning new threadgroups to run scripts.
77//
78typedef 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
104typedef void (*PFUSEACCURATECASEFORPATHS) (int);
105typedef LONG (*PFGETFILESERVERMAJORVERSIONNUMBER) (void);
106typedef void (*PFUCSTERMINATE) (); // For ucs terminate.
107typedef void (*PFUNAUGMENTASTERISK)(BOOL); // For longfile support.
108typedef int (*PFFSETMODE) (FILE *, char *);
109
110
111// local function prototypes
112//
113void fnSigTermHandler(int sig);
114void fnRegisterCommandLineHandler(void);
115void fnLaunchPerl(void* context);
116void fnSetUpEnvBlock(char*** penv);
117void fnDestroyEnvBlock(char** env);
118int fnFpSetMode(FILE* fp, int mode, int *err);
119
120void fnGetPerlScreenName(char *sPerlScreenName);
121
122void fnGetPerlScreenName(char *sPerlScreenName);
123void fnSetupNamespace(void);
124char *getcwd(char [], int);
125void fnRunScript(ScriptData* psdata);
126void 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
143void 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
272void 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
343LONG 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
433void 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
461void 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
517void 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
623void 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
1094void 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
1180void 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
1215int 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
1271void 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
1326void 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?
1361char** 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
1376char ***
1377nw_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
1402void
1403nw_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.