sub AUTOLOAD { our $AUTOLOAD; my $meth = $AUTOLOAD; $meth =~ s/.*:://; my $class = ref($_[0]) || $_[0] || die "object method only"; no strict; *{"${class}::${meth}"} = my $newsub = sub { my $self = shift; $self->{$meth} = shift if @_; return $self->{$meth}; }; goto &$newsub; } #### #!/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;