use strict; my $mail_from = q; my $mail_to = q; my $subject_prefix = q<[suika.fam.cx account]>; my $user_data_dir_name = 'data/'; my $user_prop_file_suffix = '.user'; my $group_data_dir_name = 'data/'; my $group_prop_file_suffix = '.group'; my $htpasswd_file_name = 'data/htpasswd'; my $htgroup_file_name = 'data/htgroup'; my $lock_file_name = $user_data_dir_name . '.lock'; use Fcntl ':flock'; my $Lock; sub lock_start () { return if $Lock; open $Lock, '>', $lock_file_name or die "$0: $lock_file_name: $!"; flock $Lock, LOCK_EX; } # lock_start sub get_prop_hash ($) { my $user_prop_file_name = shift; return undef unless -f $user_prop_file_name; my $r = {}; open my $user_prop_file, '<:encoding(utf8)', $user_prop_file_name or die "$0: $user_prop_file_name: $!"; while (<$user_prop_file>) { tr/\x0D\x0A//d; my ($n, $v) = split /:/, $_, 2; if ($n =~ s/^\@//) { push @{$r->{$n} ||= []}, $v // ''; } elsif ($n =~ s/^%//) { $r->{$n}->{$v // ''} = 1; } else { $n =~ s/^\$//; $r->{$n} = $v // ''; } } return $r; } # get_prop_hash sub set_prop_hash ($$) { my $user_prop_file_name = shift;; my $prop = shift; my $has_file = -f $user_prop_file_name; open my $user_prop_file, '>:encoding(utf8)', $user_prop_file_name or die "$0: $user_prop_file_name: $!"; for my $prop_name (sort {$a cmp $b} keys %$prop) { if (ref $prop->{$prop_name} eq 'ARRAY') { my $v = '@' . $prop_name; $v =~ tr/\x0D\x0A://d; for (@{$prop->{$prop_name}}) { my $pv = $_; $pv =~ tr/\x0D\x0A/ /; print $user_prop_file $v . ':' . $pv . "\x0A"; } } elsif (ref $prop->{$prop_name} eq 'HASH') { my $v = '%' . $prop_name; $v =~ tr/\x0D\x0A://d; for (sort {$a cmp $b} keys %{$prop->{$prop_name}}) { next unless $prop->{$prop_name}->{$_}; my $pv = $_; $pv =~ tr/\x0D\x0A/ /; print $user_prop_file $v . ':' . $pv . "\x0A"; } } else { my $v = '$' . $prop_name; $v =~ tr/\x0D\x0A://d; my $pv = $prop->{$prop_name}; $pv =~ tr/\x0D\x0A/ /; print $user_prop_file $v . ':' . $pv . "\x0A"; } } close $user_prop_file; system_ ('cvs', 'add', $user_prop_file_name) unless $has_file; } # set_prop_hash sub commit ($) { my $msg = shift // $0; system_ ('cvs', 'commit', -m => $msg, $user_data_dir_name); } # commit sub get_user_prop ($) { my $user_id = shift; return get_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix); } # get_user_prop sub set_user_prop ($$) { my ($user_id, $prop) = @_; return set_prop_hash ($user_data_dir_name . $user_id . $user_prop_file_suffix, $prop); } # set_user_prop sub get_group_prop ($) { my $group_id = shift; return get_prop_hash ($group_data_dir_name . $group_id . $group_prop_file_suffix); } # get_group_prop sub set_group_prop ($$) { my ($group_id, $prop) = @_; return set_prop_hash ($group_data_dir_name . $group_id . $group_prop_file_suffix, $prop); } # set_group_prop sub get_all_users () { my @r; opendir my $user_data_dir, $user_data_dir_name; for (readdir $user_data_dir) { if (/^([0-9a-z-]+)\Q$user_prop_file_suffix\E$/) { push @r, $1; } } return @r; } # get_all_users sub get_all_groups () { my @r; opendir my $group_data_dir, $group_data_dir_name; for (readdir $group_data_dir) { if (/^([0-9a-z-]+)\Q$group_prop_file_suffix\E$/) { push @r, $1; } } return @r; } # get_all_groups sub regenerate_htpasswd_and_htgroup () { my %htpasswd; my %htgroup; my @group = get_all_groups (); for my $user_id (get_all_users ()) { my $user_prop = get_user_prop ($user_id); next if $user_prop->{disabled}; next unless $user_prop->{pass_crypted}; $htpasswd{$user_id} = $user_prop->{pass_crypted}; for (@group) { if ($user_prop->{'group.' . $_}->{member}) { $htgroup{$_}->{$user_id} = 1; } } } open my $file, '>', $htpasswd_file_name or die "$0: $htpasswd_file_name: $!"; for (sort {$a cmp $b} keys %htpasswd) { print $file $_, ':', $htpasswd{$_}, "\x0A"; } open my $file, '>', $htgroup_file_name or die "$0: $htgroup_file_name: $!"; for my $group_id (sort {$a cmp $b} keys %htgroup) { print $file $group_id, ': ', join ' ', sort {$a cmp $b} keys %{$htgroup{$group_id}}; print $file "\x0A"; } } # regenerate_htpasswd_and_htgroup sub print_error ($$;$) { my ($code, $text, $text_arg) = @_; our $Lang; binmode STDOUT, ':encoding(utf-8)'; my $_text = $text; $_text =~ s/%s/$text_arg/g; print qq[Status: $code $_text Content-Type: text/html; charset=utf-8 $code @{[htescape ($_text)]}

]; print_text ('Error'); print q[

]; print_text ($text, sub { print '', htescape ($text_arg) }); print_text ('.'); print q[]; } # print_error sub check_password ($) { my $cgi = shift; my $user_pass = $cgi->get_parameter ('user-pass'); my $user_pass2 = $cgi->get_parameter ('user-pass2'); if ($user_pass ne $user_pass2) { print_error (400, 'Two passwords you input are different'); exit; } if (4 > length $user_pass) { print_error (400, 'Password must be longer than 3 characters'); exit; } my $pass_crypted = crypt $user_pass, join '', (0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]; return $pass_crypted; } # check_password sub send_mail ($$) { require Net::SMTP; require Encode; my $smtp = Net::SMTP->new ('localhost'); $smtp->mail ($mail_from); $smtp->to ($mail_to); ## NOTE: What's wrong with UTF-8 Subject? :-) $smtp->data (Encode::encode ('utf-8', "From: <$mail_from> To: <$mail_to> Subject: $_[0] Content-Type: text/plain; charset=utf-8 MIME-Version: 1.0 $_[1]")); $smtp->send; } # send_mail sub system_ (@) { (system join (' ', map {quotemeta $_} @_) . " > /dev/null") == 0 or die "$0: $?"; } # system_ sub htescape ($) { my $s = shift; $s =~ s/&/&/g; $s =~ s//>/g; $s =~ s/"/"/g; return $s; } # htescape 1;