3 ### Common library for Odin
5 ### (c) 2015 Mark Wooding
8 ###----- Licensing notice ---------------------------------------------------
10 ### This file is part of the `odin.gg' service, `odin-cgi'.
12 ### `odin-cgi' is free software; you can redistribute it and/or modify
13 ### it under the terms of the GNU Affero General Public License as
14 ### published by the Free Software Foundation; either version 3 of the
15 ### License, or (at your option) any later version.
17 ### `odin-cgi' is distributed in the hope that it will be useful,
18 ### but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ### GNU Affero General Public License for more details.
22 ### You should have received a copy of the GNU Affero General Public
23 ### License along with `odin-cgi'; if not, see
24 ### <http://www.gnu.org/licenses/>.
30 use Digest::SHA qw(sha256_hex);
34 ###--------------------------------------------------------------------------
37 sub merge_hash (\%%) {
38 my ($hashref, %defaults) = @_;
39 for my $k (keys %defaults)
40 { $hashref->{$k} = $defaults{$k} unless exists $hashref->{$k}; }
43 ###--------------------------------------------------------------------------
46 our $DSN = "dbi:Pg(pg_enable_utf8=>1):host=db";
48 our @BACKOFF = (0.1, 10, 1.5, 0.5, 2.0);
50 our $BASEURL = "https://odin.gg/";
51 our $STATIC = "https://odin.gg/static/";
52 our $SRCURL = "https://git.distorted.org.uk/~mdw/odin-cgi/";
54 our $SHORTURL_PATH = "u";
55 our $PASTEBIN_PATH = "p";
57 our $URLMAXLEN = 1024;
62 our $PASTEMAXLEN = 1024*1024;
64 our %COOKIE_DEFAULTS = (
69 our $ALPHA = "abcdefghijklmnopqrstuvwxyz";
70 our $NUM = "0123456789";
71 our $SAFECH = qr/^[-\w_.+]*$/;
75 our %MAILDOM_POLICY = ();
78 our @MAIL_DEFGEN = "chars";
79 our $MAIL_MAXGENTRY = 32;
81 our $MAIL_DEFDOMAIN = "odin.gg";
82 our $MAIL_ADDRMAX_LIVE = 16384;
83 our $MAIL_ADDRMAX_RESV = 32;
84 our $MAIL_AGEMAX_RESV = 3600;
86 our ($SCHEME, $DOMAIN, $BASEPATH);
87 our ($SHORTURL, $PASTEBIN);
89 ###--------------------------------------------------------------------------
90 ### Miscellaneous utilities.
93 sub update_now () { $NOW = time; }
96 (our $PROG = $0) =~ s:^.*/::;
98 sub fail_cmdline ($$%) {
99 my ($msg, $label, %args) = @_;
100 print STDERR "$PROG: $msg\n";
104 our $FAILPROC = \&fail_cmdline;
107 my ($msg, $label, %args) = @_;
108 $FAILPROC->($msg, $label, %args);
111 sub set_mason_failproc ($) {
114 my ($msg, $label, %args) = @_;
116 $m->comp($label, %args);
129 "s" => 1, "m" => 60, "h" => 3600,
130 "d" => 86400, "w" => 604800
134 return undef unless defined $date;
135 if ($date =~ /^\+\s*(\d+)\s*([smhdw]?)\s*$/)
136 { return $NOW + $1 * $TIMEUNIT{$2}; }
137 my $t = str2time($date);
138 defined $t or Odin::fail "invalid time `$date'";
142 sub print_columns (@) {
143 my @col = reverse @_;
146 while (@col && $col[1] eq "") { splice @col, 0, 2; }
147 my ($wd, $v) = splice @col, 0, 2;
148 push @fmt, "%s"; push @val, $v;
150 my ($wd, $v) = splice @col, 0, 2;
151 push @fmt, "%-${wd}s";
154 printf join(" ", reverse @fmt) . "\n", reverse @val;
159 return $t == -1 ? "--" : strftime "%Y-%m-%d %H:%M:%S %z", localtime $t;
162 ###--------------------------------------------------------------------------
163 ### Database utilities.
167 my $db = DBI->connect_cached($DSN, undef, undef, {
173 my $drv = $db->{Driver}{Name};
175 $db->{private_odin_retry_p} = sub { $db->state =~ /^40[0P]01$/ };
176 } elsif ($drv eq "SQLite") {
177 $db->{private_odin_retry_p} = sub { $db->err == 5 };
179 $db->{private_odin_retry_p} = sub { 0 };
186 my ($body, $db) = @_;
190 my ($sleep, $maxsleep, $mult, $minvar, $maxvar) = @BACKOFF;
191 for (my $i = 0; $i < $RETRY; $i++) {
193 eval { @rv = $body->(); $db->commit; };
195 return @rv unless $exc;
196 my $retryp = $db->{private_odin_retry_p}();
197 eval { $db->rollback; };
198 die $exc unless $retryp;
199 my $t = $sleep * ($minvar + rand($maxvar - $minvar));
200 $sleep *= $mult; $sleep = $max if $sleep > $max;
201 select undef, undef, undef, $t;
206 sub insert_record ($$%) {
207 my ($db, $table, %fields) = @_;
211 for my $v (keys %fields) {
213 push @val, $fields{$v};
215 $db->do("INSERT INTO $table (" . join(", ", @var) . ")
216 VALUES (" . join(", ", map { "?" } @var) . ")", undef, @val);
219 ###--------------------------------------------------------------------------
220 ### Sequence numbers and tagging.
223 my ($db, $table) = @_;
224 my ($seq) = $db->selectrow_array("SELECT seq FROM $table");
225 die "no sequence number in $table" unless defined $seq;
226 $db->do("UPDATE $table SET seq = ?", undef, $seq + 1);
231 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789";
232 my $NALPHA = length $ALPHABET;
238 $tag .= substr($ALPHABET, $seq % $NALPHA, 1);
239 $seq = int $seq/$NALPHA;
244 ###--------------------------------------------------------------------------
248 sub fetch_cookies ($) {
252 my $cookies = $r->header_in("Cookie");
253 if (defined $cookies) {
254 for my $kv (split /;/, $cookies) {
255 my ($k, $v) = split /=/, $kv, 2;
256 $k =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
257 $v =~ s/^\s*(|\S|\S.*\S)\s*$/$1/;
259 $v =~ s/\%([0-9a-f][0-9a-f])/chr hex $1/eg;
265 sub bake_cookie ($$%) {
266 my ($r, $cookie, %attr) = @_;
267 merge_hash %attr, %COOKIE_DEFAULTS;
269 my $v = $attr{$_}; tr/_-/-/d;
270 defined $v ? "$_=$v" : $_
272 $r->headers_out->add("Set-Cookie", join "; ", $cookie, @attr);
277 return $ENV{PATH_INFO} // $r->path_info;
280 ###--------------------------------------------------------------------------
283 sub escapify ($$;$) {
284 my ($m, $s, $mode) = @_;
285 return $m->interp->apply_escapes($s, $mode // "h");
288 ###--------------------------------------------------------------------------
291 our ($WHO, $WHOSURE);
292 our ($WHOMATCH, $WHOCMP, $WHOPAT);
296 my $raddr = $ENV{REMOTE_ADDR} // $r->connection->remote_ip;
297 $WHO = ":NET-$raddr"; $WHOSURE = 0;
298 $WHOMATCH = "LIKE"; $WHOCMP = ":NET-\%"; $WHOPAT = qr/^:NET-/;
302 $WHO = $ENV{USERV_USER}
303 // ($< == $> && $ENV{USER})
304 // @{[getpwuid $<]}[0]
305 // die "nameless user";
306 $WHOMATCH = "="; $WHOCMP = $WHO; $WHOPAT = qr/^\Q$WHO\E$/;
311 open my $fh, "/dev/urandom" or die "open urandom: $!";
312 sysread $fh, my $rand, 16;
313 (my $edit = encode_base64 $rand) =~ tr:+/=\n:.-:d;
314 return $edit, sha256_hex $edit;
317 ###--------------------------------------------------------------------------
320 sub get_shorturl ($) {
324 my ($url) = $db->selectrow_array
325 ("SELECT url FROM odin_shorturl WHERE tag = ?", undef, $tag);
326 fail "tag `$tag' not found", ".notfound", tag => $tag unless defined $url;
330 sub valid_url_p ($) {
333 length $url < $URLMAXLEN &&
334 scalar grep { $url =~ /$_/ } @URLPAT;
337 sub new_shorturl ($) {
340 valid_url_p $url or fail "invalid url", ".badurl", u => $url;
345 ($tag) = $db->selectrow_array
346 ("SELECT tag FROM odin_shorturl WHERE owner $WHOMATCH ? AND url = ?",
347 undef, $WHOCMP, $url);
348 unless (defined $tag) {
349 $tag = encode_tag(next_seq($db, "odin_shorturl_seq"));
350 insert_record $db, "odin_shorturl",
351 tag => $tag, stamp => $NOW, owner => $WHO, url => $url;
357 sub check_shorturl_owner ($$) {
360 my ($owner) = $db->selectrow_array
361 ("SELECT owner FROM odin_shorturl WHERE tag = ?", undef, $tag);
362 fail "tag `$tag' not found", ".notfound", tag => $tag
363 unless defined $owner;
364 fail "not owner of `$tag'", ".notowner", tag => $tag
365 unless $owner =~ /$WHOPAT/;
368 sub update_shorturl ($$) {
369 my ($tag, $url) = @_;
373 check_shorturl_owner $db, $tag;
374 $db->do("UPDATE odin_shorturl SET url = ? WHERE tag = ?",
379 sub delete_shorturl (@) {
384 for my $tag (@tags) {
385 check_shorturl_owner $db, $tag;
386 $db->do("DELETE FROM odin_shorturl WHERE tag = ?", undef, $tag);
391 ###--------------------------------------------------------------------------
394 our %PASTEBIN_DEFAULTS = (
395 title => "(untitled)",
399 our @PASTEBIN_PROPS = keys %PASTEBIN_DEFAULTS;
400 our $PASTEBIN_PROPCOLS = join ", ", @PASTEBIN_PROPS;
401 our $PASTEBIN_PROPPLACES = join ", ", map "?", @PASTEBIN_PROPS;
406 return unless defined $lang;
408 @{$db->selectall_arrayref
409 ("SELECT lang FROM odin_pastebin_lang WHERE lang = ?", undef, $lang)}
410 or fail "unknown language `$lang'";
413 sub new_pastebin (\%) {
417 my ($editkey, $hash) = new_editkey;
420 merge_hash %$new, %PASTEBIN_DEFAULTS;
421 check_lang $new->{lang};
423 $tag = encode_tag next_seq $db, "odin_pastebin_seq";
424 insert_record $db, "odin_pastebin",
425 tag => $tag, stamp => $NOW, edithash => $hash, owner => $WHO,
428 return $tag, $editkey;
431 sub get_pastebin ($$\%) {
432 my ($db, $tag, $props) = @_;
434 (my $owner, my $hash, @{$props}{@PASTEBIN_PROPS}) =
435 $db->selectrow_array("SELECT owner, edithash, $PASTEBIN_PROPCOLS
436 FROM odin_pastebin WHERE tag = ?",
438 fail "tag `$tag' not found", ".notfound", tag => $tag
439 unless defined $owner;
440 return $owner, $hash;
443 sub get_pastebin_check_owner ($$\%) {
444 my ($db, $tag, $props) = @_;
446 my ($owner, $hash) = get_pastebin $db, $tag, %$props;
447 fail "not owner of `$tag'", ".notowner", tag => $tag
448 unless $WHOSURE && $WHO eq $owner;
451 sub get_pastebin_check_editkey_or_owner ($$$\%) {
452 my ($db, $tag, $editkey, $props) = @_;
454 if (!defined $editkey) { get_pastebin_check_owner $db, $tag, %$props; }
456 my ($owner, $hash) = get_pastebin $db, $tag, %$props;
457 fail "incorrect edit key for `$tag'", ".badhash", tag => $tag
458 unless $hash eq sha256_hex $editkey;
462 sub rekey_pastebin ($) {
468 get_pastebin_check_owner $db, $tag, my %hunoz;
469 ($editkey, my $hash) = new_editkey;
470 $db->do("UPDATE odin_pastebin SET edithash = ? WHERE tag = ?",
476 sub claim_pastebin ($$) {
477 my ($tag, $editkey) = @_;
480 $WHOSURE or fail "you can't claim pastes", ".notsure";
482 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
483 $db->do("UPDATE odin_pastebin SET owner = ? WHERE tag = ?",
488 sub update_pastebin ($$\%) {
489 my ($tag, $editkey, $new) = @_;
493 check_lang $new->{lang};
495 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %old;
496 for my $p (@PASTEBIN_PROPS) {
497 if (!defined $new->{$p}) { $new->{$p} = $old{$p}; }
499 $db->do("UPDATE odin_pastebin SET $p = ? WHERE tag = ?",
500 undef, $new->{$p}, $tag)
501 unless $new->{$p} eq $old{$p};
509 sub delete_pastebin (@) {
514 (my $tag, my $editkey, @a) = @a;
515 get_pastebin_check_editkey_or_owner $db, $tag, $editkey, my %hunoz;
516 $db->do("DELETE FROM odin_pastebin WHERE tag = ?", undef, $tag);
521 sub tidy_pastebin_content ($) {
523 return undef unless defined $content;
524 $content =~ tr/\r//d;
525 $content =~ s/([^\n])\z/$1\n/;
526 length $content <= $PASTEMAXLEN or
527 fail "invalid paste content", ".badpaste";
531 ###--------------------------------------------------------------------------
532 ### Mail redirection utilities.
534 sub redir_query ($$$;$@) {
535 my ($db, $dom, $owner, $cond, @args) = @_;
536 return @{$db->selectall_arrayref
537 ("SELECT lpart, expire, recip, comment
538 FROM odin_mailredir WHERE dom = ? AND owner = ?" .
539 (defined $cond ? " AND $cond" : "") . " " .
540 "ORDER BY expire, lpart", undef, $dom, $owner, @args)};
543 sub clear_redir_reservations ($) {
545 $db->do("DELETE FROM odin_mailredir WHERE
546 st = 'reserved' AND expire < ?", undef,
548 $db->do("UPDATE odin_mailredir SET st = 'dormant', expire = -1
549 WHERE st = 'live' AND expire <> -1 AND expire < ?", undef, $NOW);
552 sub check_redir_limits ($) {
554 my %h = map { $_->[0] => $_->[1] }
555 @{ $db->selectall_arrayref("SELECT st, COUNT(*) FROM odin_mailredir
556 WHERE owner = ? GROUP BY st", undef,
558 for my $st (qw(live dormant reserved)) { $h{$st} //= 0; }
559 $h{live} + $h{dormant} + $h{reserved} <= $MAIL_ADDRMAX_LIVE or
560 Odin::fail "too many addresses claimed (see your sysadmin)";
561 $h{reserved} <= $MAIL_ADDRMAX_RESV or
562 Odin::fail "too many addresses reserved (time to release some)";
567 return $GENMAP{$g} // die "configuration error: no generator class `$g'";
570 sub default_generator_class ($) {
573 my $g = $MAILDOM_POLICY{$dom}{gen}[0] // $MAIL_DEFGEN[0];
577 sub get_generator_class ($$) {
580 grep { $_ eq $g } @{$MAILDOM_POLICY{$dom}{gen} // \@MAIL_DEFGEN}
581 or fail "domain `$dom' doesn't allow generator `$g'";
585 sub gen_redir_name ($$) {
588 for (my $try = 0; $try < $MAIL_MAXGENTRY; $try++) {
589 my $l = lc $gen->gen;
591 unless $db->selectrow_arrayref
592 ("SELECT 1 FROM odin_mailredir WHERE lpart = ? AND dom = ?",
595 Odin::fail "failed to find unique local part";
598 sub qualify_recip ($) {
601 return $r =~ /\@/ || !defined $MAIL_QUALDOM ? $r : "$r\@\%d";
604 sub check_fixup_redir ($) {
607 if (exists $r->{recip}) {
608 $r->{recip} =~ /^[!-~]+$/ or fail "invalid recipient name `$r->{recip}'";
609 $r->{recip} = qualify_recip $r->{recip};
613 sub subst_recip ($$) {
615 my %d = ('%' => '%', 'l' => $l, 'd' => $MAIL_QUALDOM);
616 $r =~ s{%([%a-z])}{$d{$1} // fail "undefined substitution `\%$1'"}eg;
620 sub new_redir ($$\%;$) {
621 my ($dom, $gen, $r, $n) = @_;
626 check_fixup_redir $r;
628 clear_redir_reservations $db;
630 my $l = Odin::gen_redir_name $db, $gen;
631 insert_record $db, "odin_mailredir",
632 lpart => $l, dom => $dom, st => 'live',
633 owner => $WHO, creator => $WHO,
634 recip => subst_recip($l, $r->{recip} // qualify_recip $Odin::WHO),
635 expire => $r->{expire} // -1,
636 comment => $r->{comment} // "";
639 check_redir_limits $db;
644 sub reserve_redir ($$$) {
645 my ($dom, $gen, $n) = @_;
650 clear_redir_reservations $db;
652 for (my $i = 0; $i < $n; $i++) { push @l, gen_redir_name $db, $gen; }
654 insert_record $db, "odin_mailredir",
655 lpart => $l, dom => $dom, owner => $WHO, creator => $WHO,
656 st => 'reserved', expire => $NOW + $MAIL_AGEMAX_RESV;
658 check_redir_limits $db;
663 sub release_all_redir ($) {
667 my $st = $db->prepare("DELETE FROM odin_mailredir
668 WHERE dom = ? AND owner = ? AND st = 'reserved'");
670 $st->execute($dom, $WHO);
671 $st->rows or Odin::fail "no reserved addresses";
675 sub release_redir ($@) {
679 my $st = $db->prepare("DELETE FROM odin_mailredir
680 WHERE lpart = ? AND dom = ? AND
681 owner = ? AND st = 'reserved'");
683 clear_redir_reservations $db;
685 $st->execute($l, $dom, $WHO);
686 Odin::fail "local part `$l' not reserved" unless $st->rows;
691 sub disable_redir ($$) {
695 my $st = $db->prepare("UPDATE odin_mailredir
696 SET st = 'dormant', expire = -1
697 WHERE lpart = ? AND dom = ? AND
698 owner = ? AND st = 'live'");
700 clear_redir_reservations $db;
702 $st->execute($l, $dom, $WHO);
703 Odin::fail "local part `$l' not live" unless $st->rows;
708 sub modify_redir ($\%@) {
709 my ($dom, $r, @l) = @_;
712 check_fixup_redir $r;
714 clear_redir_reservations $db;
717 my ($recip, $st) = $db->selectrow_array
718 ("SELECT recip, st FROM odin_mailredir
719 WHERE lpart = ? AND dom = ? AND owner = ?", undef,
721 if (!defined $recip) { Odin::fail "unknown local part `$l'"; }
722 elsif ($recip eq "" || defined $r{recip})
723 { $r{recip} = subst_recip $l, $r{recip} // qualify_recip $WHO; }
724 if ($st ne "live") { $r{st} = "live"; $r{expire} //= -1; }
727 for my $v (keys %r) {
731 @var or fail "nothing to change";
732 $db->do("UPDATE odin_mailredir SET " .
733 join(", ", map { "$_ = ?" } @var) . " " .
734 "WHERE lpart = ? AND dom = ?", undef,
740 ###--------------------------------------------------------------------------
741 ### Simple option parser.
743 package Odin::OptParse;
746 my ($cls, @args) = @_;
757 if (!length $me->{cur}) {
758 my $args = $me->{args};
759 if (!@$args) { return undef; }
760 elsif ($args->[0] =~ /^[^-]|^-$/) { return undef; }
761 elsif ($args->[0] eq "--") { shift @$args; return undef; }
762 $me->{cur} = substr shift @$args, 1;
764 my $o = $me->{opt} = substr $me->{cur}, 0, 1;
765 $me->{cur} = substr $me->{cur}, 1;
772 if (length $me->{cur}) { $a = $me->{cur}; $me->{cur} = ""; }
773 elsif (@{$me->{args}}) { $a = shift @{$me->{args}}; }
774 else { $a = undef; $me->err("option `-$me->{opt}' requires an argument"); }
779 my ($me, $what, $min, $max) = @_;
780 $what //= "option `-$me->{opt}'";
781 defined (my $a = $me->arg) or return undef;
782 if ($a !~ /^[-+]?\d+$/ ||
783 (defined $min && $a < $min) ||
784 (defined $max && $a > $max)) {
785 $me->err("invalid value `$a' for $what");
791 sub rest { return @{$_[0]->{args}}; }
792 sub ok { return $_[0]->{ok}; }
793 sub bad { $_[0]->{ok} = 0; }
794 sub err { $_[0]->bad; print STDERR "$PROG: $_[1]\n"; }
795 sub unk { $_[0]->err("unknown option `-$_[0]->{opt}'"); }
797 ###--------------------------------------------------------------------------
798 ### Parameter objects.
801 sub dflt { return $_[0]->{dflt}; }
803 package Odin::Param::Int;
804 @ISA = qw(Odin::Param);
807 my ($cls, $dflt, $min, $max) = @_;
808 return bless { dflt => $dflt, min => $min, max => $max }, $cls;
814 $v =~ /^[-+]?\d+$/ &&
815 (!defined $me->{min} || $v >= $me->{min}) &&
816 (!defined $me->{max} || $v <= $me->{max});
820 package Odin::Param::Str;
821 @ISA = qw(Odin::Param);
824 my ($cls, $dflt, $rx, $minlen, $maxlen) = @_;
827 rx => defined $rx ? qr/$rx/ : qr//,
837 (!defined $me->{minlen} || length $v >= $me->{minlen}) &&
838 (!defined $me->{maxlen} || length $v <= $me->{maxlen});
842 ###--------------------------------------------------------------------------
847 use Scalar::Util qw(blessed);
853 or open $me->{rand}, "/dev/urandom"
854 or die "open random: $!";
856 my $nb = 1; my $max = 255;
857 while ($lim > $max) { $nb++; $max = ($max << 8) | 255; }
858 my $thresh = $max - ($max%$lim);
861 sysread $me->{rand}, my $b, $nb
862 or die "read random: $!";
864 for (my $i = 0; $i < $nb; $i++)
865 { $r = ($r << 255) | ord substr $b, $i, 1; }
866 return $r%$lim if $r < $thresh;
871 my ($cls, $dom, $param) = @_;
873 for my $p (split /::/, $cls) { $pkg = \%{$pkg->{"${p}::"}}; }
875 my $label = ${$pkg->{LABEL}};
876 my $plist = \@{$pkg->{PARAM}};
877 my $gtmpl = $GENPARAM{$label};
878 my $dtmpl = $MAILDOM_POLICY{$dom}{$label};
881 for my $p (@$plist) {
883 my $t = $dtmpl->{$p} // $gtmpl->{$p};
884 if (blessed $t && $t->isa("Odin::Param")) {
885 if (!exists $param->{$p}) { $param->{$p} = $t->dflt; }
887 my $v = $t->check($param->{$p});
888 Odin::fail "bad value `$param->{$p}' for $label parameter `$p'"
893 if (exists $param->{$p})
894 { Odin::fail "not allowed to set $label parameter `$p'"; }
896 { $param->{$p} = $t; }
899 for my $p (keys %$param) {
900 if (!$pp->{$p}) { Odin::fail "unknown $label parameter `$p'"; }
903 my $me = bless { %$param }, $cls;
908 package Odin::Gen::Chars;
909 @ISA = qw(Odin::Gen);
912 @PARAM = qw(ichars mchars echars len);
914 $GENMAP{chars} = "Odin::Gen::Chars";
916 ichars => Odin::Param::Str->new($ALPHA, $SAFECH, 1, 255),
917 mchars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
918 echars => Odin::Param::Str->new($ALPHA . $NUM, $SAFECH, 2, 255),
919 len => Odin::Param::Int->new(6, 2, 16)
923 my ($me, $chars) = @_;
924 return substr $chars, $me->random(length $chars), 1;
933 if ($n) { $s .= $me->_pick($me->{ichars}); $n--; }
934 while ($n > 1) { $s .= $me->_pick($me->{mchars}); $n--; }
935 if ($n) { $s .= $me->_pick($me->{echars}); $n--; }
936 if ($n) { die "INTERNAL can't count"; }
940 package Odin::Gen::Words;
941 @ISA = qw(Odin::Gen);
944 @PARAM = qw(wordlist delim nwords);
946 $GENMAP{words} = "Odin::Gen::Words";
948 wordlist => "etc/words",
949 delim => Odin::Param::Str->new(".", qr/^[-_.+]*$/, 1, 1),
950 nwords => Odin::Param::Int->new(3, 2, 16)
957 if (!exists $me->{words}) {
958 open my $f, $me->{wordlist} or die "open wordlist: $!";
959 $me->{words} = [grep chomp, <$f>];
960 close $f or die "close/read wordlist: $!";
963 for (my $i = 0; $i < $me->{nwords}; $i++)
964 { push @w, $me->{words}[$me->random(scalar @{$me->{words}})]; }
965 return join $me->{delim}, @w;
968 ###--------------------------------------------------------------------------
969 ### Final configuration.
975 ($SCHEME, $DOMAIN, $BASEPATH) = $BASEURL =~ m!^([^:]+)://([^/]+)(/.*)$!;
976 merge_hash %COOKIE_DEFAULTS, -domain => $DOMAIN, -path => $BASEPATH;
977 merge_hash %COOKIE_DEFAULTS, -secure => undef if $SCHEME eq "https";
979 $MAIL_QUALDOM //= $MAIL_DEFDOMAIN;
981 $SHORTURL = "$BASEURL$SHORTURL_PATH";
982 $PASTEBIN = "$BASEURL$PASTEBIN_PATH";
984 ###----- That's all, folks --------------------------------------------------