File Coverage

blib/lib/Win32/VBScript.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package Win32::VBScript;
2             $Win32::VBScript::VERSION = '0.06';
3 1     1   795 use strict;
  1         2  
  1         24  
4 1     1   4 use warnings;
  1         2  
  1         28  
5              
6 1     1   12 use Carp;
  1         2  
  1         62  
7 1     1   839 use Digest::SHA qw(sha1_hex);
  1         3774  
  1         85  
8 1     1   926 use File::Slurp;
  1         13370  
  1         77  
9 1     1   413 use Win32::OLE;
  0            
  0            
10              
11             require Exporter;
12             our @ISA = qw(Exporter);
13             our %EXPORT_TAGS = ('ini' => [qw(
14             compile_prog_vbs compile_prog_js
15             compile_func_vbs compile_func_js
16             )]);
17             our @EXPORT = qw();
18             our @EXPORT_OK = ( @{ $EXPORT_TAGS{'ini'} } );
19              
20             my $VBRepo = $ENV{'TEMP'}.'\\Repo01';
21              
22             my $proxy_invoke = compile_func_vbs([ <<'EOP' ])->func('IProg');
23             Function IProg(ByVal MT, ByVal MNum, ByVal MBool)
24             Dim OS : Set OS = CreateObject("WScript.Shell")
25              
26             MBool = UCase(Mid(MBool, 1, 1))
27             Dim ZNum : If MNum = "1" Then ZNum = 1 Else ZNum = 0
28             Dim ZBool : If MBool = "T" Then ZBool = True Else ZBool = False
29              
30             IProg = OS.Run(MT, ZNum, ZBool)
31             End Function
32             EOP
33              
34             my $proxy_prog = compile_prog_vbs([ <<'EOP' ]);
35             Dim OS : Set OS = CreateObject("WScript.Shell")
36             Dim EP : Set EP = OS.Environment("Process")
37              
38             Dim MT : MT = EP("PAR_CMD")
39             Dim MNum : MNum = EP("PAR_NUM")
40             Dim MBool : MBool = EP("PAR_BOOL")
41              
42             MBool = UCase(Mid(MBool, 1, 1))
43             Dim ZNum : If MNum = "1" Then ZNum = 1 Else ZNum = 0
44             Dim ZBool : If MBool = "T" Then ZBool = True Else ZBool = False
45              
46             OS.Run MT, ZNum, ZBool
47             EOP
48              
49             sub new {
50             my $pkg = shift;
51              
52             my ($type, $lang, $code) = @_;
53              
54             unless ($type eq 'prog' or $type eq 'func') {
55             croak "E010: Invalid type ('$type'), expected ('prog' or 'func')";
56             }
57              
58             unless (-d $VBRepo) {
59             mkdir $VBRepo or croak "E020: Can't mkdir '$VBRepo' because $!";
60             }
61              
62             my $dat_engine;
63             my $dat_comment;
64              
65             if ($lang eq 'vbs') {
66             $dat_engine = 'VBScript';
67             $dat_comment = q{'};
68             }
69             elsif ($lang eq 'js') {
70             $dat_engine = 'JScript';
71             $dat_comment = q{//};
72             }
73             else {
74             croak "E030: Invalid language ('$lang'), expected ('vbs' or 'js')";
75             }
76              
77             my $dat_text = ''; for (@$code) { $dat_text .= $_."\n"; }
78             my $dat_sha1 = sha1_hex($dat_text);
79             my $dat_class = "InlineWin32COM.WSC\\_$dat_sha1.wsc";
80              
81             my %dat_func;
82              
83             for (split m{\n}xms, $dat_text) {
84             if (m{\A \s* (?: function | sub) \s+ (\w+) (?: \z | \W)}xmsi) {
85             $dat_func{$1} = undef;
86             }
87             }
88              
89             my $file_content;
90              
91             if ($type eq 'prog') {
92             $file_content = $dat_comment.' -- '.$dat_engine.qq{\n\n}.$dat_text;
93             }
94             elsif ($type eq 'func') {
95             $file_content =
96             qq{\n}.
97             qq{\n}.
98             qq{
99             qq{description="Inline::WSC Class" }.
100             qq{progid="$dat_class" }.
101             qq{version="1.0">\n}.
102             qq{ \n}.
103             qq{ \n}.
104             join('', map { qq{ \n} } sort { lc($a) cmp lc($b) } keys %dat_func).
105             qq{ \n}.
106             qq{ \n}.
107             qq{ \n}.
110             qq{\n};
111             }
112             else {
113             croak "E040: Panic -- Invalid type ('$type'), expected ('prog' or 'func')";
114             }
115              
116             my $file_name = 'T_'.$dat_sha1.'.txt';
117             my $file_full = $VBRepo.'\\'.$file_name;
118              
119             write_file($file_full, $file_content);
120              
121             if ($type eq 'func') {
122             my $obj = Win32::OLE->GetObject('script:'.$file_full);
123              
124             unless ($obj) {
125             #~ my $file_text = eval{ scalar(read_file($file_full)) } || '???';
126             croak "E050: ",
127             "Couldn't Win32::OLE->GetObject('script:$file_full')",
128             " -> ".Win32::GetLastError().
129             " -> ".Win32::FormatMessage(Win32::GetLastError());
130             }
131              
132             for my $method (keys %dat_func) {
133             $dat_func{$method} = sub { $obj->$method(@_); };
134             }
135             }
136              
137             bless {
138             'name' => $file_name,
139             'type' => $type,
140             'lang' => $lang,
141             'func' => \%dat_func,
142             }, $pkg;
143             }
144              
145             sub compile_prog_vbs {
146             my ($code) = @_;
147             Win32::VBScript->new('prog', 'vbs', $code);
148             }
149              
150             sub compile_prog_js {
151             my ($code) = @_;
152             Win32::VBScript->new('prog', 'js', $code);
153             }
154              
155             sub compile_func_vbs {
156             my ($code) = @_;
157             Win32::VBScript->new('func', 'vbs', $code);
158             }
159              
160             sub compile_func_js {
161             my ($code) = @_;
162             Win32::VBScript->new('func', 'js', $code);
163             }
164              
165             sub _run {
166             my $self = shift;
167             my ($scr, $mode, $level) = @_;
168              
169             unless ($scr eq 'cscript' or $scr eq 'wscript') {
170             croak "E060: Invalid script ('$scr'), expected ('cscript' or 'wscript')";
171             }
172              
173             unless ($mode eq 'a' or $mode eq 's') {
174             croak "E061: Invalid mode ('$mode'), expected ('a' or 's')";
175             }
176              
177             unless ($level eq 'pl' or $level eq 'ms' or $level eq 'tn') {
178             croak "E062: Invalid level ('$level'), expected ('pl', 'ms' or 'tn')";
179             }
180              
181             my $name = $self->{'name'};
182             my $lang = $self->{'lang'};
183             my $type = $self->{'type'};
184              
185             unless ($type eq 'prog') {
186             croak "E065: Invalid type ('$type'), expected ('prog')";
187             }
188              
189             my $full = $VBRepo.'\\'.$name;
190              
191             unless (-f $full) {
192             croak "E070: Panic -- can't find executable '$full'";
193             }
194              
195             my $engine =
196             $lang eq 'vbs' ? 'VBScript' :
197             $lang eq 'js' ? 'JScript' :
198             croak "E080: Panic -- invalid language ('$lang'), expected ('vbs' or 'js')";
199              
200             my @param = ($scr, '//Nologo', '//E:'.$engine, $full);
201              
202             if ($level eq 'pl') {
203             if ($mode eq 'a') {
204             system 1, @param; # asynchronous
205             }
206             elsif ($mode eq 's') {
207             system @param; # sequentially
208             }
209             else {
210             croak "E082: Panic -- invalid mode ('$mode'), expected ('a' or 's')";
211             }
212             }
213             elsif ($level eq 'ms' or $level eq 'tn') {
214             my $PCmd = join(' ', map { qq{"$_"} } @param);
215             my $PNum = $scr eq 'cscript' ? '1' : '0';
216             my $PBool = $mode eq 's' ? 'True' : 'False';
217              
218             # RC = CreateObject("WScript.Shell").Run($PCmd 0, False)
219             # ==> 0 = CMD Prompt will not be shown,
220             # ==> 1 = CMD Prompt will be shown,
221             # ==> False = Do not wait for program to finish
222             # ==> True = Wait for program to finish
223              
224             if ($level eq 'ms') {
225             $proxy_invoke->($PCmd, $PNum, $PBool);
226             }
227             else {
228             $ENV{'PAR_CMD'} = $PCmd;
229             $ENV{'PAR_NUM'} = $PNum;
230             $ENV{'PAR_BOOL'} = $PBool;
231              
232             $proxy_prog->_run('wscript', 'a', 'pl'); # a = asynchronous
233             }
234             }
235             else {
236             croak "E084: Panic -- invalid level ('$level'), expected ('pl' or 'ms')";
237             }
238             }
239              
240             sub cscript {
241             my $self = shift;
242             $self->_run('cscript', 's', 'pl'); # s = sequentially
243             }
244              
245             sub wscript {
246             my $self = shift;
247             $self->_run('wscript', 's', 'pl'); # s = sequentially
248             }
249              
250             sub ontop {
251             my $self = shift;
252             $self->_run('wscript', 's', 'tn'); # s = sequentially
253             }
254              
255             sub async_cscript {
256             my $self = shift;
257             $self->_run('cscript', 'a', 'ms'); # a = asynchronous
258             }
259              
260             sub async_wscript {
261             my $self = shift;
262             $self->_run('wscript', 'a', 'pl'); # a = asynchronous
263             }
264              
265             sub async_ontop {
266             my $self = shift;
267             $self->_run('wscript', 'a', 'tn'); # a = asynchronous
268             }
269              
270             sub func {
271             my $self = shift;
272             my $mname = shift;
273              
274             $self->{'func'}{$mname};
275             }
276              
277             sub flist {
278             my $self = shift;
279             my $sf = $self->{'func'};
280              
281             sort grep { $sf->{$_} } keys %$sf;
282             }
283              
284             1;
285              
286             __END__