view release on metacpan or  search on metacpan

lib/Win32/VBScript.pm  view on Meta::CPAN

Function IProg(ByVal MT, ByVal MNum, ByVal MBool)
    Dim OS : Set OS = CreateObject("WScript.Shell")

    MBool = UCase(Mid(MBool, 1, 1))
    Dim ZNum  : If MNum  = "1" Then ZNum  = 1    Else ZNum  = 0
    Dim ZBool : If MBool = "T" Then ZBool = True Else ZBool = False

    IProg = OS.Run(MT, ZNum, ZBool)
End Function
EOP

my $proxy_prog = compile_prog_vbs([ <<'EOP' ]);
    Dim OS : Set OS = CreateObject("WScript.Shell")
    Dim EP : Set EP = OS.Environment("Process")

    Dim MT    : MT    = EP("PAR_CMD")
    Dim MNum  : MNum  = EP("PAR_NUM")
    Dim MBool : MBool = EP("PAR_BOOL")

    MBool = UCase(Mid(MBool, 1, 1))
    Dim ZNum  : If MNum  = "1" Then ZNum  = 1    Else ZNum  = 0
    Dim ZBool : If MBool = "T" Then ZBool = True Else ZBool = False

    OS.Run MT, ZNum, ZBool
EOP

sub new {
    my $pkg = shift;

    my ($type, $lang, $code) = @_;

    unless ($type eq 'prog' or $type eq 'func') {
        croak "E010: Invalid type ('$type'), expected ('prog' or 'func')";
    }

    unless (-d $VBRepo) {
        mkdir $VBRepo or croak "E020: Can't mkdir '$VBRepo' because $!";
    }

    my $dat_engine;
    my $dat_comment;

    if ($lang eq 'vbs') {
        $dat_engine  = 'VBScript';
        $dat_comment = q{'};
    }
    elsif ($lang eq 'js') {
        $dat_engine  = 'JScript';
        $dat_comment = q{//};
    }
    else {
        croak "E030: Invalid language ('$lang'), expected ('vbs' or 'js')";
    }

    my $dat_text  = ''; for (@$code) { $dat_text .= $_."\n"; }
    my $dat_sha1  = sha1_hex($dat_text);
    my $dat_class = "InlineWin32COM.WSC\\_$dat_sha1.wsc";

    my %dat_func;

    for (split m{\n}xms, $dat_text) {
        if (m{\A \s* (?: function | sub) \s+ (\w+) (?: \z | \W)}xmsi) {
            $dat_func{$1} = undef;
        }
    }

    my $file_content;

    if ($type eq 'prog') {
        $file_content = $dat_comment.' -- '.$dat_engine.qq{\n\n}.$dat_text;
    }
    elsif ($type eq 'func') {
        $file_content =
          qq{<?xml version="1.0"?>\n}.
          qq{<component>\n}.
          qq{  <registration }.
              qq{description="Inline::WSC Class" }.
              qq{progid="$dat_class" }.
              qq{version="1.0">\n}.
          qq{  </registration>\n}.
          qq{  <public>\n}.
          join('', map { qq{    <method name="$_" />\n} } sort { lc($a) cmp lc($b) } keys %dat_func).
          qq{  </public>\n}.
          qq{  <implements type="ASP" id="ASP" />\n}.
          qq{  <script language="$dat_engine">\n}.
          qq{    <![CDATA[\n$dat_text\n]]>\n}.
          qq{  </script>\n}.
          qq{</component>\n};
    }
    else {
        croak "E040: Panic -- Invalid type ('$type'), expected ('prog' or 'func')";
    }

    my $file_name = 'T_'.$dat_sha1.'.txt';
    my $file_full = $VBRepo.'\\'.$file_name;

    write_file($file_full, $file_content);

    if ($type eq 'func') {
        my $obj = Win32::OLE->GetObject('script:'.$file_full);

        unless ($obj) {
            #~ my $file_text = eval{ scalar(read_file($file_full)) } || '???';
            croak "E050: ",
              "Couldn't Win32::OLE->GetObject('script:$file_full')",
              " -> ".Win32::GetLastError().
              " -> ".Win32::FormatMessage(Win32::GetLastError());
        }

        for my $method (keys %dat_func) {
            $dat_func{$method} = sub { $obj->$method(@_); };
        }
    }

    bless {
      'name' => $file_name,
      'type' => $type,
      'lang' => $lang,
      'func' => \%dat_func,
    }, $pkg;
}