view release on metacpan or  search on metacpan

lib/CGI/Bus/uauth.pm  view on Meta::CPAN

 }
 $d->{-ses}->{$c->[2]} ={-key=> $s->_signrand
                        ,-time=>$s->parent->strtime($c->[2])
                        ,-addr=>$c->[1]
                        };
 $c =$s->_signmk($d->{-ses}->{$c->[2]}->{-key}, @$c);
 return '' if !$c;
 $s->udata->store();
 my $r =shift ||$s->cgi->param($cooknme) ||$s->url; #||$ENV{HTTP_REFERER}
 my @p =(-uri=>$r
        ,-cookie=>[$s->cgi->cookie(-name=>$cooknme,-value=>$c,-path=>'/')]
        );
 push @p, (-nph=>1) if ($ENV{SERVER_SOFTWARE}||'') =~/IIS/
                    || ($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER}); # PerlSendHeader Off
 $s->parent->print->redirect(@p);
 eval{$s->parent->reset};  # for mod_perl
 delete $ENV{REMOTE_USER}; # for mod_perl
 exit;
}



sub logout {	# Clear authentication
 my $s =shift;
 my $r =$_[0] ||$ENV{HTTP_REFERER};
 my @p =(-uri=>$r
        ,-cookie=>[$s->cgi->cookie(-name=>$cooknme,-value=>['',''],-path=>'/',-expires=>'-1d')]
        );
 push @p, (-nph=>1) if ($ENV{SERVER_SOFTWARE}||'') =~/IIS/
                    || ($ENV{MOD_PERL} && !$ENV{PERL_SEND_HEADER}); # PerlSendHeader Off
 $s->parent->print->redirect(@p);
 eval{$s->parent->reset};  # for mod_perl
 delete $ENV{REMOTE_USER}; # for mod_perl
 exit;
}




sub authurl {	# URL to authentication screen with return address
 my $s =shift;
 my $l =scalar(@_) >1 ? shift : ($s->{-login}||$s->parent->set('-login'));
 return '' if !$l;
 return $l .($s->qurl =~m{/([^/]+)$} ? $1 : '') if $l =~m{/$};
 $s->parent->htmlurl($l, $cooknme, shift ||($s->url .($ENV{QUERY_STRING} ? ('?' .$ENV{QUERY_STRING}) :'')));
}



sub authscr {	# User authentication screen
 my $s =shift;
 my $g =$s->cgi;
 $s->parent->userauth(@_);
 my $ha={-align=>'left',-valign=>'top'};
 my $back =$s->cgi->param($cooknme) ||$ENV{HTTP_REFERER};
 $s->print->htpgstart(undef,$s->parent->{-htpnstart});
 $s->print->h1($s->lng(0,'Authentication'));
 $s->print('<table><tr>');
 $s->print->th($ha,$s->lng(0,'UserName'))    ->td($ha,$s->htmlescape($s->parent->user))->text('</tr><tr>');
 $s->print->th($ha,$s->lng(0,'OriginalName'))->td($ha,$s->htmlescape($s->parent->useron))->text('</tr><tr>');
 $s->print->th($ha,$s->lng(0,'Cookie'))      ->td($ha,$s->htmlescape(join(', ',$s->cookie($cooknme))))->text('</tr><tr>');
 $s->print->th($ha,$s->lng(0,'Return'))      ->td($ha,$g->a({href=>$back}, $s->htmlescape($back)))->text('</tr><tr>');
 $s->print('</tr></table>');
 $s->print->htpgend;
}



sub loginscr {	# login via cgi screen
 my $s =shift;
 my $o =shift ||'-lir'; # login, info, register
 my $g =$s->cgi;
 my $rdr =$g->param($cooknme)||$ENV{HTTP_REFERER};
 my $u;
 my $d;
 if ($o !~/l/) {
     $g->param('UserInfo',1) if $o =~/i/; # user info dialog only
     $g->param('Register',1) if $o =~/r/; # register user dialog only
 }
 if (($g->param('Login') || $g->param('UserInfo'))
 && $g->param('user') && $g->param('passwd')) { 
    $u =$s->parent->user($g->param('user'));
    $s->parent->udata->load;
    $d =$s->parent->udata->param;
    $s->die("Wrong password\n") if ($d->{-passwd}||'') ne crypt($g->param('passwd'||''),$u);
    $ENV{REMOTE_USER} =$s->parent->useron;
    if   (!$g->param('UserInfo')) {$s->signset($rdr)}
    else {$s->signset($s->qurl('', $cooknme =>$rdr, 'UserInfo'=>1))}
    exit; # above always
 }
 if ($g->param('UserInfo') ||$g->param('Register')) {
    $s->print->htpgstart(undef,$s->parent->{-htpnstart});
    $s->print('<form method=post>');
    $s->print->hidden($cooknme, $rdr);
    $u ='';
    if ($g->param('UserInfo')) {
       $u =$s->signchk;
       $s->die("No user cookie\n") if !defined($u) ||$u eq '';
       $u =$s->parent->user($u);
     # $s->parent->udata->load; # in signchk
       foreach my $p (qw(email firstname middlename lastname fullname comment)) {
          $g->param($p => $s->udata->param("-$p"))
       }
    }
    $s->print->h1( $g->param('Register')
                 ? $s->lng(0,'Register')
                 : ($s->lng(0,'UserInfo') ." - $u"));
    $s->print->text('<table>');
    my $ha={-align=>'left',-valign=>'top'};
    my @hd=(-size =>30, '-name');
    my @ht=(-cols =>23, -rows=>4, '-name');
    $s->print->tr($g->th($ha,'UserName'),   $g->td($ha,$g->textfield(@hd,'user'))) 
        if $g->param('Register');
    $s->print->tr($g->th($ha,'EMail'),      $g->td($ha,$g->textfield(@hd,'email')));
    $s->print->tr($g->th($ha,'FirstName'),  $g->td($ha,$g->textfield(@hd,'firstname')));
    $s->print->tr($g->th($ha,'MiddleName'), $g->td($ha,$g->textfield(@hd,'middlename')));
    $s->print->tr($g->th($ha,'LastName'),   $g->td($ha,$g->textfield(@hd,'lastname')));
    $s->print->tr($g->th($ha,'FullName'),   $g->td($ha,$g->textfield(@hd,'fullname')));
    $s->print->tr($g->th($ha,'Comment'),    $g->td($ha,$g->textarea (@ht,'comment')));
    $s->print->tr($g->th($ha,'Password'),   $g->td($ha,$g->textfield(@hd,'passwd1')));
    $s->print->tr($g->th($ha,'Password'),   $g->td($ha,$g->textfield(@hd,'passwd2')));