view release on metacpan or  search on metacpan

lib/Authen/Ticket/Server.pm  view on Meta::CPAN

# 3. Neither the name of the University nor the names of its contributors
#    may be used to endorse or promote products derived from this software
#    without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTERS ``AS IS''
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.

package Authen::Ticket::Server;

use strict;
use vars qw($VERSION @ISA %DEFAULTS);

use CGI ();
use MIME::Base64 (qw/encode_base64/);
use Carp;


$VERSION = '0.02';
@ISA = (qw/Apache/);

%DEFAULTS = (
  TicketExpires => 900,
  TicketDomain  => undef,
  TicketName    => 'ticket',
);

sub debug {
  my $self = shift;

  if($$self{_log}) {
    $$self{_log}->debug(join($,,@_));
  } elsif($$self{DEBUG}) {
    carp join($,,@_);
  }
}

sub new {
  my $class = shift;
  $class = ref($class) || $class;
  my $r;
  my $self = { };

  if($ENV{MOD_PERL}) {
    $r = shift;
    unless(ref $r) {
      unshift @_, $r;
      $r = '';
    }
    $r ||= Apache->request;
    $self->{_r} = $r;
    $self->{_log} = $r->log;
    $ENV{HTTP_COOKIE} ||= $r->headers_in->{Cookie};
  }

  bless $self, $class;

  $self->{query} = $self->get_query_object;
  $self->{stdout} = $self->get_stdout_object;

  $self->{request_uri} = $$self{query}->param('request_uri');

  if($$self{_r}) {
    $self->{request_uri} ||= $self->prev && $self->prev->uri;
  }
  $self->debug("Request URI: [", $$self{request_uri}, "]");

  my $cookie = $$self{query}->cookie('request_uri');

  $self->debug("Cookie: [", $cookie, "]");

  $self->{request_uri} ||= $cookie;

  $self->{has_cookies} = 1 if $cookie;

  $self->configure(@_);

  $self->initialize;

  return $self
}

sub configure {
  my $self = shift;
  my %opts = (@_);

  # build options hash
  my %defaults = ( );
  my @classes = ( );
  my %classes_seen = ( );

  push @classes, (ref $self or $self);

  while(@classes) {
    no strict;
    my $class = shift @classes;
    next if $classes_seen{$class};
    $classes_seen{$class}++;
    push @classes, @{ "$class\::ISA" };

    if(defined %{ "$class\::DEFAULTS" }) {
      foreach my $k ( keys %{ "$class\::DEFAULTS" } ) {
        $defaults{$k} ||= ${ "$class\::DEFAULTS" }{$k};
      }
    }
  }

  if($$self{_r}) {
    foreach my $k (keys %defaults) {
      $self->{$k} = $self->dir_config($k);
    }

    unless($self->{TicketDomain}) {
      $$self{TicketDomain} = $self->server->server_hostname;
      $$self{TicketDomain} =~ s/^[^.]+//;
    }
  }

  foreach my $k (keys %defaults) {
    $$self{$k} ||= $opts{$k} || $defaults{$k};
    $self->debug("$k set to $$self{$k}");
  }
}

sub initialize { }

sub get_query_object {
  my $self = shift;

  return $$self{query} || $CGI::DefaultClass->new;