Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"

Cheesy Webring

by OeufMayo (Curate)
on Aug 20, 2001 at 20:26 UTC ( #106258=sourcecode: print w/replies, xml ) Need Help??
Category: Cheesy Web Stuff
Author/Contact Info Briac 'Cheesy' Pilpré - briac (at cheese) pilpre (dot cheese) com

Don't blame me, ar0n had the idea first.

But nonetheless, it's a fully functional webring.
You too can make your own and impress your friends, by showing them how many people share you love of Cheesy things.

Big thanks to virtualsue for hosting the Cheese Ring! (see node below)

update: Eradicated a couple of bugs that prevented the code to compile. oops.

update - Thu Aug 23 07:47:26 2001 GMT: The truncate filehandle was not right, but virtualsue spotted it!

update - Sun Aug 26 13:32:41 2001 GMT: Fixed the check for, thanks crazyinsomniac!

Sat Sep 22 21:35:45 UTC 2001: Fixed the encoding of characters other than 0-9a-zA-Z.

#!/usr/local/bin/perl -Tw
use strict;
use CGI qw(:standard);

my $cheese_pic = '';
my $url        = url();

my $start     = param('start') || 'CheeseLord';
my $go        = param('go') || 'next';
my $referer   = referer() || '';
my $tld       = $referer =~ m[perlmonks\.([^/]+)/] ? $1 : 'org';
my $perlmonks = 'http://'.(($referer =~ m|www\.p|i)?'www.':'')."perlmo
my $list      = 'cheese.list';

sysopen( LIST, $list, 0 ) or die "Cannot open '$list': $!\n";

# do we need flocking here?
chomp( my @ring = <LIST> );
close LIST;

my ( $start_index, $loc );
foreach ( 0 .. $#ring ) {
    if ( $ring[$_] eq $start ) { $start_index = $_; last }

my %dispatch = (
    'first'    => sub { $ring[0] },
    'last'     => sub { $ring[-1] },
    'next'     => sub { cycle(1) },
    'previous' => sub { cycle(-1) },
    'next5'    => sub { cycle(5) },
    'prev5'    => sub { cycle(-5) },
    'random'   => sub { $ring[ rand @ring ] },
    'list'     => sub { list() },
    'add'      => sub { add($start) },

$go  = 'next' unless exists $dispatch{$go};
$loc = &{ $dispatch{$go} } || $ring[0];
$loc =~ s/([\W_])/sprintf('%%%02X', $1)/eg; # [\W_] suggested by Chees
print redirect( $perlmonks . '/' . $loc );


sub list {
    my @urls =
      map {
    my $name = $_; 
        s/([\W_])/sprintf('%%%02X', $1)/eg; # [\W_] suggested by Chees
+eLord (again!)
    a( { -href => $perlmonks . '/
    node=' . $_ }, $name )
      } @ring;

    print header(), start_html('Cheesy Ring Members'),
      h1('Cheesy Ring Members'), p( img( { -src => $cheese_pic } ) ), 
      ul( li( { -type => 'disc' }, \@urls ) ), end_html();

sub cycle {
    my $count = shift;
    return ( $ring[ $start_index + $count ] ? $ring[ $start_index + $c
+ount ] :
      $ring[ $start_index + $count - @ring ] );

sub add {
    my $name = shift;
    my $found;

    open( LIST, "$list" ) or die "Cannot open '$list': $!\n";
    flock( LIST, 1 );
    while (<LIST>) {
        $found++ if m/^$name$/i

    unless ($found){
        push ( @ring, $name );
        open( LIST, "+< $list" ) or die "Cannot open '$list': $!\n";
        flock( LIST, 2 );
        seek( LIST, 0, 0 );
        truncate( LIST, 0 );
        print LIST join ( "\n", @ring );

    my $inc = div(
        { -align => 'center' },
        img({-src=> $cheese_pic}),
        h2( $found ?  "You're already a Cheese Member!" : 'Welcome to 
+the Cheesy webring!' ),
        join(' - ', map {
        ' &#91; ' . a({-href=> "$url?start=$name&go=$_"}, $_) . ' &#93
        ( 'previous', 'next', 'random', 'list', 'next5', 'prev5',
        'first',      'last' )
      ) ) ) ), p( small(
"don't blame me for [Cheesy WebRing|this idea], it's [ar0n]'s fault!"
          ) ) );

    $inc =~ s/&/&amp;/g;
    $inc =~ s/</&lt;/g;
    $inc =~ s/>/&gt;/g;
    print header(), start_html('Cheesy Ring Members'),
      h1('Cheesy Ring Members'),
      p('Add the following code somewhere in your homenode:'), tt($inc
+), hr(),


As always, since I modified bits of the code while editing the node, it's perfectly normal if everything breaks.

Replies are listed 'Best First'.
Re: Cheesy Webring
by virtualsue (Vicar) on Aug 23, 2001 at 12:47 UTC

    To think this all started when CheeseLord said he had the ambition of being mentioned on every home node and someone else pointed out that as he was only mentioned on 10 of them, he really had his work cut out for him. :)
    ar0n suggested a webring, and ~10 seconds later, OeufMayo had one ready.*

    (Oops: My memory is failing. It was CheeseLord himself who pointed out that he had his work cut out for himself, and it was only 4 nodes then. )

    The code above is up on my site, so anyone can join the Cheesy Webring. You can see who is a citizen of the Free Cheese Nation via the member list. Show your support and add yourself to the ring while you're there. The program provides sample code that you can use in your home node.**

    I've added a delete option, so if you develop an allergy to Wensleydale /msg me and I'll give you the URL.

    *Some may find it ironic that CheeseLord is not directly mentioned in the Cheesy Webring.

    **If your level is not high enough, the Cheesy Webring image won't appear, but don't worry, you're still in the club. The image will show up once you reach level 5.

(crazyinsomniac) Re: Cheesy Webring
by crazyinsomniac (Prior) on Aug 26, 2001 at 17:27 UTC
    You check to see which top level domain it is, but you forget the server. Here, you go fix: my $perlmonks = 'http://'.(($referer =~ m|www\.p|i)?'www.':'')."perlmonks.$tld";

    Disclaimer: Don't blame. It came from inside the void

    perl -e "$q=$_;map({chr unpack qq;H*;,$_}split(q;;,q*H*));print;$q/$q;"

      Here is how I did it in Random NonHome Nodes.
      my ($www,$tld) = $referer =~ /(www\.)?perlmonks\.(\w+)/i; [snip] my $redirurl = "http://${www}perlmonks.$tld/$node";


Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://106258]
[Cow1337killr]: <p>stevieb, you should leave an insightful comment at https://plugins. idea/plugin/7796- perl</p>
[Cow1337killr]: (Oops. HTML paragraph markup not needed.)
[stevieb]: Cow1337killr yeah, you're probably right. I have communicated to the author directly, and here on his threads. It's a tremenous setup. With Devel::Camelcadedb , you get full perl debug support too
[stevieb]: so now I can use CLion with the Perl plugin and have a single IDE for Perl/C/C++. It'll make writing C/XS dists much easier
[stevieb]: Python too, but I leave work at work

How do I use this? | Other CB clients
Other Users?
Others exploiting the Monastery: (12)
As of 2017-02-20 21:08 GMT
Find Nodes?
    Voting Booth?
    Before electricity was invented, what was the Electric Eel called?

    Results (302 votes). Check out past polls.