Roth Consulting Perl Script: IEEvents.pl

##########################################################################
#
#  IEEvents.pl
#  Internet Explorer event trapping script
#
#  Copyright © 2000-2001 by Dave Roth
#  Courtesy of Roth Consulting
#  http://www.roth.net/
#
#  This file may be copied or modified only under the terms of either
#  the Artistic License or the GNU General Public License, which may
#  be found in the Perl 5.0 source kit.
#
#  2000.05.16
#
#  Demonstration of COM events in Win32 Perl.
#  This script kicks up an Internet Explorer window
#  and connects to a web site. The script displays any
#  cookie that is associated with the downloaded page.
#
##########################################################################

use vars qw( $VERSION );
use Win32::OLE qw( EVENTS in with valof );
use Win32::OLE::Variant;

Win32::OLE->Option( Warn => 0 );
$VERSION = 20000516;

$HomePage = "http://www.roth.net/";             

@BLOCKED_URLS = qw(
    doubleclick.net
);
             
%CLASS = (
    events  =>  'DWebBrowserEvents2',
    events2 =>  'IShellWindows',
    ie      =>  'InternetExplorer.Application',
);

$IE = Win32::OLE->GetActiveObject( $CLASS{ie} );
if( ! defined $IE )
{
    print "Can not find open $CLASS{ie} object. Creating one...\n";
    $IE = Win32::OLE->new( $CLASS{ie}, "Quit" ) || die "Dude, can't do it!";    
}

#Win32::OLE->WithEvents( $IE, \&EventRoutine ); #, $CLASS{events2} );
Win32::OLE->WithEvents( $IE, \&EventRoutine, $CLASS{events} );

$IE->{Visible} = 1;
$IE->{RegisterAsDropTarget} = 1;
$IE->{RegisterAsBrowser} = 1;


$IE->Navigate( $HomePage );
while( $IE->{Busy} )
{
    Spin( $IE );
}


Spin( $IE );

$Doc = $IE->{Document};
           
while( 1 )
{
    if( 1000 < $iCount++ )
    {
        $iCount = 0;
        sleep( 1 );
    }
    if( "Win32::OLE" eq ref $MyDoc )
    {
      Spin( $MyDoc );
     }
     Spin( $IE );
}

print "Finished.\n";


sub Spin
{
    my( $Object ) = @_;
    while( $Object->SpinMessageLoop() )
    {
    }
}

sub PrintUrl
{
    local( $Url ) = @_;
    $~ = HrefFormat;
    write;
}

sub PrintDocUrl
{
    local( $Url ) = @_;
    $~ = DocHrefFormat;
    write;
}


sub DocEvents
{
    my( $Obj, $Event, @Args ) = @_;
    print "******\nDocument event: $Event\n*******\n";
    return;
}


sub EventRoutine
{
    my( $Obj, $Event, @Args ) = @_;
  
    $iEventCount++;
    local( $EventDesc ) = $Event;
    $~ = EventFormat;
    if( "DownloadBegin" eq $Event )
    {
      write;
      my( $Doc ) = $Obj->{Document};
      my( $Url ) = $Doc->{Url};
      my( $ImageList ) = $Doc->{images};

      CleanImages( $Doc );
    }
    elsif( "DocumentComplete" eq $Event )
    {
        my( $Url ) = $Args[1]->Value();

        # ONLY display info if $Url is not "". Otherwise the document
        # download may have been canceled so there is nothing to display.
        if( ( "" ne $Url ) && ( "" ne $Obj->{Document}->{Cookie} ) )
        {
            my @Values = split( /;\s*/ , $Obj->{Document}->{Cookie} );
            local $Cookie;
            
            write;

            # Print URL
            PrintUrl( $Url );

            $~ = CookieFormat;
            map
            {
                ( $Cookie = $_ ) =~ s/%(\w\w)/pack( "c", hex( $1 ) )/gei;
                write;
            } ( @Values );
        }
        print "\n";
    }
    elsif( "BeforeNavigate2" eq $Event )
    {
        # We are about to download a page. Check to see if it is
        # allowed...
        local( $Url, $Message );
        $Url = lc $Args[1]->Value();

        my( $Doc ) = $Args[0]->{Document};


        write;
        CleanImages( $Doc );
        PrintUrl( $Url );
        foreach my $BlockedUrl ( @BLOCKED_URLS )
        {
            if( $Url =~ m@$BlockedUrl@i )
            {
                # Oops we have a blocked url so let's go and
                # cancel this request!
                $Message = "This URL is blocked. Cancelling the request!";

                $~ = WarningFormat;
                write;
                WarningBeep();

                $Args[6]->Put( 1 );
                last;
            }
        }
        print "\n";
    }
    elsif( "OnQuit" eq $Event )
    {
        write;

        print "Terminating!\n";
        undef $Obj;
        exit( 1 );   
    }
    elsif( "NewWindow2" eq $Event )
    {
        local( $Message ) = $Message = "A new browser window is requested. Cancelling the request!";

        write;

        PrintUrl( $Args[1]->Value() );

        $~ = WarningFormat;
        write;

        # Don't allow any new child windows
        $Args[1]->Put( 1 );
        print "\n";
    }
    elsif( "NavigateComplete2" eq $Event )
    {
        my( $HtmlDoc ) = $Args[0]->{Document};

        print "Arg 0: " . Win32::OLE->QueryObjectType( $Args[0] ) . "\n";
        print "Document: " . Win32::OLE->QueryObjectType( $HtmlDoc ) . "\n";
        
        write;
        PrintUrl( $Args[1]->Value() );
        my $iCount = 1;
        
        print "Cookie:\n";
        $Cookie = $HtmlDoc->{Cookie};
        $~ = "CookieFormat";
        write;

        print "Graphics:\n";
        foreach my $Img ( in( $HtmlDoc->{images} ) )
        {
            print $iCount++, ") $Img->{src}\n";
            print "" . Win32::OLE->QueryObjectType( $Img ) . ": ";
            # Here you can swap out this graphic image using sytnax like: 
            # $Img->{src} = "c:\\images\\No-Ads-Allowed.gif";
            $Img->{src} = "";
        }
    }
    else
    {
#        DumpValues( @Args );
    }
    return;
}

sub DumpValues
{
    my( @Args ) = @_;

    if( scalar @Args )
    {
        my $iCount = 0;
        foreach my $Arg ( @Args )
        {
            $iCount++;
            print "    Argument $iCount) ";
            if(  "Win32::OLE" eq ref $Arg )
            {
                print "< " . Win32::OLE->QueryObjectType( $Arg ) . " >";
            }
            elsif( "Win32::OLE::Variant" eq ref $Arg )
            {
                print "< Variant > ( " . $Arg->Value() . " )";
            }
            else
            {
                print "'$Arg'";
            }
            print "\n";
        }
    }
    print "\n";
}

sub WarningBeep
{
    print "•";
}

sub CleanImages
{
  my( $Doc ) = @_;
  my( $ImageList ) = $Doc->{images};
  my $iCount = 0;
  
  return unless( "Win32::OLE" eq ref $ImageList );
  print "  Url: '$Url'\n";
  foreach my $Image ( in( $ImageList ) )
  {
    print "  ", ++$iCount, ") $Image->{src}\n";
    $Image->{src} = "";
  }
}

format CookieFormat =
       COOKIE: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
~              ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
               $Cookie
.

format WarningFormat =
       WARNING: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
                $Message
.

format HrefFormat =
       Href: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
.

format DocHrefFormat =
       Page: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
.

format EventFormat =
EVENT: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
       $EventDesc
.
	Are you searching for a children's bike trailer?
	Would you like to try growing an avocado plant?
	Easily lose weight by increasing your metabolism.
	What, exactly, is a Calorie?
	Want to know about schooling your child using the Montessori method.
`Name:`	`IEEvents.pl`
`Version:`	`20000516`
`Last Updated:`	`2002.02.15`
`Author:`	`Dave Roth`
`Description:`	`Trap IE's events to prevent advertisements and popup windows.`
`Explanation:`	`This script is not pretty but it is designed to demonstrate the use of Win32::OLE events and the Internet Explorer object model. The script will instantiate an IE window and trap all events that occur. The script will block access to downloads from the sites listed in the @BLOCKED_URLS array. This can be configured to prevent advertising from sites you don't want to access. If a web page causes a new window to popup the script will fail the request. This kills pop-up and pop-under ads.`
Perl Script: IEEvents.pl

The IEEvents.pl Script:
