Create and fill a two-dimensional array
An example which shows how to create a two-dimensional array in Perl, fill it with data, pass it around via return() and print the array output.
print $twodimensionalarray[0][0];
should not work anymore. You should use the syntax suggested below.
sub getsubdomains()
{
#Create an empty, two-dimensional array
my @subdomains = ( [], [] );
#Populate it, in this case from a MySQL SELECT query
while (my @sql_rows=$syssth->fetchrow_array)
{
${@subdomains}[$i][0]= $sql_rows[0];
${@subdomains}[$i][1]= $sql_rows[1];
$i++;
}
return @subdomains;
#Pass it to the function which needs it
}
sub new_postform()
{
#Retrieve our old array and save it
my @subdomains=getsubdomains();
my $html_subdomainselect='<select name="p_subdomain">';
#Populate an HTML <SELECT> Box with the data
for(my $i=0;$i<=$#subdomains;$i++)
{
$html_subdomainselect .= '<option value="'.${@subdomains}[$i][0].'">'.${@subdomains}[$i][1].'</option>';
}
$html_subdomainselect .= '</select>';
}
Basic Google Cache Parser
This script downloads the cached versions from a Google results page.
#!C:/Perl/bin/Perl
#replace first line with "#!/usr/bin/perl" on a Linux/Unix operating system.
##############################################
# BASIC GOOGLE CACHE PARSER #
# #
# topictracer.com #
# Creative Commons Attribution 2.5 License #
##############################################
require LWP::UserAgent;
my $ua = LWP::UserAgent->new(keep_alive => 1,
agent => 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1)',
timeout => 10);
#Google seems to block lwp-trivial, so we use a proper user agent
open(IN, "queryresults.html") or die("cannot open file - $!");
#open file which contains the results of a google search query (whole html page)
@lines=<IN>;
$text = join "\n", @lines;
#make scalar
@hrefs=($text =~ m|href\s*=\s*\"([^\"]+)\"|ig);
#regular expression match for any urls, save to array "hrefs"
$i = 1;
foreach $href (@hrefs) {
if ($href =~ m|search\?q=cache:|ig) #parse it if it's a Google cache link (basic check)
{
if (length($href)<70) { print $href; } else { print substr($href,0,67)."..."; }
#strip URL down in length to make the output look pretty
my $request = HTTP::Request->new(GET => $href);
my $response = $ua->request($request);
if ($response->is_success)
{
if(defined $response->content())
{
open(OUT, ">$i.html") or die("cannot write to file - $!");
print OUT $response->content();
close(OUT);
print " saved.\n";
#save content to new file 1.html, 2.html, etc.
}
}
}
$i++;
}
close(IN);
Online version check
This snippet realizes a quick version check. It may come handy when realizing actual Windows applications in Perl.
In its current form it requires threads, Win32, Win32::GUI, Win32::TieRegistry and LWP::Simple . If you decide against the use of one or more of these modules, the general idea remains the same:
You need to upload a file called "yourappversion.txt" which is a 1-liner containing the numeric number of the latest program version (eg. "0.1" or "1.4").
The code below checks for the latest version by downloading the version text file. If the program is outdated, it will open the download page in your Windows default browser and exit.
This should work for Firefox, Mozilla and Opera users in the same way.
#!C:/Perl/bin/Perl
use Win32::GUI;
use Win32 ();
use Win32::TieRegistry;
use LWP::Simple;
use threads;
use vars qw($version);
$version=0.02;
checkversion();
#topictracer.com
sub checkversion {
my $url = 'http://www.site.com/yourappversion.txt';
#yourappversion.txt contains your program version, eg. "1.2". nothing else to keep it simple.
my $document = get($url);
#receive version file
return unless defined $document;
#just give up and return if site is down or file cannot be found
chomp($document);
if ($document>$version) {
my $answer=Win32::GUI::MessageBox(0, "New version available: v$document", "Title",64);
#announce the availability of a new version in a Win32 pop-up messagebox
my $childproc = threads->new(\&openurl, 'http://site.com/yourapp'); $childproc->detach;
#call "openurl" with the URL of your application's download page
exit;
#we're not gentle and simply quit. something more graceful might be appropriate
}
}
sub openurl {
my $url = shift(@_);
#get passed-on URL
$browser= $Registry->{'HKEY_CLASSES_ROOT\\http\\shell\\open\\command\\\\'};
#get windows default browser for opening "HTTP files", ergo websites
system($browser . " " . $url);
#open website using the browser we found in our registry
}
ActivePerl: exec/system call in background
System() is tricky in a Windows environment.
There is usually no way to quickly launch a program from Perl, then continue with your code right away while the program is (still) running. Instead, Your Perl script will stop as soon as you start an external program.
This is because system() waits for the child process (your external program) to exit before going on. On Linux command line, this makes perfect sense, but what if you need to run a Windows program with a GUI in the background to work with?
#!C:/Perl/bin/perl
#definition of the program to launch in background
$gamelaunch='D:\Games\HoMM\HoMM.exe';
#preparation of our external "Perl.exe" call.
$gamelaunch='perl -e "exec(\''.$gamelaunch.'\')"';
print "Starting Program\n";
system($gamelaunch);
#actual program start
#normally the script would be locked up now
print "It's magic";
sleep(30);
Take screenshots of websites (Internet Explorer)
A perl snippet I just found in my archive. Running with (Active)Perl under Windows, it enables you to take website screenshots. This is achieved by starting Internet Explorer, simulating a "print screen" press and printing the output to a bitmap file.
I cannot verify the integrity of the script but it should work just fine.
#!C:/Perl/bin/Perl -w
use Win32::OLE;
use Win32::API;
use Win32::Clipboard;
use Win32::InternetExplorer::Window;
my $key = new Win32::API("user32", "keybd_event", 'IINP', 'V');
#create new virtual keyboard keycode hook
die "Can't import user32.dll: $!\n" if(not defined $key);
#die if unable to reach user32.dll
my $clip = Win32::Clipboard();
#create new clipboard object
my $browser = Win32::OLE->new('InternetExplorer.Application') or die "Failed to start \n";
#load internet explorer
$browser->Navigate('http://turbo10.com',1,'_BLANK');
#browse to website specified
sleep(4); #wait 4 seconds...dirty hack
#$browser->{'Visible'} = 1;
#disabled because we assume a non-busy system with only IE being active
# empty the clipboard
$clip->Empty();
# press the key!!
$key->Call(0x2C, 0x45, 0x01, 0);
#simulate a "printscrn" key press
$key->Call(0x2C, 0x45, 0x03, 0);
# & release
# wait for the image to fill the clipboard
$clip->WaitForChange();
#get the actual image from clipboard
my $image = $clip->GetBitmap();
open (BITMAP, ">test.bmp");
binmode BITMAP;
#enable binary mode for incoming image
print BITMAP $image;
#print image to bitmap file
close(BITMAP);
# my $browser = Win32::InternetExplorer::Window->new(height => 600,
# width => 600,
# pos => [10,0],
# #no_popups => 1,
# #start_hidden => 1
# );
# $browser->display('http://www.aol.com');
# sleep(2);
# $browser->refresh_wait();
# sleep(2);
# system('import -window root image.jpg');
# $browser->stop();
Perl proxy leecher
This is probably the worst hack ever. I received this from an Austrian freelancer programmer in Spring 2006 and is pretty much unreadable if you don't know how HTML::Parser works. The script itself works, but is very slow.
It has full cookie and referrer spoofing support to leech on sites using one of these methods for protection. It might be a good start if you ever wanted to go through all those proxy leech sites automatically. You can use its source code to build a faster proxy leecher.
#!C:/Perl/bin/Perl -w
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;
use HTTP::Cookies;
use HTML::Parser 3.00 ();
my @sitelist = ("http://www.proxy4free.com",
"http://www.samair.ru/proxy/",
"http://www.proxylist.com.ru/",
"http://publicproxyservers.com",
"http://www.proxyleech.com/proxylist.txt",
"http://www.proxy4free.com/page1.html",
"http://proxyz.net/index.php?menu=anonproxys",
"http://www.publicproxyservers.com/page1.html",
"http://www.anonymitychecker.com",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-2/",
"http://www.anonymitychecker.com/page1.html",
"http://www.publicproxyservers.com/page3.html",
"http://www.proxy4free.com/page2.html",
"http://www.my-proxy.com/list/index.php?list=s1",
"http://proxyz.net/index.php?menu=anonproxys&page=5",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-4/",
"http://www.my-proxy.com/list/index.php?list=1",
"http://www.samair.ru/proxy/proxy-02.htm",
"http://www.freeproxylists.com/rss",
"http://proxyz.net/index.php?menu=anonproxys&page=2",
"http://www.proxy4free.com/page4.html",
"http://www.cybersyndrome.net/pla3.html",
"http://www.anonymitychecker.com/page4.html",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-3/",
"http://www.publicproxyservers.com/page2.html",
"http://free-proxy-servers.com/free_proxies.php",
"http://www.my-proxy.com/list/index.php?list=2",
"http://www.anonymitychecker.com/page2.html",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-5/",
"http://www.proxyforest.com/proxy.htm",
"http://www.anonymitychecker.com/page5.html",
"http://www.publicproxyservers.com/page5.html",
"http://www.my-proxy.com/list/index.php?list=s2",
"http://www.proxy4free.com/page3.html",
"http://proxyz.net/index.php?menu=anonproxys&page=3",
"http://www.my-proxy.com/list/index.php?list=3",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-1/",
"http://www.anonymitychecker.com/page6.html",
"http://www.steganos.com/?area=updateproxylist",
"http://www.anonymitychecker.com/page3.html",
"http://www.publicproxyservers.com/page4.html",
"http://www.proxy4free.com/page5.html",
"http://proxyz.net/index.php?menu=anonproxys&page=4",
"http://eliteproxy.us/proxy.php",
"http://theone.ru/proxy/",
"http://proxy.mazafaka.ru/",
"http://proxy.mazafaka.ru/?c=all&t=all&m=5&checked=y",
"http://nntime.com/",
"http://nntime.com/index.php?start=51",
"http://nntime.com/index.php?start=101",
"http://nntime.com/index.php?start=151",
"http://nntime.com/index.php?start=201",
"http://www.freeproxy.ru/",
"http://www.freeproxy.ru/en/free_proxy/get.htm",
"http://www.freeproxy.ru/download/lists/goodproxy.txt",
"http://www.digitalcybersoft.com/ProxyList/",
"http://www.digitalcybersoft.com/ProxyList/fresh-proxy-list.shtml",
"http://www.digitalcybersoft.com/ProxyList/fresh-proxy-list.shtml?L3");
my @refererlist = ("http://www.proxy4free.com",
"http://www.samair.ru/proxy/",
"http://www.proxylist.com.ru/",
"http://publicproxyservers.com",
"http://www.proxyleech.com",
"http://www.proxy4free.com/page1.html",
"http://proxyz.net/",
"http://www.publicproxyservers.com/",
"http://www.anonymitychecker.com",
"http://www.proxylist.com.ru/",
"http://www.anonymitychecker.com",
"http://www.publicproxyservers.com/",
"http://www.proxy4free.com/",
"http://www.my-proxy.com/",
"http://proxyz.net/index.php",
"http://www.proxylist.com.ru/",
"http://www.my-proxy.com/",
"http://www.samair.ru/proxy/",
"http://www.freeproxylists.com/",
"http://proxyz.net/index.php",
"http://www.proxy4free.com",
"http://www.cybersyndrome.net",
"http://www.anonymitychecker.com",
"http://www.proxylist.com.ru",
"http://www.publicproxyservers.com",
"http://free-proxy-servers.com",
"http://www.my-proxy.com/",
"http://www.anonymitychecker.com/",
"http://www.proxylist.com.ru/proxy-server/",
"http://www.proxyforest.com/",
"http://www.anonymitychecker.com/",
"http://www.publicproxyservers.com//",
"http://www.my-proxy.com/list/index.php",
"http://www.proxy4free.com/page3.html",
"http://proxyz.net/index.php?menu=anonproxys&page=3",
"http://www.my-proxy.com/list/index.php?list=3",
"http://www.proxylist.com.ru/proxy-server/anonymous-proxy-1-5/",
"http://www.anonymitychecker.com/page4.html",
"http://www.steganos.com/",
"http://www.anonymitychecker.com/page1.html",
"http://www.publicproxyservers.com/page2.html",
"http://www.proxy4free.com/page2.html",
"http://proxyz.net/index.php?menu=anonproxys&page=2",
"http://eliteproxy.us/proxy.php",
"http://theone.ru/",
"http://theone.ru",
"http://proxy.mazafaka.ru/",
"http://nntime.com/",
"http://nntime.com/",
"http://nntime.com/",
"http://nntime.com/",
"http://nntime.com/",
"http://www.freeproxy.ru/",
"http://www.freeproxy.ru/en/free_proxy/get.htm",
"http://www.freeproxy.ru/download/lists/goodproxy.txt",
"http://www.digitalcybersoft.com/",
"http://www.digitalcybersoft.com/ProxyList/",
"http://www.digitalcybersoft.com/ProxyList/fresh-proxy-list.shtml");
my $target = "C:/Programme/Apache Group/Apache2/htdocs/proxy/proxy.html";
my $rip = "C:/Programme/Apache Group/Apache2/htdocs/proxy/list.html";
my $final ="C:/Programme/Apache Group/Apache2/htdocs/proxy/final.txt";
my %inside;
print "Content-type: text/html\n\n";
# Instanciate
my $request = HTTP::Request->new(GET => $url);
my $cookie_jar = HTTP::Cookies->new;
my $client = LWP::UserAgent->new();
$client->agent('Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; iOpus-I-M; .NET CLR 1.1.4322)');
$client->cookie_jar($cookie_jar);
$client->timeout('20');
open (FINAL, ">$final") or die "cant open file $final";
print FINAL "";
close(FINAL);
my $arrayprogress=0;
foreach $page (@sitelist){
$request = HTTP::Request->new(GET => $page);
$request->referer($refererlist[$arrayprogress]);
#my $hash = $client->get($page);
my $hash = $client->request($request);
my $content= $hash->content();
$cookie_jar->extract_cookies($response);
print $cookie_jar->as_string,"<br>\n";
unless ($hash->is_error())
{
open (TARGET, ">$target") or die "cant open file $target";
print TARGET $content;
close(TARGET);
}
open (RIP, ">$rip") or die "cant open file $rip";
HTML::Parser->new(api_version => 3,
handlers => [start => [\&tag, "tagname, '+1'"],
end => [\&tag, "tagname, '-1'"],
text => [\&text, "dtext"],
],
marked_sections => 1,
)->parse_file($target) || die "Can't open file: $!\n";;
close(RIP);
##############################################################################
# open file
open(F,"$rip") or die("$!\n");
# read data
$data = join("", <F>);
# remove comments
close(F);
$data =~ s/#.*$//gm;
# match pairs IP and PORT, it's pretty strict one, not greedy
@matches = ($data =~ /(\d+\.\d+\.\d+\.\d+)[\n\r\s\:]+(\d+)[\n\r\s\:]+/sg);
open (RIP, ">>$final") or die "cant open file $final";
# print them out
while(@matches) {
my $ip=shift(@matches);
my $port=shift(@matches);
print RIP $ip.":".$port."\n";
}
close(RIP);
$arrayprogress++;
}
sub tag
{
my($tag, $num) = @_;
$inside{$tag} += $num;
print " "; # not for all tags
}
sub text
{
return if $inside{script} || $inside{style};
print RIP $_[0];
}
Proxy List script
This script is a fully automatic proxy list checker in Perl.
It reads from a file called unchecked.txt which contains unverified proxies in <IP>:<port> format, one per line.
Proxies are verified against Google.co.uk, the British Google site. If the test is successful, the proxy is added to checked.txt in the same format.
The script is not multithreaded, so it will be slower than programs like Charon which use multiple threads. On the other hand, it is very easy on the server resources so you may even use it on a shared webserver or small hosting plan. It just required the LWP::UserAgent module which is available on most servers. 5 proxy list sites were built around this script so far.
#!/usr/bin/perl -w
require LWP::UserAgent;
use CGI::Carp qw( fatalsToBrowser );
my $proxystatus=0;
print "Content-type:text/html\n\n";
$INFILE = "/var/www/vhosts/myvhost/cgi-bin/unchecked.txt";
open(INFILE) or die("Could not open IN file.");
open(OUTFILE,">/var/www/vhosts/myvhost/cgi-bin/checked.txt") or die ("Could not open OUT file");
print OUTFILE "";
close(OUTFILE);
foreach $proxy (<INFILE>) {
chomp($proxy);
$proxystatus = &testproxy($proxy);
if ($proxystatus==1)
{
open(OUTFILE,">>/var/www/vhosts/myvhost/cgi-bin/checked.txt") or die ("Could not open OUT file");
print OUTFILE $proxy."\n";
print "proxy ".$proxy." is ok!\n";
}
else
{
print "proxy ".$proxy." is bad!\n";
}
}
close(INFILE);
close(OUTFILE);
sub testproxy
{
my ($proxy) = shift (@_);
$proxy='http://'.$proxy.'/';
my $ua = LWP::UserAgent->new;
$ua->timeout(14);
$ua->agent('Mozilla/5.0');
$ua->proxy(['http', 'ftp'], $proxy);
my $response = $ua->get('http://www.google.co.uk/');
if ($response->is_success) {
#print $response->content; # or whatever
if ($response->content =~ m/Google/)
{
return 1;
}
else
{
return 0;
}
}
else
{
return 0;
}
}
IP-Updater / DynDNS script via Perl
For years and years, I've been using the dynamic DNS service at DynDNS.net to make my home machine accessible on the web via a static hostname. DynDNS even supplies you with a script to update DNS records on-the-fly without some nasty third party programs being required. This especially made sense for me because I am using the DynDNS updater on my Linux server, thus no windows taskbar stuff would have worked anyway.
This Perl script realizes a simple solution to make DynDNS on-the-fly updates possible. It also features a logging mechanism which prints all IP changes to a file.
This is a part of my log file which is running since 2004:
2006-01-06, 10:36:01 => IP changed to 217.225.225.69
2006-01-07, 05:39:01 => IP changed to 217.225.227.96
2006-01-07, 12:01:01 => IP changed to 217.81.240.219
2006-01-07, 14:32:01 => IP changed to 62.226.70.222
2006-01-07, 16:31:01 => IP changed to 217.225.225.59
2006-01-08, 05:39:01 => IP changed to 217.225.233.78
2006-01-08, 06:55:01 => IP changed to 62.226.65.25
2006-01-09, 05:39:01 => IP changed to 217.225.226.211
2006-01-09, 07:22:01 => IP changed to 62.226.77.73
2006-01-09, 22:58:01 => IP changed to 84.135.204.180
2006-01-10, 03:59:01 => IP changed to 62.226.71.54
The actual updates are done via my updatedns.pl:
#!/usr/bin/perl
use LWP::Simple;
my $page = "http://www.whatismyip.com";
my $dnspage = http://www.dynup.net/update/java.php3?hostname=myhostname&password=mypassword;
my $ipfilepath ="/srv/www/htdocs/ipdaemon/ip.txt";
my $updatefilepath ="/srv/www/htdocs/ipdaemon/ipupdates.txt";
$begincut = "<TITLE>WhatIsMyIP.com - ";
$endcut = "</TITLE>";
$_ = get($page);
s/^.*$begincut//is;
s/$endcut.*$//is;
open( FILE, "<$ipfilepath" );
my $oldip = <FILE>;
close FILE;
if ($_ ne $oldip)
{
my $update = get($dnspage);
if($update =~ m/complete/i)
{
my ($sec,$min,$hour,$mday,$mon,$year) = localtime(time);
$mon++;
$year+=1900;
if ($mon < 10) { $mon = "0" . $mon; }
if ($mday < 10) { $mday ="0" . $mday; }
if ($sec < 10) { $sec ="0" . $sec; }
if ($min < 10) { $min ="0" . $min; }
if ($hour < 10) { $hour ="0" . $hour; }
open( FILE, ">$ipfilepath" );
print FILE $_;
close FILE;
open( UPDATE, ">>$updatefilepath" );
print UPDATE $year . "-" . $mon . "-" . $mday . ", " . $hour . ":" . $min . ":" . $sec . " => IP changed to " . $_ . "\n";
close UPDATE;
print "update complete";
}
}
What this does is grab my external IP address from a third party website which is rock solid (WhatIsMyIp.com) and print it to my "IP file", if the IP has changed since the last call. The "IP file" just contains my current IP, nothing more. If the IP has changed indeed, I call the DynDNS.net update script which contains my hostname and my password to trigger the DNS update process. In the last step, we update the IP log to reflect the latest change. On my machine, I call the script regularly via a cronjob.
The DynDNS log file makes sense if you want to keep track of your IP changes for various reasons. In my case, I often had problems with a flaky connection until I complained to my ISP and supplied them with the actual timestamps of IP changes to prove the problem to them.
Can't modify constant item in scalar assignment
The code?
sessionname="A";
What did the apache error log say?
[error] [client 127.0.0.1] Can't modify constant item in scalar assignment at C:/Programme/Apache Group/Apache2/cgi-bin/reporting/session.cgi line 7, near ");"\r
This Perl error is one of the most occuring ones when debugging a Perl script. Especially when you are also used to work with a language which supports declaring variables without a leading dollar, the source of this problem might not even be obvious to you.
Add a dollar sign before your scalar variables in Perl!
