[Liveframe-commits] cvs commit: commons/lib/LiveFrame Action.pm Application.pm Errors.pm Form.pm

[<ix...@us...>]

ixjonez     01/12/18 21:36:13

  Added:       lib/LiveFrame Action.pm Application.pm Errors.pm Form.pm
  Log:
  move application classes to commons
  
  Revision  Changes    Path
  1.1                  commons/lib/LiveFrame/Action.pm
  
  Index: Action.pm
  ===================================================================
  # -*- Mode: Perl; indent-tabs-mode: nil; -*-
  
  package LiveFrame::Action;
  
  use strict;
  
  sub new {
      my ($type, $params) = @_;
      my $class = ref($type) || $type;
  
      my $self = bless
          {
           name => undef,
          }, $class;
  
      $self->init($params || {});
  
      return $self;
  }
  
  sub init {
      my ($self, $params) = @_;
  
      $self->name($params->{name}) if $params->{name};
  
      return 1;
  }
  
  sub name {
      my $self = shift;
      $self->{name} = shift if @_;
      return $self->{name};
  }
  
  1;
  
  
  
  1.1                  commons/lib/LiveFrame/Application.pm
  
  Index: Application.pm
  ===================================================================
  # -*- Mode: Perl; indent-tabs-mode: nil; -*-
  
  package LiveFrame::Application;
  
  use strict;
  use AppConfig ();
  use CGI ();
  use Cwd ();
  use File::Spec ();
  use HTML::Entities ();
  use Template 2.0.6 ();
  use URI ();
  
  $LiveFrame::Application::VERSION = '0.01';
  
  sub new {
      my ($type) = @_;
      my $class = ref($type) || $type;
  
      my $self = bless {
                        actions              => {},
                        attrs                => {},
                        cgi                  => undef,
                        committed            => undef,
                        config               => undef,
                        config_processed     => undef,
                        config_file          => undef,
                        current_action_name  => undef,
                        current_control_name => undef,
                        current_form_name    => undef,
                        default_action_name  => undef,
                        default_error_page   => undef,
                        forms                => {},
                        template_dir         => undef,
                        tproc                => undef,
                       }, $class;
  
      return $self;
  }
  
  ## accessor methods
  
  sub action {
      my ($self, $name) = @_;
      return undef unless $name;
      return $self->{actions}->{$name};
  }
  
  sub actions {
      my ($self) = @_;
      my @actions = values %{ $self->{actions} };
      return wantarray ? @actions : \@actions;
  }
  
  sub add_action {
      my ($self, $name, $class) = @_;
      return undef unless $name && $class;
  
      eval "require $class";
      die "can't load action class $class: $@\n" if $@;
  
      my $action = $class->new();
      $action->name($name);
  
      $self->{actions}->{$name} = $action;
  
      return 1;
  }
  
  sub add_form {
      my ($self, $name, $class) = @_;
      return undef unless $name && $class;
  
      eval "require $class";
      die "can't load action class $class: $@\n" if $@;
  
      my $form = $class->new();
      $form->name($name);
  
      $self->{forms}->{$name} = $form;
  
      return 1;
  }
  
  sub attr {
      my $self = shift;
      my $name = shift or
          return undef;
      $self->{attrs}->{$name} = shift if @_;
      return $self->{attrs}->{$name};
  }
  
  sub attrs {
      my ($self) = @_;
      my @names = keys %{ $self->{attrs} };
      return wantarray ? @names : \@names;
  }
  
  sub cgi {
      my ($self) = @_;
      $self->{cgi} ||= CGI->new();
      return $self->{cgi};
  }
  
  sub config_vars {
      my ($self) = @_;
  
      $self->{config}->define("template_dir=s", { DEFAULT => '../share/tmpl' });
      $self->{config}->define("img_url=s",      { DEFAULT => '../lab/img' });
      $self->{config}->define("css_url=s",      { DEFAULT => '../lab' });
  
      return 1;
  }
  
  sub config {
      my ($self) = @_;
  
      my $config_error = sub { die @_, "\n"; };
  
      unless ($self->{config}) {
          my $config_opts =
              {
               PEDANTIC => 1,
               ERROR => $config_error,
               GLOBAL => {EXPAND => AppConfig::EXPAND_ALL},
              };
  
          $self->{config} = AppConfig->new($config_opts);
  
          $self->config_vars();
      }
  
      return $self->{config};
  }
  
  sub config_file {
      my $self = shift;
      my $orig = shift if @_;
  
      if (defined $orig || ! defined $self->{config_file}) {
          $orig ||= $self->config()->config_file();
          my $file = File::Spec->file_name_is_absolute($orig) ?
              File::Spec->canonpath($orig) :
                  File::Spec->rel2abs($orig, Cwd::getcwd());
          -f $file or
              die "config file $file not found\n";
          $self->{config_file} = $file;
      }
  
      return $self->{config_file};
  }
  
  sub control {
      my ($self) = @_;
      $self->form() unless defined $self->{control};
      return $self->{control};
  }
  
  sub css_url {
      my ($self) = @_;
      return $self->config()->css_url();
  }
  
  sub current_action {
      my ($self) = @_;
      my $name = $self->current_action_name();
      return defined $name ?
          $self->action($name) :
              $self->default_action();
  }
  
  sub current_action_name {
      my $self = shift;
  
      if (@_) {
          $self->{current_action_name} = shift;
      } elsif (! defined $self->{current_action_name}) {
          my $path_info = $self->cgi()->path_info();
          if ($path_info) {
              $path_info =~ s|^/||;
              if ($path_info) {
                  ($self->{current_action_name} = $path_info) =~ s|/|_|g;
              }
          }
      }
  
      return $self->{current_action_name};
  }
  
  sub current_form {
      my ($self) = @_;
      my $form = $self->form($self->current_form_name()) or
          return undef;
  
      $form->control($self->current_control_name());
  
      my $cgi = $self->cgi();
      for my $name ($cgi->param()) {
          $form->$name($cgi->param($name)) if $form->can($name);
      }
  
      return $form;
  }
  
  sub current_control_name {
      my $self = shift;
      $self->{current_control_name} = shift if @_;
      return $self->{current_control_name};
  }
  
  sub current_form_name {
      my $self = shift;
  
      if (@_) {
          my $name = shift;
          unless ($self->form($name)) {
              die "current form $name is not defined\n";
          }
          $self->{current_form_name} = $name;
      } elsif (! defined $self->{current_form_name}) {
          for my $name ($self->cgi()->param()) {
              ($self->{current_form_name}, $self->{current_control_name}) =
                  ($name =~ m|^form_(.+)_(.+)$|);
              last if defined $self->{current_form_name};
          }
      }
  
      return $self->{current_form_name};
  }
  
  sub default_action {
      my ($self) = @_;
      return $self->action($self->default_action_name());
  }
  
  sub default_action_name {
      my $self = shift;
      $self->{default_action_name} = shift if @_;
      return $self->{default_action_name};
  }
  
  sub default_error_page {
      my $self = shift;
      $self->{default_error_page} = shift if @_;
      return $self->{default_error_page};
  }
  
  sub form {
      my ($self, $name) = @_;
      return undef unless $name;
      return $self->{forms}->{$name};
  }
  
  sub forms {
      my ($self) = @_;
      my @forms = values %{ $self->{forms} };
      return wantarray ? @forms : \@forms;
  }
  
  sub img_url {
      my ($self) = @_;
      return $self->config()->img_url();
  }
  
  sub remove_action {
      my ($self, $name) = @_;
      return undef unless $name;
      delete $self->{actions}->{name};
      return 1;
  }
  
  sub remove_form {
      my ($self, $name) = @_;
      return undef unless $name;
      delete $self->{forms}->{name};
      return 1;
  }
  
  sub template_dir {
      my ($self) = @_;
  
      unless (defined $self->{template_dir}) {
          my $orig = $self->config()->template_dir();
          $self->{template_dir} = File::Spec->file_name_is_absolute($orig) ?
              File::Spec->canonpath($orig) :
                  File::Spec->rel2abs($orig, Cwd::getcwd());
      }
  
      return $self->{template_dir};
  }
  
  sub tproc {
      my ($self) = @_;
  
      unless ($self->{tproc}) {
          my $tproc_opts =
              {
               INCLUDE_PATH => $self->template_dir(),
               PLUGIN_BASE  => 'LiveFrame::Template::Plugin',
              };
  
          $self->{tproc} = Template->new($tproc_opts);
      }
  
      return $self->{tproc};
  }
  
  ## application utility methods
  
  sub fill_in_form {
      my ($self, $form) = @_;
  
      for my $name ($form->fields()) {
          $self->attr($name, $form->field($name));
      }
  
      return 1;
  }
  
  sub process_config {
      my ($self) = @_;
  
      unless ($self->{config_processed}) {
          $self->config()->file($self->config_file());
          $self->{config_processed} = 1;
      }
  
      return 1;
  }
  
  sub process_template {
      my ($self, $page, $tparams) = @_;
      $tparams ||= {};
  
      my $cgi = $self->cgi();
      my $config = $self->config();
      my $tproc = $self->tproc();
  
      for my $name ($self->attrs()) {
          $tparams->{$name} = $self->attr($name);
      }
  
      $tparams->{application}  = $self;
      $tparams->{config}       = $self->config();
      $tparams->{cgi}          = $self->cgi();
      $tparams->{page}         = $page;
  
      my $current_form_name = $self->current_form_name() || '';
      if ($current_form_name eq $page) {
          my $form = $self->current_form();
          if ($form) {
              $tparams->{form} = $form;
          }
      }
  
      $tparams->{self_url}     = $self->url($cgi->script_name());
      $tparams->{img_url}      = $self->url($config->img_url());
      $tparams->{css_url}      = $self->url($config->css_url());
  
      $tproc->process($self->template($page), $tparams) or do {
          $self->send_tmpl_error($tproc->error(), $page);
      };
  
      return 1;
  }
  
  sub send_header {
      my ($self) = @_;
  
      print $self->cgi()->header() unless $self->{committed};
      $self->{committed} = 1;
  
      return 1;
  }
  
  sub send_page {
      my ($self, $page) = @_;
  
      $self->send_header();
      return $self->process_template($page);
  }
  
  sub send_redirect {
      my ($self, $page) = @_;
      my $cgi = $self->cgi();
  
      print $cgi->redirect(join('/', $cgi->script_name(), $page));
  
      return 1;
  }
  
  sub send_error {
      my ($self, $msg, $tmpl) = @_;
  
      $self->send_header();
  
      my $error_page = $self->default_error_page();
      if (defined $error_page) {
          my $tparams = { error_msg  => $msg };
  
          if (defined $tmpl) {
              $tparams->{error_type} = 'template';
              $tparams->{error_tmpl} = $tmpl;
          }
          else {
              $tparams->{error_type} = 'application';
          }
  
          return $self->process_template($error_page, $tparams);
      }
  
      $msg = HTML::Entities::encode_entities($msg);
  
      print <<EOT;
  <p>
  <b>Application Error</b>
  </p>
  <p>
  An internal application error was encountered:
  </p>
  <pre>
  $msg
  </pre>
  EOT
  
      return 1;
  }
  
  sub send_tmpl_error {
      my ($self, $error, $page) = @_;
  
      my $msg = $error->info() || '';
      $msg =~ s|\\n|\n|g;
      my $tmpl = $self->template($page);
  
      eval { $self->send_error($msg, $tmpl) };
      if ($@) {
          $msg = HTML::Entities::encode_entities($msg);
  
          print <<EOT;
  <p>
  <b>Template Error</b>
  </p>
  <p>
  An error was encountered processing <i>$tmpl</i>:
  </p>
  <pre>
  $msg
  </pre>
  <p>
  Additionally, an error was encountered processing the default error page:
  </p>
  <pre>
  $@
  </pre>
  EOT
      }
  
      return 1;
  }
  
  sub template {
      my ($self, $page) = @_;
      return join('.', $page, 'tmpl');
  }
  
  sub url {
      my ($self, $path) = @_;
      my $cgi = $self->cgi();
  
      my $scheme = $cgi->https() ? 'https' : 'http';
      my $url = URI->new($path, $scheme);
  
      my $abs = $url->abs($cgi->script_name());
      $abs =~ s|/$||;
  
      return $abs;
  }
  
  ## run methods
  
  sub start {
      my ($self, $params) = @_;
      return 1 unless $params;
  
      $self->config_file($params->{config_file});
      $self->default_action_name($params->{default_action_name} || 'default');
      $self->default_error_page($params->{default_error_page});
  
      if ($params->{config_vars}) {
          unless (UNIVERSAL::isa($params->{config_vars}, 'ARRAY')) {
              die "application init param 'config_vars' must be an array ref\n";
          }
  
          my $config = $self->config();
          for my $var (@{ $params->{config_vars} }) {
              $config->define($var);
          }
      }
  
      if ($params->{actions}) {
          unless (UNIVERSAL::isa($params->{actions}, 'ARRAY')) {
              die "application init param 'actions' must be an array ref\n";
          }
  
          for (my $i = 0; $i < @{ $params->{actions} }; $i++) {
              my $action_params = $params->{actions}->[$i];
              unless (UNIVERSAL::isa($params, 'HASH')) {
                  die "application init param 'actions[$i]'",
                      " must be an array ref\n";
              }
              unless (defined $action_params->{name}) {
                  die "application init param 'actions[$i]", "->name'",
                      " must be defined\n";
              }
              unless (defined $action_params->{class}) {
                  die "application init param 'actions[$i]", "->class'",
                      " must be defined\n";
              }
  
              $self->add_action($action_params->{name},
                                $action_params->{class});
          }
      }
  
      if ($params->{forms}) {
          unless (UNIVERSAL::isa($params->{forms}, 'ARRAY')) {
              die "application init param 'forms' must be an array ref\n";
          }
  
          for (my $i = 0; $i < @{ $params->{forms} }; $i++) {
              my $form_params = $params->{forms}->[$i];
              unless (UNIVERSAL::isa($params, 'HASH')) {
                  die "application init param 'forms[$i]'",
                      " must be an array ref\n";
              }
              unless (defined $form_params->{name}) {
                  die "application init param 'forms[$i]", "->name'",
                      " must be defined\n";
              }
              unless (defined $form_params->{class}) {
                  die "application init param 'forms[$i]", "->class'",
                      " must be defined\n";
              }
  
              $self->add_form($form_params->{name},
                              $form_params->{class});
          }
      }
  
      return 1;
  }
  
  sub run {
      my ($self, $params) = @_;
  
      eval { $self->start($params) };
      if ($@) {
          $self->send_error("application could not be started: $@");
          return 0;
      }
  
      # force the config file to be read.
      eval { $self->process_config() };
      if ($@) {
          $self->send_error("config file error: $@");
          return 0;
      }
  
      my $action = eval { $self->current_action() };
      if ($@) {
          $self->send_error("can't get current action: $@");
          return 0;
      }
  
      if ($action) {
          my $form = eval { $self->current_form() };
          if ($@) {
              $self->send_error("can't get current form: $@");
              return 0;
          }
  
          if ($form) {
              # validate the form
              eval { $form->validate($self) };
              if ($@) {
                  # the form did not validate successfully. reset form
                  # variables and set errors. send the previous page again.
                  $self->attr('errors', $@);
                  $self->fill_in_form($form);
  
                  # XXX: requires the previous action to have the same name
                  # as the form in the page htat it sends
                  $self->current_action_name($form->name());
                  $action = $self->current_action();
              }
          }
          else {
              # the action did not involve a form
              # XXX: how to signal that an action requires a form submission?
          }
  
          # if the action wasn't unset (usually by an invalid form
          # submission), execute the action method, which will send a
          # page when it completes
          if ($action) {
              eval { $action->perform($self, $form) };
              if ($@) {
                  $self->send_error($@);
              }
          }
      }
  
      unless ($action) {
          # no action exists for the specified action name so assume
          # it's a page name
          # XXX: set a config switch to disable page sending?
  #        my $msg = sprintf("requested action [%s] not defined",
  #                          $self->current_action_name());
  #        $self->send_error($msg);
  #        return 0;
          eval {
              $self->send_page($self->current_action_name() ||
                               $self->default_action_name());
          };
          if ($@) {
              $self->send_error($@);
          }
      }
  
      return 0;
  }
  
  1;
  
  
  
  
  
  1.1                  commons/lib/LiveFrame/Errors.pm
  
  Index: Errors.pm
  ===================================================================
  # -*- Mode: Perl; indent-tabs-mode: nil; -*-
  
  package LiveFrame::Errors;
  
  use strict;
  
  sub new {
      my ($type, $params) = @_;
      my $class = ref($type) || $type;
  
      my $self = bless
          {
           errors => {},
          }, $class;
  
      $self->init($params || {});
  
      return $self;
  }
  
  sub init {
      my ($self, $params) = @_;
      return 1;
  }
  
  sub add_error {
      my ($self, $msg, $name) = @_;
      return undef unless defined $msg;
      $name ||= 'default';
      $self->{errors}->{$name} ||= [];
      push @{ $self->{errors}->{$name} }, $msg;
      return 1;
  }
  
  sub errors {
      my ($self, $name) = @_;
      $name ||= 'default';
      return undef unless exists $self->{errors}->{$name};
      my @errors = @{ $self->{errors}->{$name} };
      return wantarray ? @errors : \@errors;
  }
  
  sub error_types {
      my ($self) = @_;
      my @types = keys %{ $self->{types} };
      return wantarray ? @types : \@types;
  }
  
  sub remove_errors {
      my ($self, $name) = @_;
      return undef unless $name;
      delete $self->{errors}->{name};
      return 1;
  }
  
  1;
  
  
  
  1.1                  commons/lib/LiveFrame/Form.pm
  
  Index: Form.pm
  ===================================================================
  # -*- Mode: Perl; indent-tabs-mode: nil; -*-
  
  package LiveFrame::Form;
  
  use strict;
  
  sub new {
      my ($type, $params) = @_;
      my $class = ref($type) || $type;
  
      my $self = bless
          {
           control => undef,
           name => undef,
           fields => {},
          }, $class;
  
      $self->init($params || {});
  
      return $self;
  }
  
  sub init {
      my ($self, $params) = @_;
  
      $self->name($params->{name}) if $params->{name};
      $self->control($params->{control}) if $params->{control};
  
      return 1;
  }
  
  ## accessors
  
  sub control {
      my $self = shift;
      $self->{control} = shift if @_;
      return $self->{control};
  }
  
  sub field {
      my $self = shift;
      my $name = shift or
          return undef;
      $self->{fields}->{$name} = shift if @_;
      return $self->{fields}->{$name};
  }
  
  sub fields {
      my $self = shift;
      my @names = keys %{ $self->{fields} };
      return wantarray ? @names : \@names;
  }
  
  sub name {
      my $self = shift;
      $self->{name} = shift if @_;
      return $self->{name};
  }
  
  ## public methods
  
  sub validate {
      my ($self, $lab) = @_;
  
      return 1;
  }
  
  1;