ClearPress::view - MVC view superclass

  my $oView = ClearPress::view::<subclass>->new({util => $oUtil});
  $oView->model($oModel);

  print $oView->decor()?
    $oDecorator->header()
    :
    q(Content-type: ).$oView->content_type()."\n\n";

  print $oView->render();

  print $oView->decor()?$oDecorator->footer():q[];

  my $oView = ClearPress::view::<subclass>->new({util => $oUtil, ...});

 sets the aspect based on the HTTP Accept: header

 - useful for API access setting Accept: text/xml

  my $sTemplateName = $oView->template_name();

  my $sMethodName = $oView->method_name();

  $oView->add_warning($sWarningMessage);

  my $arWarningStrings = $oView->warnings();

  This should usually take into account $self->action() which suggests
  read or write access.

  my $bIsAuthorised = $oView->authorised();

  my $sViewOutput = $oView->render();

  Implemented in subclass:

  sub streamed_aspects {
    return [qw(list list_xml list_json)];
  }

  sub list { ... }
  sub list_xml { ... }
  sub list_json { ... }

  $oView->create();

  Populates $oSelf->model() with its expected parameters from the CGI
  block, then calls $oModel->create();

  my $tt = $oView->tt();

  sub init {
    my $self = shift;
    $self->add_tt_filter('foo_filter',
                         sub {
                              my $string = shift;
                              $string =~ s/foo/bar/smxg;
                              return $string;
                             });
    return;
  }

  my $hrFilters = $oView->tt_filters();

  $oView->util($oUtil);
  my $oUtil = $oView->util();

  $oView->model($oModel);
  my $oModel = $oView->model();

  $oView->action($sAction);
  my $sAction = $oView->action();

  $oView->aspect($sAction);
  my $sAction = $oView->aspect();

  $oView->content_type($sContentType);
  my $sContentType = $oView->content_type();

  $oView->charset($sCharSet);
  my $sCharSet = $oView->charset();

  $oView->decor($bDecorToggle);
  my $bDecorToggle = $oView->decor();

 Usually set by the controller, after processing the request. Used for
 remapping requests to classes (specifically things of the form
 application::(model|view)::something::somethingelse .

  $oView->entity_name($sEntityName);
  my $sEntityName = $oView->entity_name();

  my $sActionOutput = $oView->actions();

  Process template.tt2 with standard parameters, output to stdout.

  $oView->process_template('template.tt2');




  Process template.tt2 with standard parameters plus extras, output to
  stdout.

  $oView->process_template('template.tt2', {extra=>'params'});




  Process template.tt2 with standard plus extra parameters and output
  into $to_scalar.

  $oView->process_template('template.tt2', {extra=>'params'}, $to_scalar);

  $oView->output_buffer(q[my string]);
  $oView->output_buffer(@aStrings);

  $oView->output_end();

  $oView->output_finished(1);
  $oViwe->output_finished(0);

  $oView->output_flush();

  $oView->output_reset();

 If you're producing applications of moderate complexity, you almost
 certainly want to disable autoescaping and handle it more cleverly
 yourself. Subclass ClearPress::view and set self->autoescape to zero
 or override the subroutine:

 sub autoescape { return 0; }

#########
# Author:        rmp
# Maintainer:    $Author: zerojinx $
# Created:       2007-03-28
# Last Modified: $Date: 2010-09-27 09:38:41 +0100 (Mon, 27 Sep 2010) $
# Id:            $Id: view.pm 388 2010-09-27 08:38:41Z zerojinx $
# Source:        $Source: /cvsroot/clearpress/clearpress/lib/ClearPress/view.pm,v $
# $HeadURL: https://clearpress.svn.sourceforge.net/svnroot/clearpress/trunk/lib/ClearPress/view.pm $
#
package ClearPress::view;
use strict;
use warnings;
use base qw(Class::Accessor);
use Template;
use Template::Filters;
use ClearPress::util;
use Carp;
use English qw(-no_match_vars);
use POSIX qw(strftime);
use HTML::Entities qw(encode_entities_numeric);
use XML::Simple qw(XMLin);
use utf8;

our $VERSION        = do { my ($r) = q$Revision: 388 $ =~ /(\d+)/smx; $r; };
our $DEBUG_OUTPUT   = 0;
our $TEMPLATE_CACHE = {};

__PACKAGE__->mk_accessors(qw(util model action aspect content_type entity_name autoescape charset));

sub new {
  my ($class, $self)    = @_;
  $self               ||= {};
  bless $self, $class;

  my $util                    = $self->util();
  my $username                = $util?$util->username():q[];
  $self->{requestor_username} = $username;
  $self->{logged_in}          = $username?1:0;
  $self->{warnings}           = [];
  $self->{output_buffer}      = [];
  $self->{output_finished}    = 0;
  $self->{autoescape}         = 1;

  my $aspect = $self->aspect() || q[];

  $self->{content_type} ||= ($aspect =~ /(?:rss|atom|ajax|xml)$/smx)?'text/xml':q[];
  $self->{content_type} ||= ($aspect =~ /(?:js|json)$/smx)?'application/javascript':q[];
  $self->{content_type} ||= ($aspect =~ /_png$/smx)?'image/png':q[];
  $self->{content_type} ||= ($aspect =~ /_jpg$/smx)?'image/jpeg':q[];
  $self->{content_type} ||= ($aspect =~ /_txt$/smx)?'text/plain':q[];
  $self->{content_type} ||= ($aspect =~ /_xls$/smx)?'application/vnd.ms-excel':q[];

  $self->init();

  $self->{content_type} ||= 'text/html';

  $self->{charset}      ||= 'UTF-8';

  return $self;
}

sub init {
  return 1;
}

sub add_warning {
  my ($self, $warning) = @_;
  push @{$self->{warnings}}, $warning;
  return 1;
}

sub warnings {
  my $self = shift;
  return $self->{warnings};
}

sub _accessor { ## no critic (ProhibitUnusedPrivateSubroutines)
  my ($self, $field, $val) = @_;
  carp q[_accessor is deprecated. Use __PACKAGE__->mk_accessors(...) instead];
  if(defined $val) {
    $self->{$field} = $val;
  }
  return $self->{$field};
}

sub authorised {
  my $self      = shift;
  my $action    = $self->action() || q[];
  my $aspect    = $self->aspect() || q[];
  my $util      = $self->util();
  my $requestor = $util->requestor();

  if(!$requestor) {
    #########
    # If there's no requestor user object then authorisation isn't supported
    #
    return 1;
  }

  if($action =~ /^list/smx ||
     ($action eq 'read' &&
      $aspect !~ /^(?:add|edit|delete|update|create)/smx)) {
    #########
    # by default assume public read access for 'read' actions
    #
    return 1;

  } else {
    #########
    # by default allow only 'admin' group for non-read aspects (add, edit, create, update, delete)
    #
    if($requestor->can('is_member_of') &&
       $requestor->is_member_of('admin')) {
      return 1;
    }
  }

  return;
}

sub template_name {
  my $self   = shift;
  my $name = $self->entity_name();
  if(!$name) {
    ($name) = (ref $self) =~ /view::(.*)$/smx;
  }
  $name    ||= 'view';
  my $method = $self->method_name();

  if($method) {
    $name .= "_$method";
  }
  $name =~ s/:+/_/smxg;

  return $name;
}

sub method_name {
  my $self   = shift;
  my $aspect = $self->aspect();
  my $action = $self->action();
  my $method = $aspect || $action;
  my $model  = $self->model();
  my $pk     = $model->primary_key();

  if($pk               &&
     $method eq 'read' &&
     !$model->$pk()) {
    $method = 'list';
  }

  $method =~ s/__/_/smxg;

  return $method;
}

sub streamed_aspects {
  return [];
}

sub render {
  my $self   = shift;
  my $util   = $self->util();
  my $aspect = $self->aspect() || q[];
  my $action = $self->action();

  if(!$util) {
    croak q(No util object available);
  }

  my $requestor = $util->requestor();

  if(!$self->authorised()) {
    if(!$requestor) {
      croak q(Authorisation unavailable for this view.);
    }
    my $username = $requestor->username();
    if(!$username) {
      croak q(You are not authorised for this view. You need to log in.);
    }
    croak qq[You ($username) are not authorised for this view];
  }

  #########
  # Figure out and call the appropriate action if available
  #
  my $method = $self->method_name();
  if($method !~ /^(?:add|edit|create|read|update|delete|list)/smx) {
    croak qq(Illegal method: $method);
  }

  if($self->can($method)) {
    if($aspect =~ /_(?:jpg|png|gif)/smx) {
      return $self->$method();
    }

    #########
    # handle streamed methods
    #
    my $streamed = 0;
    for my $str_aspect (@{$self->streamed_aspects()}) {
      if($aspect eq $str_aspect) {
	$streamed = 1;
      }
    }

    if($streamed) {
      $self->output_flush();
    }

    $self->$method();

    if($streamed) {
      $self->output_end();
      return q[];
    }

  } else {
    croak qq(Unsupported method: $method);
  }

  my $model   = $self->model();
  my $actions = my $warnings = q[];

  if($self->decor()) {
    $actions  = $self->actions();
    eval {
      $self->process_template('warnings.tt2', {
					       warnings => $self->warnings,
					      }, \$warnings);

    } or do {
      #########
      # non-fatal warning - usually warnings.tt2 missing
      #
      carp "Warning: $EVAL_ERROR";
    };
  }

  #########
  # handle block (non-streamed) methods
  #
  my $tmpl = $self->template_name();

  for my $copy (qw(logged_in)) {
    $model->{$copy} ||= $self->{$copy};
  }

  my $cfg     = $util->config();
  my $content = q[];

  $self->process_template("$tmpl.tt2", {}, \$content);

  return $warnings . $actions . $content || q(No data);
}

sub process_template { ## no critic (Complexity)
  my ($self, $template, $extra_params, $where_to_ref) = @_;
  my $util        = $self->util();
  my $cfg         = $util->config();
  my ($entity)    = (ref $self) =~ /([^:]+)$/smx;
  $entity       ||= q[];
  my $script_name = $ENV{SCRIPT_NAME} || q[];
  my ($xfh, $xfp) = ($ENV{HTTP_X_FORWARDED_HOST}, $ENV{HTTP_X_FORWARDED_PORT});
  my $http_host   = ($xfh ? $xfh : $ENV{HTTP_HOST})   || q[localhost];
  my $http_port   = ($xfh ? $xfp : $ENV{HTTP_PORT})   || q[];
  my $https       = $ENV{HTTPS}?q[https]:q[http];
  my $href        = sprintf q[%s://%s%s%s%s],
			    $https,
			    $http_host,
			    $http_port?":$http_port":q[],
			    $script_name,
			    ($script_name eq q[/])?q[]:q[/];

  my $cfg_globals = {
		     (map {
		       $_ => $cfg->val('globals',$_)
		     } $cfg->Parameters('globals'))
		    };

  my $params   = {
		  requestor   => $util->requestor,
		  model       => $self->model(),
		  view        => $self,
		  entity      => $entity,
		  SCRIPT_NAME => $script_name,
		  HTTP_HOST   => $http_host,
		  HTTP_PORT   => $http_port,
		  HTTPS       => $https,
		  SCRIPT_HREF => $href,
		  ENTITY_HREF => "$href$entity",
		  now         => (strftime '%Y-%m-%dT%H:%M:%S', localtime),
		  %{$cfg_globals},
		  %{$extra_params||{}},
		 };


  my $appname = $util->config->val('application', 'name') ||
                $util->config->val('application', 'namespace') ||
                $ENV{SCRIPT_NAME};

  $TEMPLATE_CACHE->{$appname} ||= {};
  my $template_cache = $TEMPLATE_CACHE->{$appname};

  if(!$template_cache->{$template}) {
    my $path = sprintf q(%s/templates), $util->data_path();
    open my $fh, q[<], "$path/$template" or croak qq[Error opening $template];
    local $RS = undef;
    $template_cache->{$template} = <$fh>;
    close $fh or croak qq[Error closing $template];
  }

  $template = \$template_cache->{$template};

  if($where_to_ref) {
    $self->tt->process($template, $params, $where_to_ref) or croak $self->tt->error();

  } else {
    $self->tt->process($template, $params) or croak $self->tt->error();
  }

  return 1;
}

sub _populate_from_cgi {
  my $self  = shift;
  my $util  = $self->util();
  my $model = $self->model();
  my $cgi   = $util->cgi();

  #########
  # Populate model object with parameters posted into CGI
  # by default (in controller.pm) model will only have util & its primary_key.
  #
  $model->read();

  my $pk = $model->primary_key();

  my @fields = $model->fields();
  if($pk) {
    #########
    # don't leave primary key in field list
    #
    @fields = grep { $_ ne $pk } @fields;
  }

  my $params = {
		map { ## no critic (ProhibitComplexMappings)
		      my $p = $cgi->param($_);
		      utf8::decode($p);
		      $_ => $p;
		    } $cgi->param()
	       };

  #########
  # parse old-style XML POST payload
  #
  my $xmlpost = $cgi->param('POSTDATA');
  if($xmlpost) {
    utf8::decode($xmlpost);
    eval {
      $params = XMLin($xmlpost);
      for my $k (%{$params}) {
	if(ref $params->{$k} &&
	   ref $params->{$k} eq 'HASH' &&
	   !scalar keys %{$params->{$k}}) {
	  delete $params->{$k};
	}
      }
      1;
    } or do {
      #########
      # Not an XML-formatted POST body. Ignore for now.
      #
      carp q[Got error while parsing POSTDATA: ].$EVAL_ERROR;
    };
  }

  #########
  # parse new-style XML POST payload
  #
  my $xml = $cgi->param('XForms:Model');
  if($xml) {
    utf8::decode($xml);
    $params = XMLin($xml);
    for my $k (%{$params}) {
      if(ref $params->{$k} &&
	 ref $params->{$k} eq 'HASH' &&
	 !scalar keys %{$params->{$k}}) {
	delete $params->{$k};
      }
    }
  }

  for my $field (@fields) {
    if(!exists $params->{$field}) {
      next;
    }
    my $v = $params->{$field};

    #########
    # $v here will always be defined
    # but may be false, e.g. $v=q[] or $v=q[0]
    #
    if($self->autoescape()) {
      $v = $cgi->escapeHTML($v);
    }

    $model->$field($v);
  }

  return 1;
}

sub add {
  my $self = shift;
  return $self->_populate_from_cgi();
}

sub edit {
  my $self = shift;
  return $self->_populate_from_cgi();
}

sub list {
  return 1;
}

sub read { ## no critic (homonym)
  return 1;
}

sub delete { ## no critic (homonym)
  my $self  = shift;
  my $model = $self->model();

  $model->delete() or croak qq(Failed to delete entity: $EVAL_ERROR);

  return 1;
}

sub update {
  my $self  = shift;
  my $model = $self->model();

  #########
  # Populate model object with parameters posted into CGI
  # by default (in controller.pm) model will only have util & its primary_key.
  #
  $self->_populate_from_cgi();

  $model->update() or croak qq(Failed to update entity: $EVAL_ERROR);
  return 1;
}

sub create {
  my $self  = shift;
  my $model = $self->model();

  #########
  # Populate model object with parameters posted into CGI
  # by default (in controller.pm) model will only have util & its primary_key.
  #
  $self->_populate_from_cgi();

  $model->create() or croak qq(Failed to create entity: $EVAL_ERROR);

  return 1;
}

sub add_tt_filter {
  my ($self, $name, $code) = @_;

  if(!$name || !$code) {
    return;
  }

  $self->tt_filters->{$name} = $code;

  return 1;
}

sub tt_filters {
  my $self = shift;

  if(!$self->{tt_filters}) {
    $self->{tt_filters} = {};
  }

  return $self->{tt_filters};
}

sub tt {
  my ($self, $tt) = @_;
  my $util = $self->util();

  if($tt) {
    $util->{tt} = $tt;
  }

  if(!$util->{tt}) {
    $self->add_tt_filter('js_string', sub {
			                   my $string = shift;
					   if(!defined $string) {
					     $string = q[];
					   }
					   $string    =~ s/\r/\\r/smxg;
					   $string    =~ s/\n/\\n/smxg;
					   $string    =~ s/"/\\"/smxg;
					   $string    =~ s/'/\\'/smxg;
					   return $string;
					 });
    $self->add_tt_filter('xml_entity', sub {
					    my $string = shift;
					    if(!defined $string) {
					      $string = q[];
					    }
					    return encode_entities_numeric($string),
					  });

    my $filters = Template::Filters->new({
					  FILTERS => $self->tt_filters(),
					 });
    $util->{tt} = Template->new({
				 PLUGIN_BASE  => 'ClearPress::Template::Plugin',
				 RECURSION    => 1,
				 INCLUDE_PATH => (sprintf q(%s/templates), $util->data_path()),
				 EVAL_PERL    => 1,
				 ENCODING     => 'utf8',
				 LOAD_FILTERS => [ $filters ],
				}) or croak $Template::ERROR;
  }
  return $util->{tt};
}

sub decor {
  my $self = shift;
  my $aspect = $self->aspect() || q[];

  if($aspect =~ /(?:rss|atom|ajax|xml|json|js|_png|_jpg|_txt)$/smx) {
    return 0;
  }
  return 1;
}

sub output_flush {
  my $self = shift;
  $DEBUG_OUTPUT and carp "output_flush: @{[scalar @{$self->{output_buffer}}]} blobs in queue";

  eval {
    print @{$self->{output_buffer}} or croak "Error flushing output: $ERRNO";
    1;
  } or do {
    #########
    # client stopped receiving (e.g. disconnect from lengthy streamed response)
    #
    carp $EVAL_ERROR;
  };

  $self->output_reset();
  return 1;
}

sub output_buffer {
  my ($self, @args) = @_;
  if(!$self->output_finished()) {
    push @{$self->{output_buffer}}, @args;
    $DEBUG_OUTPUT and carp "output_buffer added (@{[scalar @args]} blobs)";
  }
  return 1;
}

sub output_finished {
  my ($self, $val) = @_;
  if(defined $val) {
    $self->{output_finished} = $val;
    $DEBUG_OUTPUT and carp "output_finished = $val";
  }
  return $self->{output_finished};
}

sub output_end {
  my $self = shift;
  $DEBUG_OUTPUT and carp "output_end: $self";
  $self->output_finished(1);
  return $self->output_flush();
}

sub output_reset {
  my $self = shift;
  $self->{output_buffer} = [];
  $DEBUG_OUTPUT and carp 'output_reset';
  return;
}

sub actions {
  my $self    = shift;
  my $content = q[];

  $self->process_template('actions.tt2', {}, \$content);
  return $content;
}

# todo: auto-create these <action>_<format> style accessors

sub list_xml {
  my $self = shift;
  return $self->list();
}

sub read_xml {
  my $self = shift;
  return $self->read();
}

sub create_xml {
  my $self = shift;
  return $self->create();
}

sub update_xml {
  my $self = shift;
  return $self->update();
}

sub delete_xml {
  my $self = shift;
  return $self->delete();
}

sub list_ajax {
  my $self = shift;
  return $self->list();
}

sub read_ajax {
  my $self = shift;
  return $self->read();
}

sub create_ajax {
  my $self = shift;
  return $self->create();
}

sub update_ajax {
  my $self = shift;
  return $self->update();
}

sub delete_ajax {
  my $self = shift;
  return $self->delete();
}

sub list_json {
  my $self = shift;
  return $self->list();
}

sub read_json {
  my $self = shift;
  return $self->read();
}

sub create_json {
  my $self = shift;
  return $self->create();
}

sub update_json {
  my $self = shift;
  return $self->update();
}

sub delete_json {
  my $self = shift;
  return $self->delete();
}

1;
__END__