http://qs321.pair.com?node_id=50490
Category: Syntax
Author/Contact Info Dmitry Ovsyanko, do@rambler.ru
Description: This is an OO preprocessor for Perl. It features the class definitions, 'with' statement and many more...
package PlusPlus;
 
use strict;
use Carp;
use vars qw($VERSION);
 
$VERSION = '1.10';
 
use Filter::Util::Call;
 
sub import {
    my ($type) = @_;
    filter_add (bless {oo => 'none', export => [], export_ok => [], is
+a => ['Exporter']});
}
 
sub filter {
    my $self = shift;
    $_ = translate_oneline ($_, $self) if my ($status) = filter_read (
+);
    unless ($status) {
        if ($self -> {oo} eq 'none') {
            return 0;
        } else {
            $_ = '';
            $_ .= 'sub new {my $class = shift; my $self = {}; bless ($
+self, $class); eval {init (@_)}; return $self}; ';
            $_ .= '@ISA = qw(' . join (' ', @{$self -> {isa}})  . '); 
+@EXPORT = qw(' . join (' ', @{$self -> {export}}) . '); @EXPORT_OK = 
+qw('
. join (' ', @{$self -> {export_ok}}) . "); 1;\n";
            $self -> {oo} = 'none';
            return 1;
        }
    }
    return $status;
}
 
sub list_to_nested_hashes {
 my $parts = shift;
 my $str = shift @$parts;
 foreach (@$parts) { $str = "\$\{$str\}\{'$_'\}" };
 return $str;
};
 
sub list_to_method {
    my $parts = shift;
    my $str = shift @$parts;
    my $method = pop @$parts;
    $str .= ' -> ';
    $str .= join (' -> ', (map {"{'$_'}"} @$parts)) . ' -> ' if @$part
+s;
    $str .= $method;
    return $str;
};
 
sub code_parse_fields_and_methods {
    return 0 unless shift =~ /([\$]\w+)(\.\$?\w+)+|\$\.\w+(\.\$?\w+)*/
+;
    my $r =  {pre => $`, match => $&, post => $'};
    my @parts = split (/\./, $r -> {match});
    $r -> {parts} = \@parts;
 package PlusPlus;
 
use strict;
use Carp;
use vars qw($VERSION);
 
$VERSION = '1.10';
 
use Filter::Util::Call;
 
sub import {
    my ($type) = @_;
    filter_add (bless {oo => 'none', export => [], export_ok => [], is
+a => ['Exporter']});
}
 
sub filter {
    my $self = shift;
    $_ = translate_oneline ($_, $self) if my ($status) = filter_read (
+);
    unless ($status) {
        if ($self -> {oo} eq 'none') {
            return 0;
        } else {
            $_ = '';
            $_ .= 'sub new {my $class = shift; my $self = {}; bless ($
+self, $class); eval {init (@_)}; return $self}; ';
            $_ .= '@ISA = qw(' . join (' ', @{$self -> {isa}})  . '); 
+@EXPORT = qw(' . join (' ', @{$self -> {export}}) . '); @EXPORT_OK = 
+qw('
. join (' ', @{$self -> {export_ok}}) . "); 1;\n";
            $self -> {oo} = 'none';
            return 1;
        }
    }
    return $status;
}
 
sub list_to_nested_hashes {
 my $parts = shift;
 my $str = shift @$parts;
 foreach (@$parts) { $str = "\$\{$str\}\{'$_'\}" };
 return $str;
};
 
sub list_to_method {
    my $parts = shift;
    my $str = shift @$parts;
    my $method = pop @$parts;
    $str .= ' -> ';
    $str .= join (' -> ', (map {"{'$_'}"} @$parts)) . ' -> ' if @$part
+s;
    $str .= $method;
    return $str;
};
 
sub code_parse_fields_and_methods {
    return 0 unless shift =~ /([\$]\w+)(\.\$?\w+)+|\$\.\w+(\.\$?\w+)*/
+;
    my $r =  {pre => $`, match => $&, post => $'};
    my @parts = split (/\./, $r -> {match});
    $r -> {parts} = \@parts;
    return $r;
};
 
sub code_translate_fields_and_methods {
    my $src_line = shift;
    while (1) {
        last unless (my $parsed = code_parse_fields_and_methods ($src_
+line));
        my $str = ($parsed -> {post} =~ /^\s*\(/ ?
            list_to_method ($parsed -> {parts}) :
            list_to_nested_hashes ($parsed -> {parts})
        );
        $src_line = $parsed -> {pre} . $str . $parsed -> {post}
    }
    return $src_line;
};
 
sub code_translate_fields_and_methods {
    my $src_line = shift;
    while (1) {
        last unless (my $parsed = code_parse_fields_and_methods ($src_
+line));
        my $str = ($parsed -> {post} =~ /^\s*\(/ ?
            list_to_method ($parsed -> {parts}) :
            list_to_nested_hashes ($parsed -> {parts})
        );
        $src_line = $parsed -> {pre} . $str . $parsed -> {post}
    }
    return $src_line;
};
 
sub translate_oneline {
    local $_ = shift;
    my $cntxt = shift;
 
    if (s/class\s+([\w\:]+)\s*(\([^\)]+\))?\s*\;/package $1; use Expor
+ter; use vars qw(\@ISA \@EXPORT \@EXPORT_OK);/) {
        $cntxt -> {oo} = 'class';
        foreach my $ancestor (split /,/, $2) {
            $ancestor =~ s /[\s\(\)]//g;
            push @{$cntxt -> {isa}}, $ancestor;
        }
    }
 
    if (s/module\s+([\w\:]+)\s*(\([^\)]+\))?\s*\;/package $1; use Expo
+rter; use vars qw(\@ISA \@EXPORT \@EXPORT_OK);/) {
        $cntxt -> {oo} = 'module';
        foreach my $ancestor (split /,/, $2) {
            $ancestor =~ s /[\s\(\)]//g;
            push @{$cntxt -> {isa}}, $ancestor;
        }
    }
 
    s/method\s+(\w+)\s*\{/sub $1 { my \$self = shift; my \$__with__pre
+fix__ = \$self; /;
 
    if (s/(export_ok|export)\s+sub\s+(\w+)/sub $2/) {
        my $name = $2;
        push @{$cntxt -> {export_ok}}, $name if ($1 eq 'export_ok');
        push @{$cntxt -> {export}},    $name if ($1 eq 'export');
    }
 
    s/new\s+([\w\:]+)/ $1 -> new/g;
    s/with([^\{]+)\{/do { my \$__with__prefix__ = $1\;/g;
    s/\$\./\$__with__prefix__\./g;
    code_translate_fields_and_methods ($_);
};
Replies are listed 'Best First'.
Downvotes with No Comments (Was Re: PlusPlus.pm)
by salvadors (Pilgrim) on Jan 14, 2001 at 17:58 UTC

    So, why exactly does this have a Rep of -7?

    Surely at least one of the people downvoting it could have posted something saying "This is bad, because ...."?

    Is it just because no-one can understand what this does? Or because it it's a really longwinded way of doing nothing|something standard|somethign that can be done much easier|something on CPAN? Or because it's a security risk? Or what?

    Or is it just because someone voted it down, it appeared in Worst Nodes, and some other people thought, "That must be bad, I'll vote it down too"?

    If something is really bad, and just gets downvoted with no comments, then most readers won't realise, as you can't see the reputation until you've voted, or unless you visit Worst Nodes.

    I don't think there should be a rule that says you can't downvote without a comment, but I'd maybe say that the first person to downvote should have to explain why. Or at least something that stops something getting to -7 without anyone having responded to the post at all.

    Tony