File Coverage

blib/lib/Inline/WSC.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Inline::WSC;

use strict;
use warnings;
use Win32::OLE;
use Digest::MD5 'md5_hex';

our $VERSION      = 0.02;
my $WSC_DIR      = $ENV{TMP} || $ENV{TEMP} || 'C:\Windows\Temp';
die "Temporary directory '$WSC_DIR' does not exist" unless -d $WSC_DIR;
die "Temporary directory '$WSC_DIR' is not writable" unless -w $WSC_DIR;
our $WSC_PREFIX   = 'InlineWin32COM.WSC';
my @ToDelete      = ();
my %MethodMapping = ();

#==============================================================================
# Called when this module is 'use'd:
sub import
{
  my ($s, $language, $code) = @_;
  return unless
    ( defined($language) && defined($code) ) &&
    ( length($language) && length($code) );
  my $caller = caller;
  my @methods = $s->_init( $language, $code );
  $s->_export_methods( $caller, \@methods );
}# end import()


#==============================================================================
# Alias to import:
*compile = \&import;


#==============================================================================
# Writes the *.wsc file to disk:
sub _init
{
  my ($s, $language, $code) = @_;

  my $md5       = md5_hex($code);
  my $classname = "$WSC_PREFIX\_$md5.wsc";
  my @methods   = $s->_get_method_names( $code );

  # Die when we encounter function redefinitions:
  foreach( @methods )
  {
    die "Method '$_' was already defined in file '$MethodMapping{$_}'"
      if $MethodMapping{$_};
    $MethodMapping{$_} = $classname;
  }# end foreach()

  my $wsc_code = $s->_make_wsc_code( $language, $code, $classname, \@methods );
  my $filename = "$WSC_DIR\\$classname";
  push @ToDelete, $filename;
  open my $ofh, '>', $filename;
  print $ofh $wsc_code;
  close($ofh);

  return @methods;
}# end _init()


#==============================================================================
# Assembles the *.wsc code:
sub _make_wsc_code
{
  my ($s, $language, $code, $classname, $methods) = @_;

  my $methodcode = join("\n",
    map qq{}, @$methods
  );

  return <<"EOF";



                description = "Inline::WSC Class"
                progid = "$classname"
                version = "1.0"
        >


$methodcode


        
 </td>
</tr>

<tr>
<td  class="h" >
<a name="89">89</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> <![CDATA[
 </td>
</tr>

<tr>
<td  class="h" >
<a name="90">90</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> $code
 </td>
</tr>

<tr>
<td  class="h" >
<a name="91">91</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> ]]>
 </td>
</tr>

<tr>
<td  class="h" >
<a name="92">92</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">

EOF
}# end _make_wsc_code()


#==============================================================================
# Scans the code for declarations of functions and subs.
sub _get_method_names
{
  my ($s, $code) = @_;
  my @out = ();
  FUNC: while($code =~ m/\s*(function|sub)\s+([a-z0-9_]+)\s*(?:\(.*?\))?/isgx)
  {
    local $^W = 0;
    push @out, $2;
  }# end while()
  return @out;
}# end _get_method_names()


#==============================================================================
# Pollute the caller's namespace with the methods defined in the various code
# fragments we were passed.
sub _export_methods
{
  my ($s, $caller, $methods) = @_;
  no strict 'refs';
  foreach my $method ( @$methods )
  {
    my $WscClass = $MethodMapping{$method};
    my $ob = Win32::OLE->GetObject("script:$WSC_DIR\\$WscClass")
      or die "Couldn't create OLE '$WscClass':\n" . Win32::GetLastError . " ";
    # The sub exists as a closure - saves us the call to GetObject() every time
    # the method is called:
    *{"$caller\::$method"} = sub {
      return $ob->$method(@_);
    };
  }# end foreach()
}# end _export_methods()

1;# return true:

__END__