#!/Perl
# FROM : http://www.roth.net/perl/scripts/scripts.asp?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.
#
#  Added output to LOG file, and increased the message output,
#  so a quiet review can be done, after the page has been CLOSED!
#  geoff mclane - mailto: geoffair@hotmail.com - 2006-06-14
##########################################################################

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

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

$HomePage = "http://www.roth.net/";             
##$HomePage = "http://geoffmclane.com/";             
##$HomePage = 'http://www.friendofflowers.com/';
##$HomePage = 'http://macpcfirstaid.com/';

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

# LOG FILE STUFF
my $write_log = 0;
my $outfile = "$0.txt";
my $LOG = new FileHandle ">$outfile"; 
##if ( open( $LOG, ">$outfile" ) ) {
if ($LOG) {
    $write_log = 1;
	select $LOG;
} else {
    $write_log = 0;
    prt( "WARNING: Unable to open $outfile LOG ...\n" );
}

prt("Finding active IE object ...\n");
$IE = Win32::OLE->GetActiveObject( $CLASS{ie} );
if( ! defined $IE )
{
    prt( "Can not find open $CLASS{ie} object. Creating one...\n" );
    $IE = Win32::OLE->new( $CLASS{ie}, "Quit" ) || mydie( "HEY Dude, can't do it!?!?\n" );    
} else {
	prt( "Using existing $CLASS{ie} object ...\n" );
}

prt("\nEstablishing an event callback ...\n");
#Win32::OLE->WithEvents( $IE, \&EventRoutine ); #, $CLASS{events2} );
Win32::OLE->WithEvents( $IE, \&EventRoutine, $CLASS{events} );

prt("\nSetting VISIBLE ...\n");
$IE->{Visible} = 1;
prt("\nSetting RegisterAsDropTarget ...\n"); 
$IE->{RegisterAsDropTarget} = 1;
prt("\nSetting RegisterAsBrowser ...\n"); 
$IE->{RegisterAsBrowser} = 1;
prt("\nNavigating to [$HomePage] ...\n");
$IE->Navigate( $HomePage );
prt("\nSpinning, while Busy ...\n");
while( $IE->{Busy} )
{
    Spin( $IE );
}
prt("\nOne more spin ...\n");
Spin( $IE );

prt("\nGetting MyDoc ...\n");
$MyDoc = $IE->{Document};

prt("\nEntering FOREVER loop ... exit is when browser quits ...\n");
$sCount = 0;
while( 1 )
{
	$sCount++;
    #if( 1000 < $iCount++ )
    if( $sCount > 1000 )
    {
        #$iCount = 0;
        $sCount = 0;
        sleep( 1 );
    }

    if( "Win32::OLE" eq ref $MyDoc )
    {
		Spin( $MyDoc );
     }
     Spin( $IE );
}

prt( "Finished.\n" );


sub Spin
{
    my( $Object ) = @_;
    while( $Object->SpinMessageLoop() )
    {
		# process all messages ...
    }
}

sub PrintUrl
{
    local( $U ) = @_;
    $~ = HrefFormat;
    write;
	#prt( "PrintUrl: $U \n" );
}

sub PrintDocUrl
{
    local( $U ) = @_;
    $~ = DocHrefFormat;
    write;
	#prt( "PrintDocUrl: $U \n" );
}


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


sub EventRoutine
{
    my( $Obj, $Event, @Args ) = @_;
  
    $iEventCount++;
	prt("Event $iEventCount: $Event\n");
	DumpValues( @Args );

    local( $EventDesc ) = $Event;
    $~ = EventFormat;
    if( "DownloadBegin" eq $Event )
    {
      write;
	  #	if ($write_log) { write $LOG; }
      my( $Doc ) = $Obj->{Document};
      my( $Url ) = $Doc->{Url};
      my( $ImageList ) = $Doc->{images};

      CleanImages( $Doc, $Url );
    }
    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 );
        }
        prt( "\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, $Url );
        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;
            }
        }
        prt( "\n" );
    }
    elsif( "OnQuit" eq $Event )
    {
        write;
        prt( "\nTerminating!\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 );
        prt( "\n" );
    }
    elsif( "NavigateComplete2" eq $Event )
    {
        my( $HtmlDoc ) = $Args[0]->{Document};

        prt( "Arg 0: " . Win32::OLE->QueryObjectType( $Args[0] ) . "\n" );
        prt( "Document: " . Win32::OLE->QueryObjectType( $HtmlDoc ) . "\n" );
        
        write;

        PrintUrl( $Args[1]->Value() );
        my $iCount = 0;
        
        prt( "Cookie:\n" );
        $Cookie = $HtmlDoc->{Cookie};
        $~ = "CookieFormat";
        write;

        prt( "Graphics:\n" );
        foreach my $Img ( in( $HtmlDoc->{images} ) )
        {
			$iCount++;
            prt( "$iCount ) [" . $Img->{src} . "] " );
            prt( "ObjectType [" . Win32::OLE->QueryObjectType( $Img ) . "]\n" );
            # Here you can swap out this graphic image using sytnax like: 
            # $Img->{src} = "c:\\images\\No-Ads-Allowed.gif";
			# or CLEAR the image with
            # $Img->{src} = "";
        }

		if ($iCount == 0) {
			prt("No images ...\n");
		}
    }

    #else
    #{
	#	### aready done at top ...
    #    ###DumpValues( @Args );
    #}

    return;
}

sub DumpValues
{
    my( @Args ) = @_;
	prt("Dump values ...\n");

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

sub WarningBeep
{
    prt( "&bullet;" );
}

sub CleanImages
{
  my( $Doc, $Url ) = @_;
  my( $ImageList ) = $Doc->{images};
  my $iCount = 0;
  my $type = ref $ImageList;
  prt( "CleanImages: type = [$type] ...\n" );
  #return unless( "Win32::OLE" eq ref $ImageList );
  if ($type eq "Win32::OLE") {
	  prt( "  Url: '$Url'\n" );
	  foreach my $Image ( in( $ImageList ) )
	  {
		  $iCount++;
		  prt( "$iCount ) " . $Image->{src} . "\n" );
		  ### $Image->{src} = ""; # if you want to NOT display the image
	  }
	  if ($iCount == 0) {
		  prt("No images in image list???\n");
	  } else {
		  prt("Cleared $iCount images ...\n");
	  }
  }
}

################################
### output and log file
sub wlog {
	my $ml = shift;
	print $LOG $ml;
}

sub prt {
	my $m = shift;
	if ($write_log) {
		wlog($m);
	}
	print STDOUT $m;
}

sub mydie {
	my $msg = shift;
	if ($write_log) {
		wlog($msg);
	}
	die $msg;
}

sub close_log {
	if ($write_log) {
		prt( "Closing LOG file, and passing to 'system($outfile)'\nMay need to CLOSE notepad to continue ...\n" );
		close( $LOG );
		system( $outfile );
	}
}

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
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
~            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
             $Url
.

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

format EventFormat =
EVENT: @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
       $EventDesc
.

# eof - autoie03.pl
