view release on metacpan or  search on metacpan

lib/AuthCAS.pm  view on Meta::CPAN

        $errors = sprintf "Unable to parse URL '%s'\n", $url;
        return undef;
    }

    return ( $host, $port, $path );
}

## Simple XML parser
sub _parse_xml {
    my $data = shift;

    my %xml_struct;

    while ( $data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) {
        my ( $new_tag, $new_data ) = ( $1, $3 );
        chomp $new_data;
        $new_data =~ s/^[\s\n]+//m;
        $data     =~ s/^<$new_tag(\s+[^\s>]+)*>([\s\S\n]*)(<\/$new_tag>)//m;
        $data     =~ s/^[\s\n]+//m;

        ## Check if data still includes XML tags
        my $struct;
        if ( $new_data =~ /^<([^\s>]+)(\s+[^\s>]+)*>([\s\S\n]*)(<\/\1>)/m ) {
            $struct = &_parse_xml($new_data);
        }
        else {
            $struct = $new_data;
        }
        push @{ $xml_struct{$new_tag} }, $struct;
    }

    return \%xml_struct;
}

=pod

=head2 getServerLoginURL($service)

Returns a URL that you can redirect the browser to, which includes the URL to return to

TODO: it escapes the return URL, but I've noticed some issues with more complicated URL's

=cut

sub getServerLoginURL {
    my $self    = shift;
    my $service = shift;

    return
        $self->{'url'}
      . $self->{'loginPath'}
      . '?service='
      . &_escape_chars($service);
}

=pod

=head2 getServerLoginGatewayURL($service)

Returns non-blocking login URL
ie: if user is logged in, return the ticket, otherwise do not prompt for login

=cut

sub getServerLoginGatewayURL {
    my $self    = shift;
    my $service = shift;

    return
        $self->{'url'}
      . $self->{'loginPath'}
      . '?service='
      . &_escape_chars($service)
      . '&gateway=1';
}

=pod

=head2 getServerLogoutURL($service)

Return logout URL
After logout user is redirected back to the application

=cut

sub getServerLogoutURL {
    my $self    = shift;
    my $service = shift;

    return
        $self->{'url'}
      . $self->{'logoutPath'}
      . '?service='
      . &_escape_chars($service)
      . '&gateway=1';
}

=pod

=head2 getServerServiceValidateURL($service, $ticket, $pgtUrl)

Returns 

=cut

sub getServerServiceValidateURL {
    my $self    = shift;
    my $service = shift;
    my $ticket  = shift;
    my $pgtUrl  = shift;

    my $query_string =
      'service=' . &_escape_chars($service) . '&ticket=' . $ticket;
    if ( defined $pgtUrl ) {
        $query_string .= '&pgtUrl=' . &_escape_chars($pgtUrl);
    }

    ## URL was /validate with CAS 1.0
    return
        $self->{'url'}
      . $self->{'serviceValidatePath'} . '?'