g0n's scratchpad

Public Scratchpad

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;
}
[download]

Corion

Additional, the cgi script I was using for choosing a page:

#!/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,
        "<h1>Error! No such node id $nodeid</h1>",
        $cgi->end_html;
        die "";
}
[download]

The notorious node grabber - I've been meaning to put it back on line for ages, but the friend who promised server space keeps saying 'soon, soon' and never quite doing anything.


#!/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 i
+n a run.

    my $starttime = time();
    my $url = "http://www.perlmonks.org/?displaytype=xml;node_id=$next
+file";

        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;
[download]

######################################################################
+######
# 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();
    }
}
[download]

davis

#!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,
    '<table><tr><td>',
    'Enter Surname',
    '</td><td>',
    $cgi->textfield(-name=>'sn'),
    '</td></tr>',
    '<tr><td>',
    $cgi->submit,
    '</td></tr></table>',
    $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->pa
+ram('sn').")",
                    basedn    =>    "ou=container, dc=companyname,dc=n
+et",
                    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')."<br>";
        }
    }

    print $cgi->end_html;
}
[download]

I'm trying to modify a logging class so that when log() is called in list context it returns the list of errors encountered, and in scalar context, returns the last error encountered. p72 of the 3rd Ed Camel says that:

my $scalar = ("one","two","three");
[download]

sets $scalar to "three", and sho nuff it does. I'm trying to get the same behaviour from a returned array. Here's the test I've been fiddling with:

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;
}
[download]

any ideas?

marto - to get a sub to run on creation of MainWindow. This works (but you have to wait a second or so after MainWindow appears - MainLoop is sloooow....

use strict;
use warnings;
use Tk;

my $tk = Tk::MainWindow->new();

$tk->bind('Tk::MainWindow','<Enter>',\&badger);
#print $tk->bind();
MainLoop();

sub badger
{
    print "badger\n";
[download]

virtualsues query

select u.usernae, u.realname from userdata where username in (select u
+sername from appointmentslot where appointment is null)
 and u.mobdetailsid = m.id and m.deploymentmethod like 'IT assisted'
[download]

Troll detector

Many people have commented on what appears to be an increase in trolling lately. Blacklisting of certain IPs or detecting where an IP is used for both logged in users and AM might cut things down a bit, but doesn't take into account dynamic IP allocation, or NAT.

As an alternative, might I suggest a cookie containing a list of postings made (or last 30 perhaps). On arrival at the site, these could be compared with a list of reaped nodes, and if more than a certain number have been reaped (or a pmdev/god has marked the node as 'troll') anonymous posting could be prevented.

Of course, that wouldn't help with users that favour 'cookie cutters', or users that knew this was done, but it might cut down the 'drive by' trolling somewhat.

Not being a pmdev, I don't know how much work this would entail, but if the Powers That Be were in favour, I'd be happy to work on it.

add: perhaps not prevent posting, but it might be useful to have the information

Message for l.frankline

When you use < code> tags, you seem to use them like this:

< code>#first line of code < /code>< br>
< code>#second line of code < /code>< br>
< code>#third line of code < /code>< br>

and the result is:

#first line of code
#second line of code
#third line of code

Instead, try using them like this:

< code>
#first line of code
#second line of code
#third line of code
< /code>

And you'll get:

#first line of code
#second line of code
#third line of code
[download]

If you use < code> tags that way, you don't need to put in < br> & < code> tags on each line, and readers can click the 'download' link to download your code easily :-)

There once was a wizard from the netherlands, who cast mighty spells with his clever hands, His lightning was fun, his brooms they would run, Of his spells all the monks they were ever fans....

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 "<b>$param</b>\n";
}

1;
[download]