#!/usr/bin/perl
use strict;
use lib qw[/home/httpd/html/www/markup/html/whatpm
/home/wakaba/work/manakai2/lib];
use CGI::Carp qw[fatalsToBrowser];
require Message::CGI::Carp;
require 'users.pl';
require Message::CGI::HTTP;
require Encode;
my $cgi = Message::CGI::HTTP->new;
$cgi->{decoder}->{'#default'} = sub {
return Encode::decode ('utf-8', $_[1]);
};
require Message::DOM::DOMImplementation;
my $dom = Message::DOM::DOMImplementation->new;
my $path = $cgi->path_info;
$path = '' unless defined $path;
my @path = split m#/#, percent_decode ($path), -1;
shift @path;
if (@path == 1 and $path[0] eq 'new-user') {
if ($cgi->request_method eq 'POST') {
lock_start ();
binmode STDOUT, ':encoding(utf-8)';
my $user_id = $cgi->get_parameter ('user-id');
if ($user_id !~ /\A[0-9a-z-]{4,20}\z/) {
print_error (400, qq[User id "$user_id" is invalid; use characters [0-9a-z-]{4,20}]);
exit;
}
if (get_user_prop ($user_id)) {
print_error (400, qq[User id "$user_id" is already used]);
exit;
}
my $pass_crypted = check_password ($cgi);
my $user_prop = {id => $user_id, pass_crypted => $pass_crypted};
set_user_prop ($user_id, $user_prop);
commit ();
my $user_url = get_absolute_url ('../edit/users/' . $user_id . '/');
print qq[Status: 201 User registered
Location: $user_url
Content-Type: text/html; charset=utf-8
User "@{[htescape ($user_id)]}" registered
User "@{[htescape ($user_id)]}" registered
Your user account is created successfully.
See your user account information page.];
exit;
} else {
binmode STDOUT, ":encoding(utf-8)";
print qq[Content-Type: text/html; charset=utf-8
Create a new user account
Create a new user account
];
exit;
}
} elsif (@path == 0) {
my $root_url = get_absolute_url ('add/new-user');
print qq[Status: 301 Moved permanently
Location: $root_url
Content-Type: text/html; charset=us-ascii
See other page.];
exit;
}
print_error (404, 'Not found');
exit;
sub percent_decode ($) {
return $dom->create_uri_reference ($_[0])
->get_iri_reference
->uri_reference;
} # percent_decode
sub get_absolute_url ($) {
return $dom->create_uri_reference ($_[0])
->get_absolute_reference ($cgi->request_uri)
->get_iri_reference
->uri_reference;
} # get_absolute_url