***** infoCopter.com/perl *****

Basic Authorization

Basic Authorization with Perl

Basic Authorization without LWP

Request a protected document as a client

#!/usr/bin/perl -w

################################################
#       Usage:
#
#       e.g.
#       ./xdbclient.dbc yourhost.org /private/ Zm9vOmJhcg==
################################################
use Socket;

unless (&open_TCP(F, $ARGV[0], 80)) {
        print "Error";
        exit(-1);
}

print F "GET $ARGV[1] HTTP/1.0\n";
print F "Authorization: BASIC $ARGV[2]\n\n";

while(<F>) {
        print;
}

close F;


sub open_TCP (@) {

        my ($FS, $dest, $port) = @_;

        my $proto = getprotobyname('tcp');
        socket($FS, PF_INET, SOCK_STREAM, $proto);
        my $sin = sockaddr_in($port, inet_aton($dest));

        connect($FS, $sin) || return undef;

        my $old_fh = select($FS);
        $| = 1;
        select($old_fh);
        1;
}

Server Implementation

mod_perl Version

package testauth::Login;

use strict;
use warnings;

# ---------------------------------------------------
# Basic Auth Sample
# retoh :)
# ---------------------------------------------------
  
use Apache::Access ();
use Apache::RequestUtil ();
  
use Apache::Const -compile => qw(OK DECLINED AUTH_REQUIRED);
  
  sub handler {
      my $r = shift;
  
      my ($status, $password) = $r->get_basic_auth_pw;
      return $status unless $status == Apache::OK;

	my $user = $r->user;

	if ($user) {
		$r->content_type('text/html');
		print qq~
		<html>
		<h2>You have entered username / password: <br> <br>

		$user / $password</h2>

		<p><a href="Login.txt">View Source Code</a></p>
		</html>~;

		return Apache::OK;
	}
	else {
		$r->note_basic_auth_failure;
		return Apache::AUTH_REQUIRED;
	}
  }
  
1;

[ Try it out ]

© reto :)