OS/2 Shareware BBS: 10 Tools/10-Tools.zip/perl501m.zip/OS2/os2main.c

C/C++ Source or Header | 1995-05-17 | 6KB | 193 lines

/*
 * "The Road goes ever on and on, down from the door where it began."
 */

#include "EXTERN.h"
#include "perl.h"

#define INCL_BASE
#include <os2.h>

#pragma pack(1)
#define _Packed
#define INCL_REXXSAA
#include <rexxsaa.h>
#pragma pack()

extern ULONG _emx_exception (    EXCEPTIONREPORTRECORD *,
                EXCEPTIONREGISTRATIONRECORD *,
                                CONTEXTRECORD *,
                                void *);

static void xs_init _((void));
static PerlInterpreter *my_perl;

void
usage(char *myname)
{
  printf("\nUsage: %s [switches] [filename] [arguments]\n", myname);

  printf("\n  -0[octal]       specify record separator (0, if no argument)"
         "\n  -a              autosplit mode with -n or -p"
         "\n  -c              syntaxcheck only"
         "\n  -d              run scripts under debugger"
         "\n  -Dnumber        set debugging flags (argument is a bit mask)"
         "\n  -e command      one line of script, multiple -e options are allowed"
         "\n                  [filename] can be ommitted, when -e is used"
         "\n  -F regexp       regular expression for autosplit (-a)"
         "\n  -i[extension]   edit <> files in place (make backup if extension supplied)"
         "\n  -Idirectory     specify include directory in conjunction with -P"
         "\n  -l[octal]       enable line ending processing, specifies line teminator"
         "\n  -n              assume 'while (<>) { ... }' loop arround your script"
         "\n  -p              assume loop like -n but print line also like sed"
         "\n  -P              run script through C preprocessor before compilation"
#ifndef HAS_FORK
         "\n  -R              enable REXX variable pool"
#endif
         "\n  -s              enable some switch parsing for switches after script name"
         "\n  -S              look for the script using PATH environment variable"
         "\n  -v              print version number and patchlevel of perl"
         "\n  -w              turn warnings on for compilation of your script\n"
         "\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
}

static int    argc0;
static char **    argv0;
static char **    envp0;
static int    exit0;

static ULONG
StartPerl(PSZ name, ULONG argc, RXSTRING argv[], PSZ queue, PRXSTRING ret)
{
    int exitstatus;
    EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };

#ifndef HAS_FORK
    DosSetExceptionHandler(&xreg);
#endif

    my_perl = perl_alloc();
    if (my_perl) {
        perl_construct( my_perl );

        if ((exit0 = perl_parse( my_perl, xs_init, argc0, argv0, envp0 )) == 0) {
            exit0 = perl_run( my_perl );

            perl_destruct( my_perl );
            perl_free( my_perl );
        }
    } else
        exit0 = 1;

#ifndef HAS_FORK
    DosUnsetExceptionHandler(&xreg);
#endif

    MAKERXSTRING(*ret, NULL, 0);
    return 0;
}

/* Register any extra external extensions */

static void
xs_init()
{
    /* Do not delete this line--writemain depends on it */
    char *file = __FILE__;
#ifndef HAS_FORK
    {   extern void boot_DynaLoader _((CV* cv));
        newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    }
#endif
#ifdef HAS_FORK
    {   extern void boot_Socket _((CV* cv));
        newXS("Socket::boot_Socket", boot_Socket, file);
    }
    {   extern void boot_POSIX _((CV* cv));
        newXS("POSIX::boot_POSIX", boot_POSIX, file);
    }
#endif
}

/*****************************************************************************/

int
main(argc, argv, envp)
int argc;
char **argv;
char **envp;
{
    int useREXX = 0;
    int i;
    char *cp;
    RXSTRING args[1];
    RXSTRING inst[2];
    RXSTRING result;
    USHORT   retcode;
    static char cmd[] = "CALL StartPerl\r\n";

    _response(&argc, &argv);
    _wildcard(&argc, &argv);

    tzset();

    /* Look for REXX option. */
    for (i = 1; i < argc && *argv[i] == '-'; )
        if (cp = strchr(argv[i]+1, 'R')) {
            ++useREXX;
            memmove(cp, cp+1, strlen(cp+1)+1);
            if (!*(argv[i]+1)) {
                while (++i < argc)
            argv[i-1] = argv[i];
        argv[--argc] = NULL;
            }
        } else
            ++i;

    if (argc <= 1) {
        usage(argv[0]);
        exit(1);
    }

    DosError(FERR_DISABLEHARDERR | FERR_DISABLEEXCEPTION);

    argc0 = argc;
    argv0 = argv;
    envp0 = envp;

#ifndef HAS_FORK
    if (useREXX) {
    HMODULE hRexx, hRexxAPI;
    BYTE    buf[200];
    LONG    APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
    APIRET  APIENTRY (*pRexxRegisterFunctionExe) (PSZ, PFN);
    APIRET  APIENTRY (*pRexxDeregisterFunction) (PSZ);

    if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
     || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
     || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
     || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", (PFN *)&pRexxRegisterFunctionExe)
     || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", (PFN *)&pRexxDeregisterFunction)) {
        fprintf(stderr, "REXX not available\n");
        exit(1);
    }

        pRexxRegisterFunctionExe("StartPerl", (PFN)StartPerl);

        MAKERXSTRING(args[0], NULL, 0);
        MAKERXSTRING(inst[0], cmd,  strlen(cmd));
        MAKERXSTRING(inst[1], NULL, 0);
        MAKERXSTRING(result,  NULL, 0);
        pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, &retcode, &result);

        pRexxDeregisterFunction("StartPerl");

    DosFreeModule(hRexxAPI);
    DosFreeModule(hRexx);
    } else
#endif
        StartPerl(0, 0, 0, 0, &result);

    return exit0;
}