#!/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 'texts.pl';
our $subject_prefix;
require Message::CGI::HTTP;
require Encode;
my $cgi = Message::CGI::HTTP->new;
$cgi->{decoder}->{'#default'} = sub {
return Encode::decode ('utf-8', $_[1]);
};
our $Lang = 'ja'
if $cgi->get_meta_variable ('HTTP_ACCEPT_LANGUAGE') =~ /\bja\b/; ## TODO: ...
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,
q[User id %s is invalid; use characters [0-9a-z-]{4,20}],
$user_id);
exit;
}
if (get_user_prop ($user_id)) {
print_error (400, q[User id %s is already used], $user_id);
exit;
}
my $pass_crypted = check_password ($cgi);
my $user_prop = {id => $user_id, pass_crypted => $pass_crypted};
set_user_prop ($user_id, $user_prop);
send_mail ("$subject_prefix User $user_id created",
"User: $user_id\nStatus: User registered\n");
regenerate_htpasswd_and_htgroup ();
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
];
print_text ('User %s registered', sub { print '', htescape ($user_id) });
print q[
];
print_text ('User %s registered', sub { print '', htescape ($user_id) });
print q[
];
print_text ('Your user account is created successfully.');
print q[
];
print_text ('See %s.', sub {
print qq[];
print_text ('your user account information page');
print q[];
});
exit;
} else {
binmode STDOUT, ":encoding(utf-8)";
print q[Content-Type: text/html; charset=utf-8
];
print_text ('Create a new user account');
print q[
];
print_text ('Create a new user account');
print q[
];
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