win32/perllib.c

   1 /*
   2  * "The Road goes ever on and on, down from the door where it began."
   3  */
   4
   5 #ifdef __cplusplus
   6 extern "C" {
   7 #endif
   8
   9 #include "EXTERN.h"
  10 #include "perl.h"
  11 #include "XSUB.h"
  12
  13 #ifdef __cplusplus
  14 }
  15 #  define EXTERN_C extern "C"
  16 #else
  17 #  define EXTERN_C extern
  18 #endif
  19
  20 static void xs_init _((void));
  21
  22 __declspec(dllexport) int
  23 RunPerl(int argc, char **argv, char **env, void *iosubsystem)
  24 {
  25     int exitstatus;
  26     PerlInterpreter *my_perl;
  27     void *pOldIOSubsystem;
  28
  29     pOldIOSubsystem = SetIOSubSystem(iosubsystem);
  30
  31     PERL_SYS_INIT(&argc,&argv);
  32
  33     perl_init_i18nl10n(1);
  34
  35     if (!(my_perl = perl_alloc()))
  36         return (1);
  37     perl_construct( my_perl );
  38     perl_destruct_level = 0;
  39
  40     exitstatus = perl_parse( my_perl, xs_init, argc, argv, env);
  41     if (!exitstatus) {
  42         exitstatus = perl_run( my_perl );
  43     }
  44
  45     perl_destruct( my_perl );
  46     perl_free( my_perl );
  47
  48     PERL_SYS_TERM();
  49
  50     SetIOSubSystem(pOldIOSubsystem);
  51
  52     return (exitstatus);
  53 }
  54
  55 extern HANDLE PerlDllHandle;
  56
  57 BOOL APIENTRY
  58 DllMain(HANDLE hModule,         /* DLL module handle */
  59         DWORD fdwReason,        /* reason called */
  60         LPVOID lpvReserved)     /* reserved */
  61 {
  62     switch (fdwReason) {
  63         /* The DLL is attaching to a process due to process
  64          * initialization or a call to LoadLibrary.
  65          */
  66     case DLL_PROCESS_ATTACH:
  67 /* #define DEFAULT_BINMODE */
  68 #ifdef DEFAULT_BINMODE
  69         _setmode( _fileno( stdin  ), _O_BINARY );
  70         _setmode( _fileno( stdout ), _O_BINARY );
  71         _setmode( _fileno( stderr ), _O_BINARY );
  72         _fmode = _O_BINARY;
  73 #endif
  74         PerlDllHandle = hModule;
  75         break;
  76
  77         /* The DLL is detaching from a process due to
  78          * process termination or call to FreeLibrary.
  79          */
  80     case DLL_PROCESS_DETACH:
  81         break;
  82
  83         /* The attached process creates a new thread. */
  84     case DLL_THREAD_ATTACH:
  85         break;
  86
  87         /* The thread of the attached process terminates. */
  88     case DLL_THREAD_DETACH:
  89         break;
  90
  91     default:
  92         break;
  93     }
  94     return TRUE;
  95 }
  96
  97 /* Register any extra external extensions */
  98
  99 char *staticlinkmodules[] = {
 100     "DynaLoader",
 101     NULL,
 102 };
 103
 104 EXTERN_C void boot_DynaLoader _((CV* cv));
 105
 106 static
 107 XS(w32_GetCwd)
 108 {
 109     dXSARGS;
 110     SV *sv = sv_newmortal();
 111     /* Make one call with zero size - return value is required size */
 112     DWORD len = GetCurrentDirectory((DWORD)0,NULL);
 113     SvUPGRADE(sv,SVt_PV);
 114     SvGROW(sv,len);
 115     SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
 116     /*
 117      * If result != 0
 118      *   then it worked, set PV valid,
 119      *   else leave it 'undef'
 120      */
 121     if (SvCUR(sv))
 122         SvPOK_on(sv);
 123     EXTEND(sp,1);
 124     ST(0) = sv;
 125     XSRETURN(1);
 126 }
 127
 128 static
 129 XS(w32_SetCwd)
 130 {
 131     dXSARGS;
 132     if (items != 1)
 133         croak("usage: Win32::SetCurrentDirectory($cwd)");
 134     if (SetCurrentDirectory(SvPV(ST(0),na)))
 135         XSRETURN_YES;
 136
 137     XSRETURN_NO;
 138 }
 139
 140 static
 141 XS(w32_GetNextAvailDrive)
 142 {
 143     dXSARGS;
 144     char ix = 'C';
 145     char root[] = "_:\\";
 146     while (ix <= 'Z') {
 147         root[0] = ix++;
 148         if (GetDriveType(root) == 1) {
 149             root[2] = '\0';
 150             XSRETURN_PV(root);
 151         }
 152     }
 153     XSRETURN_UNDEF;
 154 }
 155
 156 static
 157 XS(w32_GetLastError)
 158 {
 159     dXSARGS;
 160     XSRETURN_IV(GetLastError());
 161 }
 162
 163 static
 164 XS(w32_LoginName)
 165 {
 166     dXSARGS;
 167     char name[256];
 168     DWORD size = sizeof(name);
 169     if (GetUserName(name,&size)) {
 170         /* size includes NULL */
 171         ST(0) = sv_2mortal(newSVpv(name,size-1));
 172         XSRETURN(1);
 173     }
 174     XSRETURN_UNDEF;
 175 }
 176
 177 static
 178 XS(w32_NodeName)
 179 {
 180     dXSARGS;
 181     char name[MAX_COMPUTERNAME_LENGTH+1];
 182     DWORD size = sizeof(name);
 183     if (GetComputerName(name,&size)) {
 184         /* size does NOT include NULL :-( */
 185         ST(0) = sv_2mortal(newSVpv(name,size));
 186         XSRETURN(1);
 187     }
 188     XSRETURN_UNDEF;
 189 }
 190
 191
 192 static
 193 XS(w32_DomainName)
 194 {
 195     dXSARGS;
 196     char name[256];
 197     DWORD size = sizeof(name);
 198     if (GetUserName(name,&size)) {
 199         char sid[1024];
 200         DWORD sidlen = sizeof(sid);
 201         char dname[256];
 202         DWORD dnamelen = sizeof(dname);
 203         SID_NAME_USE snu;
 204         if (LookupAccountName(NULL, name, &sid, &sidlen,
 205                               dname, &dnamelen, &snu)) {
 206             XSRETURN_PV(dname);         /* all that for this */
 207         }
 208     }
 209     XSRETURN_UNDEF;
 210 }
 211
 212 static
 213 XS(w32_FsType)
 214 {
 215     dXSARGS;
 216     char fsname[256];
 217     DWORD flags, filecomplen;
 218     if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
 219                          &flags, fsname, sizeof(fsname))) {
 220         if (GIMME == G_ARRAY) {
 221             XPUSHs(sv_2mortal(newSVpv(fsname,0)));
 222             XPUSHs(sv_2mortal(newSViv(flags)));
 223             XPUSHs(sv_2mortal(newSViv(filecomplen)));
 224             PUTBACK;
 225             return;
 226         }
 227         XSRETURN_PV(fsname);
 228     }
 229     XSRETURN_UNDEF;
 230 }
 231
 232 static
 233 XS(w32_GetOSVersion)
 234 {
 235     dXSARGS;
 236     OSVERSIONINFO osver;
 237
 238     osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
 239     if (GetVersionEx(&osver)) {
 240         XPUSHs(newSVpv(osver.szCSDVersion, 0));
 241         XPUSHs(newSViv(osver.dwMajorVersion));
 242         XPUSHs(newSViv(osver.dwMinorVersion));
 243         XPUSHs(newSViv(osver.dwBuildNumber));
 244         XPUSHs(newSViv(osver.dwPlatformId));
 245         PUTBACK;
 246         return;
 247     }
 248     XSRETURN_UNDEF;
 249 }
 250
 251 static
 252 XS(w32_IsWinNT)
 253 {
 254     dXSARGS;
 255     XSRETURN_IV(IsWinNT());
 256 }
 257
 258 static
 259 XS(w32_IsWin95)
 260 {
 261     dXSARGS;
 262     XSRETURN_IV(IsWin95());
 263 }
 264
 265 static
 266 XS(w32_FormatMessage)
 267 {
 268     dXSARGS;
 269     DWORD source = 0;
 270     char msgbuf[1024];
 271
 272     if (items != 1)
 273         croak("usage: Win32::FormatMessage($errno)");
 274
 275     if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
 276                       &source, SvIV(ST(0)), 0,
 277                       msgbuf, sizeof(msgbuf)-1, NULL))
 278         XSRETURN_PV(msgbuf);
 279
 280     XSRETURN_UNDEF;
 281 }
 282
 283 static
 284 XS(w32_Spawn)
 285 {
 286     dXSARGS;
 287     char *cmd, *args;
 288     PROCESS_INFORMATION stProcInfo;
 289     STARTUPINFO stStartInfo;
 290     BOOL bSuccess = FALSE;
 291
 292     if(items != 3)
 293         croak("usage: Win32::Spawn($cmdName, $args, $PID)");
 294
 295     cmd = SvPV(ST(0),na);
 296     args = SvPV(ST(1), na);
 297
 298     memset(&stStartInfo, 0, sizeof(stStartInfo));   /* Clear the block */
 299     stStartInfo.cb = sizeof(stStartInfo);           /* Set the structure size */
 300     stStartInfo.dwFlags = STARTF_USESHOWWINDOW;     /* Enable wShowWindow control */
 301     stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE;   /* Start min (normal) */
 302
 303     if(CreateProcess(
 304                 cmd,                    /* Image path */
 305                 args,                   /* Arguments for command line */
 306                 NULL,                   /* Default process security */
 307                 NULL,                   /* Default thread security */
 308                 FALSE,                  /* Must be TRUE to use std handles */
 309                 NORMAL_PRIORITY_CLASS,  /* No special scheduling */
 310                 NULL,                   /* Inherit our environment block */
 311                 NULL,                   /* Inherit our currrent directory */
 312                 &stStartInfo,           /* -> Startup info */
 313                 &stProcInfo))           /* <- Process info (if OK) */
 314     {
 315         CloseHandle(stProcInfo.hThread);/* library source code does this. */
 316         sv_setiv(ST(2), stProcInfo.dwProcessId);
 317         bSuccess = TRUE;
 318     }
 319     XSRETURN_IV(bSuccess);
 320 }
 321
 322 static
 323 XS(w32_GetTickCount)
 324 {
 325     dXSARGS;
 326     XSRETURN_IV(GetTickCount());
 327 }
 328
 329 static
 330 XS(w32_GetShortPathName)
 331 {
 332     dXSARGS;
 333     SV *shortpath;
 334
 335     if(items != 1)
 336         croak("usage: Win32::GetShortPathName($longPathName)");
 337
 338     shortpath = sv_mortalcopy(ST(0));
 339     SvUPGRADE(shortpath, SVt_PV);
 340     /* src == target is allowed */
 341     if (GetShortPathName(SvPVX(shortpath), SvPVX(shortpath), SvCUR(shortpath)))
 342         ST(0) = shortpath;
 343     else
 344         ST(0) = &sv_undef;
 345     XSRETURN(1);
 346 }
 347
 348 static void
 349 xs_init()
 350 {
 351     char *file = __FILE__;
 352     dXSUB_SYS;
 353     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 354
 355     /* XXX should be removed after checking with Nick */
 356     newXS("Win32::GetCurrentDirectory", w32_GetCwd, file);
 357
 358     /* these names are Activeware compatible */
 359     newXS("Win32::GetCwd", w32_GetCwd, file);
 360     newXS("Win32::SetCwd", w32_SetCwd, file);
 361     newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
 362     newXS("Win32::GetLastError", w32_GetLastError, file);
 363     newXS("Win32::LoginName", w32_LoginName, file);
 364     newXS("Win32::NodeName", w32_NodeName, file);
 365     newXS("Win32::DomainName", w32_DomainName, file);
 366     newXS("Win32::FsType", w32_FsType, file);
 367     newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
 368     newXS("Win32::IsWinNT", w32_IsWinNT, file);
 369     newXS("Win32::IsWin95", w32_IsWin95, file);
 370     newXS("Win32::FormatMessage", w32_FormatMessage, file);
 371     newXS("Win32::Spawn", w32_Spawn, file);
 372     newXS("Win32::GetTickCount", w32_GetTickCount, file);
 373     newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
 374
 375     /* XXX Bloat Alert! The following Activeware preloads really
 376      * ought to be part of Win32::Sys::*, so they're not included
 377      * here.
 378      */
 379     /* LookupAccountName
 380      * LookupAccountSID
 381      * InitiateSystemShutdown
 382      * AbortSystemShutdown
 383      * ExpandEnvrironmentStrings
 384      */
 385 }
 386