#!/usr/bin/perl -w
use strict;

# For our crude help system, see below
use vars qw/%accessibleCommands/;

{
  # The first package, implementing the "accesslevel" attribute.
  # All objects which implement security must inherit
  # from this package
  package Security;
  
  use Attribute::Handlers;
  use Hook::LexWrap;
  
  use vars qw/$verbose/;
  
  $verbose = 0;
  
  # This is called for each use of ":accessLevel(0)"
  # in a definition of a subroutine
  sub accessLevel :ATTR(CODE) {
    my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
    
    my $name = *{$symbol}{NAME};
    print "Adding $name => $data\n" if $verbose;
    $::accessibleCommands{$name} = $data;
    
    # Install our access level checker :
    wrap *{$symbol}, 
      pre => sub { 
                   my ($self,@args) = @_;
                   if ($self->{"userlevel"} <= $data) {
                     # We will call the original routine
                     $self->log_action($name);
                     #$self->log_action($name,@args);
                     # Why does this crash IndigoPerl 5.6.1, build 626 ??
                   } else {
                     $self->log_accessViolation($name,$data);
                     # Due to lack of a better value. 
                     $_[-1] = "Access violation in $name() : Level $data too large !"; 
                     # Maybe an exception should be raised instead
                   }
                 };
    
    print STDERR
      ref($referent), " $name  ($referent) was just declared ",
      "and ascribed the ${attr} attribute ",
      "with data ($data)\n",
      "in phase $phase\n" if $verbose;
  };

sub new {
  my $self = {
    userlevel => 666,
    username => "Hieronymous Monk",
    url => "<none>",
  };
  my $classname = shift;
  $classname = ref($classname)||$classname;
  bless $self, $classname;
  return $self;
};

sub log_accessViolation {
  my ($session,$symbol,$level) = @_;
  print "ACCESS VIOLATION on $symbol: user: ",$session->{'username'},"/",$session->{'userlevel'}," tried ",$session->{'url'},"/$level\n"
};

sub log_action {
  my ($session,@params) = @_;
  print "ACTION: user: ",$session->{username},"/",$session->{'userlevel'},":",join("", @params);
};

sub log_error {
  my ($session,$message) = @_;
  print "ERROR: user: ",$session->{'username'},"/",$session->{'userlevel'}," $message";
};
1;
}

{
# This is the "application", inheriting from
# the Security package
package secureApp;
no warnings 'redefine'; # because that's what we'll do plenty

use base 'Security';
use UNIVERSAL;

use constant ANONYMOUS => 666;
use constant REGISTERED => 1;
use constant ROOT => 0;

sub export_show_inside :accessLevel(1) {
  my $self = shift;
  print "Showing the inside.\n";
  # return "the inside";
  # Return values are not (yet) well thought out
};

sub export_show_frontpage :accessLevel(666) {
  my $self = shift;
  print "Showing the front page.\n";
};

sub export_show_admin :accessLevel(0) {
  my $self = shift;
  print "Showing the admin page.\n";
};

sub export_su :accessLevel(666) {
  my ($self,$newlevel) = @_;
  $self->{"userlevel"} = $newlevel;
  print "You become a new " . ((rand > 0.5) ? "wo" : "" ) . "man.\n";
};

sub export_quit :accessLevel(666) {
  my ($self) = @_;
  exit 0;
};

sub export_help :accessLevel(666) {
  my ($self) = @_;
  # A really crude help system which dosen't account
  # for multiple classes etc.
  foreach (sort (keys %::accessibleCommands)) {
    print "$1 : $::accessibleCommands{$_}\n" if /^export_(.*)/;
  };
};

# The main (and blind) dispatch loop
sub handle {
  my ($self,$command,@params) = @_;
  
  my $handler = $self->can( "export_$command" );
  if ($handler) {
    #print "$command(", join( ",", @params ), ");\n";
    $self->{"url"} = "export_$command";
    &$handler( $self,@params );
  } else {
    $self->log_error("Invalid command requested: '$command'\n");
  };
};

sub new {
  my $self = new Security;
  
  my $classname = shift;
  $classname = ref($classname)|| $classname;
  bless $self,$classname;
  
  print "Current user level : ",$self->{userlevel},"\n";
  return $self;
};

1;
};

my $app = new secureApp;

print "Type 'help' for commands\n";
print $app->{'userlevel'},">";
while (<>) {
  chomp;
  my ($command, @params) = split / /;
  $app->handle($command,@params) if /./;
  print $app->{'userlevel'},">";
};