##
#!/usr/bin/perl -T
use strict;
use CGI;
my $cgi = CGI->new();
my $nodeid= $cgi->param('node');
if ($nodeid=~s/^(\d{6})$/$1/){}
else{nonode()}
open (my $fh,"<","../htdocs/perlmonks/$nodeid.xml") or nonode();
print $cgi->header(-type=>'text/xml');
while (<$fh>)
{
print $_
}
sub nonode
{
print $cgi->header,
$cgi->start_html,
"Error! No such node id $nodeid
",
$cgi->end_html;
die "";
}
##
##
#!/usr/bin/perl
use strict;
use warnings;
use LWP::UserAgent;
my $ua = LWP::UserAgent->new(agent=>"g0ns node grabber/0.01");
open (my $ln,"<","/home/charlesc/scripts/lastnode") or die $!;
my $lastnode = <$ln>;
chomp $lastnode;
close $ln;
#opendir(my $dh,"/srv/www/htdocs/perlmonks/");
#my @files = readdir($dh);
#closedir $dh;
#for (@files)
#{
# if ($_ eq "index.html"){$_=""}
# $_ =~s/\.xml//;
#}
#my @sortedfiles = sort {$a <=> $b} @files;
my $nextfile = ++$lastnode;
print "nextfile = $nextfile\n";
my $retrievednode;
my $end;
my $counter=0;
while (!$end)
{
if ($counter >=25){last} # just in case, don't take more than 25 in a run.
my $starttime = time();
my $url = "http://www.perlmonks.org/?displaytype=xml;node_id=$nextfile";
print "Searching $url\n";
my $req = HTTP::Request->new(GET=>$url);
my $result = $ua->request($req);
my $content;
my $endtime = time();
if ($result->is_success){$content= $result->content}
else {next}
if ($content =~/title="Not found"/ && $content =~/superdoc/)
{
$end++;
}
else
{
open (my $fh,">","/srv/www/htdocs/perlmonks/$nextfile.xml") or die "Can't open $nextfile.xml for writing because $!";
print $fh $content;
close $fh;
}
$retrievednode = $nextfile;
$nextfile++;
$counter++;
my $pause = 2*($endtime - $starttime)+1;
print "Sleeping for $pause seconds\n";
sleep $pause;
}
open ($ln,">","/home/charlesc/scripts/lastnode") or die $!;
print $ln --$retrievednode."\n";
close $ln;
##
##
############################################################################
# smallWindowWhenRecomposed.pl
############################################################################
# CColbourn 09-Oct-2007
############################################################################
use strict;
use warnings;
use Tk;
my $mw = MainWindow->new();
my $frame = $mw->Frame->pack();
populate();
$frame->Button(-command=>\&recompose)->pack();
MainLoop;
sub recompose
{
$frame->destroy();
$frame = $mw->Frame->pack;
}
sub populate
{
for (1..10)
{
$frame->Label(-text=>$_)->pack();
}
}
##
##
#!perl -w
use strict;
use warnings;
use CGI;
use Net::LDAP;
my $cgi = new CGI;
if (!$cgi->params){displayform}
else{lookup()}
sub displayform
{
print $cgi->header,
$cgi->start_html,
$cgi->start_multipart_form,
'',
'Enter Surname',
' ',
$cgi->textfield(-name=>'sn'),
' ',
'',
$cgi->submit,
'
',
$cgi->end_form,
$cgi->end_html;
}
sub lookup
{
print $cgi->header,
$cgi->start_html;
my $ad = Net::LDAP->new('127.0.0.1');
my $result = $ad->bind(dn=>'username',password=>'password');
if ($result->code)
{
die $result->error;
}
my $searchresult = $ad->search( filter => "(sn=".$cgi->param('sn').")",
basedn => "ou=container, dc=companyname,dc=net",
scope => "sub" );
if ($searchresult->code)
{
die $searchresult->error;
}
if ($searchresult->count == 0)
{
print "No matches";
}
else
{
for my $entry ($searchresult->entries)
{
print $entry->get('sn').", ".$entry->get('givenName')." - ".$entry->get('telephoneNumber')."
";
}
}
print $cgi->end_html;
}
##
##
my $scalar = ("one","two","three");
##
##
use strict;
# context test
my @array = qw (one two three);
my $scalar = returnfunc();
#my ($scalar) = @array;
my $otherscalar = ("one","two","three");
print "scalar = $scalar\n";
print "otherscalar = $otherscalar\n";
sub returnfunc
{
return @array;
}
##
##
use strict;
use warnings;
use Tk;
my $tk = Tk::MainWindow->new();
$tk->bind('Tk::MainWindow','',\&badger);
#print $tk->bind();
MainLoop();
sub badger
{
print "badger\n";
##
##
select u.usernae, u.realname from userdata where username in (select username from appointmentslot where appointment is null)
and u.mobdetailsid = m.id and m.deploymentmethod like 'IT assisted'
##
##
#first line of code
#second line of code
#third line of code
##
##
use strict;
use warnings;
my $o = overlord::baseclass->new(choice=>"delegate2");
$o->display("badger");
exit 0;
package overlord;
package overlord::baseclass;
sub new
{
my $self = shift;
my %obj = @_;
$obj{delegate} = "overlord::$obj{choice}"->new();
return bless \%obj,$self;
}
sub display
{
my $self = shift;
my $param = shift;
$self->{delegate}->display($param);
}
package overlord::delegate1;
sub new
{
my $self = shift;
my %obj;
return bless \%obj,$self;
}
sub display
{
my $self = shift;
my $param = shift;
print $param."\n";
}
package overlord::delegate2;
sub new
{
my $self = shift;
my %obj;
return bless \%obj,$self;
}
sub display
{
my $self = shift;
my $param = shift;
print "$param\n";
}
1;