view release on metacpan or  search on metacpan

lib/Apache2/PageKit.pm  view on Meta::CPAN

  # this can maybe changed!? Needs some tests
  my $send_gzipped = ( $retcharset && $pk->{use_gzip} eq 'all' );
  $apr->content_encoding('gzip') if ($send_gzipped);

  $apr->content_type($content_type) unless $apr->main;

  if ($send_gzipped) {
    $apr->print(Compress::Zlib::memGzip($converted_data || $$output_ref));
  } else {
    $apr->print($converted_data || $$output_ref);
  }
}

sub new {
  my $class = shift;

  my $rr = shift || die "missing RequestRec";
  my $self = {@_};

  bless $self, $class;

  # set up contained objects
  my $pkit_root = $rr->dir_config('PKIT_ROOT');
  die "Must specify PerlSetVar PKIT_ROOT in httpd.conf file" unless $pkit_root;
  my $config_dir = $pkit_root . '/Config';
  my $content_dir = $pkit_root . '/Content';
  my $view_dir = $pkit_root . '/View';
  my $server = $rr->dir_config('PKIT_SERVER');
  die "Must specify PerlSetVar PKIT_SERVER in httpd.conf file" unless $server;
  my $config = $self->{config} = Apache2::PageKit::Config->new(config_dir => $config_dir,
                                                              server => $server);
  my $post_max = $self->{config}->get_global_attr('post_max') || 64_000_000;
  my $upload_tmp_dir = $self->{config}->get_global_attr('upload_tmp_dir');

  # the TEMP_DIR option is only avail since version 1.0 of libapreq
  # so we set it only on request.
  my @apr_params = ();
  push @apr_params, TEMP_DIR => $upload_tmp_dir if $upload_tmp_dir;
  my $request_class = $self->{config}->get_global_attr('request_class') || "Apache2::Request::PageKit";
  my $apr = $self->{apr} = $request_class->new($rr, POST_MAX => $post_max, @apr_params);
  my $model_base_class = $self->{config}->get_global_attr('model_base_class') || "MyPageKit::Common";

  $self->_check_gzip;
  
  my $model;
  eval {$model = $self->{model} = $model_base_class->new(pkit_pk => $self)};
  if($@){
    unless($model_base_class){
      die "model_base_class not specified";
    } else {
      die "Model class $model_base_class has no new method ($@)";
    }
  }

  $self->{dbh} = $model->pkit_dbi_connect if $model->can('pkit_dbi_connect');

  my $default_lang = $config->get_global_attr('default_lang') || 'en';
  my $default_input_charset = $config->get_global_attr('default_input_charset') || 'ISO-8859-1';
  my $default_output_charset = $config->get_global_attr('default_output_charset') || 'ISO-8859-1';
  my $html_clean_level = $config->get_server_attr('html_clean_level') || 0;
  my $can_edit = $config->get_server_attr('can_edit') || 'no';
  my $reload = $config->get_server_attr('reload') || 'no';

  my $cache_dir = $config->get_global_attr('cache_dir');
  my $view_cache_dir = $cache_dir ? $cache_dir . '/pkit_cache' : $pkit_root . '/View/pkit_cache';
  my $relaxed_parser = $config->get_global_attr('relaxed_parser') || 'no';
  my $errorspan_begin_tag = $config->get_global_attr('errorspan_begin_tag') || q{<font color="<PKIT_ERRORSTR>">};
  my $errorspan_end_tag   = $config->get_global_attr('errorspan_end_tag')   || q{</font>};
  my $default_errorstr   = $config->get_global_attr('default_errorstr')   || '#ff0000';

  my $uri_prefix = $config->get_global_attr('uri_prefix') || '';

  my $template_class = $config->get_global_attr('template_class')
    || 'HTML::Template';
  my $view_class = $template_class =~ /^HTML::Template/ ? 'Apache2::PageKit::View' : 'Apache2::PageKit::View::TT2';
  $self->{view} = $view_class->new(
					     root_dir => $pkit_root,
  					     view_dir => "$pkit_root/View",
					     content_dir => "$pkit_root/Content",
					     cache_dir => $view_cache_dir,
					     default_lang => $default_lang,
					     default_input_charset => $default_input_charset,
					     default_output_charset => $default_output_charset,
					     reload => $reload,
					     html_clean_level => $html_clean_level,
					     input_param_object => $apr,
					     output_param_object => $self->{output_param_object},
					     can_edit => $can_edit,
                                             relaxed_parser => $relaxed_parser,
                                             errorspan_begin_tag => $errorspan_begin_tag,
                                             errorspan_end_tag => $errorspan_end_tag,
                                             default_errorstr => $default_errorstr,
                                             template_class => $template_class,

					     uri_prefix => $uri_prefix,

					     # used only to set browser_cache = '..' maybe another
					     # way to set browser_cache is better to leave the View
					     # independent from pk
					     pkit_pk => $self,
					    );

  return $self;
}

sub page_sub {
  my $pk = shift;
  my $page_id = shift || $pk->{page_id};

  # change all the / to ::
  $page_id =~ s!/!::!g;

  my $perl_sub;
  if($page_id =~ s/^pkit_edit:://){
    $perl_sub = 'Apache2::PageKit::Edit::' . $page_id;
  } else {
    my $model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');
    $perl_sub = $model_dispatch_prefix . '::' . $page_id;
  }

  return $perl_sub if defined &{$perl_sub};

  my ($class_package) = $perl_sub =~ m/^(.*)::/;
  return if exists $Apache2::PageKit::checked_classes{$class_package};

  # with this funny require line, we can check also for files with expressions like
  # Foo::Bar-Foo::Bar without a warining and this is more secure
  eval "require $class_package" if ( $class_package =~ /^[\w\d:]+$/ );

  $Apache2::PageKit::checked_classes{$class_package} = 1;

  return undef unless (defined &{$perl_sub});

  my $model_base_class = $pk->{config}->get_global_attr('model_base_class') || "MyPageKit::Common";

  warn qq{For full preformance please add "use $class_package" in your $model_base_class or startup.pl script};

  return $perl_sub;
}

sub page_code {
  my $pk = shift;
  my ( $common_page_id, $model_dispatch_prefix, $default_code_perl_sub );

  ( $common_page_id = $pk->{page_id} ) =~ s!/!::!g;
  $model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');
  ( $default_code_perl_sub = $model_dispatch_prefix . '::' . $common_page_id ) =~ s/[^:]+$/pkit_default/;
  $default_code_perl_sub = undef unless (defined &$default_code_perl_sub);

  my @subs = grep { $_ } ( $default_code_perl_sub, $pk->page_sub );
  return $pk->call_model_code(@subs) if (@subs);
  return;
}

sub component_code {
  my $pk = shift;
  my $component_id = shift;

  #remove any leading /
  $component_id =~ s!^/+!!;

  # change all the / to ::
  $component_id =~ s!/!::!g;

  # insert a module_ before the method
#  $component_id =~ s/(.*?)([^:]+)$/$1::$2/;

  my $model_dispatch_prefix = $pk->{config}->get_global_attr('model_dispatch_prefix');

  my $perl_sub = $model_dispatch_prefix . '::' . $component_id;

  return $pk->call_model_code($perl_sub) if (defined &{$perl_sub});
  return;
}