lib/Keitairc/Config.pm

   1 # -*- mode: perl; coding: utf-8 -*-
   2 # Keitairc::Config
   3 #
   4 # Copyright (c) 2008 Jun Morimoto <morimoto@mrmt.net>
   5 # Copyright (c) 2010 ISHIKAWA Mutsumi <ishikawa@hanzubon.jp>
   6 # This program is covered by the GNU General Public License 2
   7
   8 package Keitairc::Config;
   9 use AppConfig qw(:argcount);
  10 use Cwd;
  11 use Encode;
  12 use Encode::MIME::Name;
  13 use strict;
  14 use warnings;
  15 our @ISA = qw(AppConfig);
  16
  17 ################################################################
  18 sub new{
  19         my $class = shift;
  20         my $arg = shift;
  21         my @argv = @{$arg->{argv}};
  22         my $me = $class->SUPER::new(
  23                 {CASE => 1,
  24                  ERROR => \&on_error,
  25                  GLOBAL => {
  26                          ARGCOUNT => ARGCOUNT_ONE,
  27                  }});
  28
  29         $me->define(
  30                 # required
  31                 'irc_nick' => {ATTR => 'RO|REQ'},
  32                 'irc_username' => {ATTR => 'RO|REQ'},
  33                 'irc_server'  => {ATTR => 'RO|REQ'},
  34                 'web_password'  => {ATTR => 'RO|REQ'},
  35                 'web_host' => {ATTR => 'RO|REQ'},
  36
  37                 # optional
  38                 'irc_password',
  39                 'irc_desc' => {DEFAULT => 'keitairc'},
  40                 'au_subscriber_id' => {DEFAULT => ''},
  41                 'docomo_foma_icc' => {DEFAULT => ''},
  42                 'docomo_imodeid' => {DEFAULT => ''},
  43                 'softbank_serial_key' => {DEFAULT => ''},
  44                 'emobile_userid' => {DEFAULT => ''},
  45                 'irc_keyword',
  46                 'web_listen_port' => {ATTR => 'RO'},
  47                 'web_title' => {DEFAULT => 'keitairc'},
  48                 'common_header' => {DEFAULT => '
  49 <meta name="Robots" content="noindex,nofollow" />
  50 <meta name="Keywords" content="norobot" />
  51 <meta http-equiv="pragma" content="no-cache" />
  52 <meta http-equiv="cache-control" content="no-cache" />
  53 <meta http-equiv="expires" content="-1" />'},
  54                 'extra_header' => {DEFAULT => ''},
  55                 'silent_config' => {DEFAULT => $arg->{silent}, ATTR => 'RO'},
  56                 'version' => {DEFAULT => $arg->{version}},
  57                 'template_dir'  => {DEFAULT => getcwd() . '/data/templates:__KEITAIRC_DATA_DIR__/templates', ATTR => 'RO'},
  58                 'plugin_dir' => {DEFAULT => getcwd() . '/data/plugins:__KEITAIRC_DATA_DIR__/plugins', ATTR => 'RO'},
  59                 'public_dir' => {DEFAULT => getcwd() . '/data/public:__KEITAIRC_DATA_DIR__/public', ATTR => 'RO'},
  60                 'url_redirect' => {DEFAULT => ''},
  61                 'smtp_server' => {DEFAULT => ''},
  62                 'smtp_from' => {DEFAULT => ''},
  63                 'smtp_to' => {DEFAULT => ''},
  64                 'rgeocode_server' => {DEFAULT => 'finds'},
  65                 'pid_file' => {DEFAULT => 'keitairc.pid', ATTR => 'RO'},
  66
  67                 'web_root' => {TYPE => 'web_root', DEFAULT => '/', ATTR => 'RO'},
  68                 'web_schema' => {TYPE => 'web_schema', DEFAULT => 'http', ATTR => 'RO'},
  69                 'fontsize' => {TYPE => 'fontsize', DEFAULT => '+0'},
  70                 'mobile_fontsize' => {TYPE => 'fontsize', DEFAULT => -1},
  71                 'irc_charset' => {TYPE => 'charset', DEFAULT => 'utf8'},
  72                 'web_charset' => {TYPE => 'charset', DEFAULT => 'shiftjis'},
  73                 'pid_dir' => {TYPE => 'dir', DEFAULT => $ENV{HOME} . '/.keitairc.d', ATTR => 'RO'},
  74                 'url_target' => {TYPE => 'url_target', DEFAULT => '_self'},
  75                 'log' => {TYPE => 'log', DEFAULT => 'file', ATTR => 'RO'},
  76
  77                 # optional integer params
  78                 'irc_port' => {TYPE => 'int', DEFAULT => 6667, ATTR => 'RO'},
  79                 'cookie_ttl' => {TYPE => 'int', DEFAULT => 86400 * 3},  # 3 days
  80                 'session_ttl' => {TYPE => 'int', DEFAULT => 60 * 30},  # 30 min
  81                 'cache_expire' => {TYPE => 'int', DEFAULT => 3600 * 12}, # 12 hour
  82                 'web_port' => {TYPE => 'int', DEFAULT => 8080, ATTR => 'RO'},
  83                 'web_lines' => {TYPE => 'int', DEFAULT => 100},
  84                 'ping_delay' => {TYPE => 'int', DEFAULT => 30},
  85                 'reconnect_delay' => {TYPE => 'int', DEFAULT => 10},
  86
  87                 # optional boolean params
  88                 'show_joinleave' => {TYPE => 'bool', DEFAULT => 1},
  89                 'show_console' => {TYPE => 'bool', DEFAULT => 0},
  90                 'follow_nick' => {TYPE => 'bool', DEFAULT => 1},
  91                 'debug' => {TYPE => 'bool', DEFAULT => 0},
  92                 'daemonize' => {TYPE => 'bool', DEFAULT => 0, ATTR => 'RO'},
  93                 'reverse_message' => {TYPE => 'bool', DEFAULT => 1},
  94                 'reverse_recent' => {TYPE => 'bool', DEFAULT => 1},
  95                 'reverse_unread' => {TYPE => 'bool', DEFAULT => 1},
  96                 'webkit_newui' => {TYPE => 'bool', DEFAULT => 1},
  97
  98                 # obsolates (ignored)
  99                 'show_newmsgonly' => {TYPE => 'obsolates'},
 100                 'web_username' => {TYPE => 'obsolates'},
 101                 'use_cookie' => {TYPE => 'obsolates'},
 102                 'au_pcsv' => {TYPE => 'obsolates'},
 103                 );
 104
 105         if(-r '/etc/keitairc'){
 106                 $me->file('/etc/keitairc');
 107         }
 108         if(-r $ENV{HOME} . '/.keitairc'){
 109                 $me->file($ENV{HOME} . '/.keitairc');
 110         }
 111         if(-r $ENV{HOME} . '/.keitairc.d/config.dump'){
 112                 $me->file($ENV{HOME} . '/.keitairc.d/config.dump');
 113         }
 114
 115         if(defined $argv[0]){
 116                 if(-r $argv[0]){
 117                         $me->file($argv[0]);
 118                         shift(@argv);
 119                 }
 120         }
 121
 122         $me->args(\@argv);
 123
 124         # check required parameters
 125         foreach my $n (keys %{$me->{'REQ'}}) {
 126                 if(!defined($me->get($n)) || !length($me->get($n))) {
 127                         die($n . ' does not specified');
 128                 }
 129         }
 130
 131         if(!defined($me->web_listen_port()) || !length($me->web_listen_port())){
 132                 $me->web_listen_port($me->web_port());
 133         }
 134
 135         $me;
 136 }
 137
 138 ################################################################
 139 sub file {
 140         my $me = shift;
 141         my $file = shift;
 142         if(-r $file){
 143                 $me->SUPER::file($file);
 144                 print STDERR "Loaded configuration file: $file\n" unless $me->silent_config();
 145                 return;
 146         }
 147         warn("$file does not exist");
 148 }
 149
 150 ################################################################
 151 sub define {
 152         my $me = shift;
 153         my @args = ();
 154
 155         while (@_) {
 156                 my $var = shift;
 157                 my $cfg = ref($_[0]) eq 'HASH' ? shift : { };
 158                 if (defined $cfg->{TYPE}) {
 159                         if (!defined $cfg->{VALIDATE} && defined &{'valid_' . $cfg->{TYPE}}) {
 160                                 $cfg->{VALIDATE} = \&{'valid_' . $cfg->{TYPE}};
 161                         }
 162                         if (!defined $cfg->{ARGCOUNT} && $cfg->{TYPE} eq 'bool') {
 163                                 $cfg->{ARGCOUNT} = ARGCOUNT_NONE;
 164                         }
 165                         $me->type($var, $cfg->{TYPE});
 166                         delete $cfg->{TYPE};
 167                 }
 168                 if (defined $cfg->{ATTR}) {
 169                         my @attr = split(/\|/, $cfg->{ATTR});
 170                         foreach my $at (@attr) {
 171                                 if ($at eq 'RO') {
 172                                         $me->readonly($var, 1);
 173                                 } elsif ($at eq 'REQ') {
 174                                         $me->required($var, 1);
 175                                 } else {
 176                                         warn 'Ignore unknown attribute: ' . $at;
 177                                 }
 178                         }
 179                         delete $cfg->{ATTR};
 180                 }
 181                 push(@args, $var => $cfg);
 182         }
 183
 184         return $me->SUPER::define(@args);
 185 }
 186
 187 sub type {
 188         my ($me, $name, $type) = @_;
 189         $me->{TYPE} = {} if (!defined $me->{TYPE});
 190         $me->{TYPE}->{$name} = $type if (defined $type);
 191         return (defined $me->{TYPE}->{$name} ? $me->{TYPE}->{$name} : 'string');
 192 }
 193
 194 sub bool_attr {
 195         my ($me, $type_name, $name, $flag) = @_;
 196         $me->{$type_name} = {} if (!defined $me->{$type_name});
 197         if (defined $flag) {
 198                 if ($flag) {
 199                         $me->{$type_name}->{$name} = 1;
 200                 } else {
 201                         delete $me->{$type_name}->{$name};
 202                 }
 203         }
 204         return defined $me->{$type_name}->{$name};
 205 }
 206
 207 sub readonly {
 208         my $me = shift;
 209         return $me->bool_attr('RO', @_);
 210 }
 211
 212 sub required {
 213         my $me = shift;
 214         return $me->bool_attr('REQ', @_);
 215 }
 216
 217 ################################################################
 218 sub content_charset{
 219         my $me = shift;
 220         Encode::MIME::Name::get_mime_name(Encode::resolve_alias($me->web_charset()));
 221 }
 222
 223 ################################################################
 224 sub dump {
 225         my $me = shift;
 226         my %list = $me->varlist('.*');
 227         my $ret = '';
 228         foreach my $k (sort keys %list) {
 229                 if (defined $list{$k} && length($list{$k})) {
 230                         my $value = $list{$k};
 231                         $value =~ s/\x0D\x0A|\x0D|\x0A//g;
 232                         $ret .= $k .' = '. $value . "\n"
 233                 }
 234         }
 235         return $ret;
 236 }
 237
 238 sub dump2file {
 239         my $me = shift;
 240         if (! open(FH, '> ' . $ENV{HOME} . '/.keitairc.d/config.dump') ) {
 241                 $::log->log_error('can not open config dump file: ' . $ENV{HOME} . '/.keitairc.d/config.dump');
 242                 return 0;
 243         }
 244
 245         print FH $me->dump;
 246
 247         close(FH);
 248         return 1;
 249 }
 250
 251 ################################################################
 252 # config params check utility functions
 253 ################################################################
 254 sub on_error {
 255         my $msg = shift;
 256         die $msg;
 257 }
 258
 259 sub valid_int {
 260         my ($name, $value) = @_;
 261         return 1 if ($value =~ /^\d+$/);
 262
 263         if (my $val = eval $value) {
 264                 return 1 if ($val =~ /^\d+$/);
 265         }
 266
 267         return 0;
 268 }
 269
 270 sub valid_web_root {
 271         my ($name, $value) = @_;
 272         return ($value =~ /^\//);
 273 }
 274
 275 sub valid_web_schema {
 276         my ($name, $value) = @_;
 277         return ($value =~ /^https?$/);
 278 }
 279
 280 sub valid_fontsize {
 281         my ($name, $value) = @_;
 282         return ($value =~ /^[+-]?[0-7]$/);
 283 }
 284
 285 sub valid_charset {
 286         my ($name, $value) = @_;
 287         return Encode::resolve_alias($value);
 288 }
 289
 290 sub valid_dir {
 291         my ($name, $value) = @_;
 292         if (-w $value) {
 293                 return 1;
 294         } else {
 295                 print STDERR "pid_dir $value is not writable\n";
 296                 return 0;
 297         }
 298 }
 299
 300 sub valid_url_target {
 301         my ($name, $value) = @_;
 302         return ($value =~ /^_(?:blank|self|top|parent)$/);
 303 }
 304
 305 sub valid_log {
 306         my ($name, $value) = @_;
 307         return ($value =~ /^(?:(?:file|syslog|stdio)$|(?:file|syslog):)/);
 308 }
 309
 310 sub valid_obsolates {
 311         my ($name, $value) = @_;
 312         warn($name . ' has obsoleted from keitairc 2.0, ignored');
 313         return 1;
 314 }
 315
 316 1;