#!/usr/bin/env perl use strict; use IO::File; use Data::Dumper; my $CFILE = $ENV{'HOME'} . '/.bip/bip.conf.autogen'; my $sfile = $ENV{'HOME'} . '/.bip/bipgenconfig.store'; my $SERIALIZE_DBG = 1; my %cf; my $DEBUG = 0; my $global_done = 0; my $cert_done = 0; my $mode = 'normal'; # maximum level of blocks { { { } } } my $maxlevel = 5; my $bipmkpw; my $tmpcrt = "/tmp/bip-cert.cnf"; my $certout = $ENV{'HOME'} . '/.bip/bip.pem.autogen'; my %optdesc = ( 'global' => { 'ip' => { 'type' => 's', 'adv' => 1, 'default' => '0.0.0.0', 'optional' => 1, 'desc' => 'What IP address/hostname do you want bip to listen on ?' }, 'port' => { 'type' => 'i', 'adv' => 1, 'default' => '7778', 'optional' => 1, 'desc' => 'What port do you want bip to listen on ?' }, 'client_side_ssl' => { 'type' => 'b', 'adv' => 1, 'default' => 'true', 'optional' => 1, 'desc' => 'Do you want to enable client side SSL ?' }, 'pid_file' => { 'type' => 's', 'adv' => 1, 'optional' => 1, 'default' => $ENV{'HOME'} . '/.bip/bip.pid', 'desc' => 'Where do you want the pidfile to be stored ?' }, 'log' => { 'type' => 'b', 'adv' => 0, 'default' => 'true', 'optional' => 1, 'desc' => 'Do you want to enable the logging system ?' }, 'log_sync_interval' => { 'type' => 'i', 'adv' => 1, 'optional' => 1, 'default' => '5', 'depends' => 'log', 'depval' => 'true', 'desc' => 'At which interval do you want bip to force logs to be written {seconds} ?' }, 'log_level' => { 'type' => 'i', 'adv' => 1, 'default' => '3', 'optional' => 1, 'depends' => 'log', 'depval' => 'true', 'desc' => 'Define bip\'s system logs verbosity level {less 0 - 7 tremendous}:' }, 'log_root' => { 'type' => 's', 'adv' => 0, 'optional' => 1, 'default' => $ENV{'HOME'} . '/.bip/logs', 'depends' => 'log', 'depval' => 'true', 'desc' => 'In which directory do you want logs to be stored ?' }, 'log_format' => { 'type' => 's', 'adv' => 1, 'default' => '%n/%Y-%m/%c.%d.log', 'optional' => 1, 'depends' => 'log', 'depval' => 'true', 'desc' => 'Define the channel/private log format {see strftime, limited}:' }, 'backlog' => { 'type' => 'b', 'adv' => 0, 'default' => 'true', 'optional' => 1, 'depends' => 'log', 'depval' => 'true', 'desc' => 'Do you want to activate backlog {play back logs} system ?' }, 'backlog_lines' => { 'type' => 'i', 'adv' => 0, 'default' => '10', 'optional' => 1, 'depends' => 'backlog', 'depval' => 'true', 'desc' => 'How much line do you want bip to play back upon client connect' . " {0 => replay everything since backlog's last reset} ?" }, 'backlog_no_timestamp' => { 'type' => 'b', 'adv' => 0, 'optional' => 1, 'default' => 'false', 'depends' => 'backlog', 'depval' => 'true', 'desc' => 'Disable timestamp in backlog ?' }, 'bl_msg_only' => { 'type' => 'b', 'adv' => 0, 'optional' => 1, 'default' => 'false', 'depends' => 'backlog', 'depval' => 'true', 'desc' => 'Only playback users messages {chan/priv}, no nick/join/... ?' }, 'always_backlog' => { 'type' => 'b', 'adv' => 0, 'optional' => 1, 'default' => 'false', 'depends' => 'backlog', 'depval' => 'true', 'desc' => 'Always backlog {false means backlog pointers are reset after each backlog} ?' }, 'blreset_on_talk' => { 'type' => 'b', 'adv' => 0, 'optional' => 1, 'default' => 'false', 'depends' => 'backlog', 'depval' => 'true', 'desc' => 'Reset backlog each time an attached client "talks" ?' }, }, 'network' => { 'name' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'Network\'s name' }, 'ssl' => { 'type' => 'b', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'Enable SSL for this network ?' }, 'server' => { 'type' => 'e' }, }, 'user' => { 'name' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'User\'s internal name ?' }, 'password' => { 'type' => 'p', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'Set a password for his bip account:' }, 'ssl_check_mode' => { 'type' => 's', 'adv' => 1, 'optional' => 1, 'default' => 'none', 'desc' => 'Type of SSL servers certificate\'s checks' }, 'ssl_check_store' => { 'type' => 's', 'adv' => 1, 'optional' => 1, 'default' => '', 'desc' => 'Path to SSL servers\'s data storage' }, 'default_nick' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'User\'s default IRC nickname' }, 'default_user' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'User\'s default IRC username' }, 'default_realname' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'User\'s default IRC realname' }, 'connection' => { 'type' => 'e' }, }, 'connection' => { 'name' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'Connection name (used by bip only)' }, 'network' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'postdepends' => 'networks.$value', 'desc' => 'Network to connect to' }, 'defid' => { 'type' => 'b', 'adv' => 0, 'default' => 'true', 'optional' => 1, 'nosave' => 1, 'desc' => 'Use default identity ?' }, 'nick' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'depends' => 'defid', 'depval' => 'false', 'desc' => 'IRC nickname on this connection ?' }, 'user' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'depends' => 'defid', 'depval' => 'false', 'desc' => 'IRC username on this connection ?' }, 'realname' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'depends' => 'defid', 'depval' => 'false', 'desc' => 'IRC realname on this connection ?' }, 'password' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'IRC server\'s password ?' }, 'vhost' => { 'type' => 's', 'adv' => 1, 'default' => '', 'optional' => 1, 'desc' => 'Connect to IRC server from this specific IP address:' }, 'source_port' => { 'type' => 'i', 'adv' => 1, 'default' => '', 'optional' => 1, 'desc' => 'Connect to IRC server from this specific port:' }, 'follow_nick' => { 'type' => 'b', 'adv' => 0, 'default' => 'true', 'optional' => 1, 'desc' => 'Follow nicknames changes from clients to use upon reconnection (if false, bip\'ll use config nickname)' }, 'ignore_first_nick' => { 'type' => 'b', 'adv' => 0, 'default' => 'true', 'optional' => 1, 'desc' => 'Ignore nickname change sent by a client (first one only, upon client attach)' }, 'away_nick' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'Set nickname to this value when there\'s no more client attached:' }, 'no_client_away_msg' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'Set this away message when there\'s no more client attached:' }, 'on_connect_send' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'Send this raw message upon connection to IRC server' }, 'channel' => { 'type' => 'e' }, }, 'channel' => { 'name' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'Channel name' }, 'key' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 1, 'desc' => 'Channel key (optional)' }, }, 'server' => { 'host' => { 'type' => 's', 'adv' => 0, 'default' => '', 'optional' => 0, 'desc' => 'IRC server\'s IP address/hostname' }, 'port' => { 'type' => 'i', 'adv' => 0, 'default' => '6667', 'optional' => 0, 'desc' => 'IRC server\'s port' }, } ); my %optorder = ( 'global' => [ 'ip' , 'port' , 'client_side_ssl' , 'pid_file' , undef, 'log' , 'log_sync_interval' , 'log_level' , 'log_root' , 'log_format' , undef, 'backlog' , 'backlog_lines' , 'backlog_no_timestamp' , 'bl_msg_only' , 'always_backlog' , 'blreset_on_talk' , ], 'network' => [ 'name' , 'ssl' , 'server' , ], 'user' => [ 'name' , 'password' , 'ssl_check_mode' , 'ssl_check_store' , undef, 'default_nick' , 'default_user' , 'default_realname' , 'connection' , ], 'connection' => [ 'name' , 'network' , 'defid', 'nick' , 'user' , 'realname' , 'password' , undef, 'vhost' , 'source_port' , 'follow_nick' , 'ignore_first_nick' , 'away_nick' , 'no_client_away_msg' , 'on_connect_send' , 'channel' , ], 'channel' => [ 'name' , 'key' , ], 'server' => [ 'host' , 'port' , ] ); my $clear_string = `clear`; sub myexit { warn("Error: $1"); warn("Saving configuration..."); save_config(); warn("Don't worry, your configuration has been saved ;)"); exit(1); } sub askOpt { my ($e, $curval, $mayempty) = @_; my ($o, $sel); $sel = (($curval ne undef) ? $curval : $e->{'default'}); return $sel if ($mode eq 'normal' && $e->{'adv'} eq 1); while (1) { my $opt = (defined $e->{'optional'} && $e->{'optional'} eq 1 ? 1 : 0); if ($e->{'type'} eq 'b') { $o = askbool($e->{'desc'}, $sel, 1); } elsif ($e->{'type'} eq 'p') { $o = askPass($e->{'desc'}); } else { $o = askval($e->{'desc'}, $sel, ($mayempty && ($opt ne 1 || $e->{'type'} eq 'i' ? 1 : undef)), 1); } if ($o eq undef && $opt eq 0) { print("This value is mandatory, please enter a value\n"); next; } if ($e->{'type'} eq 'i' && $o !~ /^\d*$/) { print("We want a number here, please enter one\n"); next; } last; } return $o; } sub align { my ($text, $num) = @_; my ($out, $pos, $orig); $orig = $text; while ($text ne '' || $text ne undef) { $num = 60 if (!$num); $pos = rindex($text, " ", 60); $out .= "\n" if ($out); $out .= substr($text, 0, $pos); $text = substr($text, $pos+1); } $out .= " "; return $out; } sub askbool { my ($text, $default, $star) = @_; $text = "* $text" if $star; if ($default eq "true") { print align("$text [Y/n] "); } else { $default = "false"; print align("$text [y/N] "); } while (my $l = ) { chomp($l); if ($default eq "true" && $l =~ /^n$/i) { return "false"; } elsif ($default eq "false" && $l =~ /^y$/i) { return "true"; } elsif (!$default && $l eq '') { return undef; } else { return $default; } } } sub askPass { my ($text) = @_; while (!$bipmkpw || ! -x "$bipmkpw") { if ($bipmkpw ne '' && (! -f $bipmkpw || ! -x $bipmkpw)) { print("No exec permission: $bipmkpw\n"); } $bipmkpw = askval("Please enter the path to bipmkpw:", undef, 1); } print("$text ? "); my $pass = `$bipmkpw`; chomp($pass); $pass =~ s/^Password:\s*\n?//si; chomp($pass); return $pass; } sub askval { my ($text, $default, $skipblank, $star) = @_; $text .= " "; $text .= "[$default] " if ($default ne undef); $text = "* $text" if $star; print(align("$text")); while (my $l = ) { chomp($l); # if ($default eq undef && !$skipblank && $l eq '') { # my $q = askbool("You've entered a blank value, do you want this field to be unset (if not, it'll be set to the empty string) ?", "true"); # return undef if ($q eq 'true'); # } return ($l ne '' ? $l : $default); } } sub checkDepends { my ($n, $v) = @_; return if (!exists($v->{'depends'})); my $d = $v->{'depends'}; if (!exists($cf{'global'}->{$d})) { return "You cannot define `$n' since `$d' isn't defined"; } if (exists($v->{'depval'}) && $cf{'global'}->{$d} ne $v->{'depval'}) { return "You cannot define `$n' since `$d' isn't set to " . $v->{'depval'}; } } sub loadConfig { my ($f) = @_; my ($fh, $data, $hr); $fh = new IO::File; $data = ''; $fh->open($f) || return "Unable to open $f"; while (<$fh>) { chomp(); $data .= $_; } $fh->close; $hr = unserialize($data) || return "Invalid format in $f"; %cf = %{$hr}; return "Config loaded from $f"; } sub resetConfig { my $r = askbool("Do you want to reset current loaded configuration options, networks, users... ?", 'false'); $r eq 'false' && return "Reset config aborted"; %cf = (); -e "$sfile" || return "Configuration cleared"; my $r = askbool("Do you want to delete saved configuration file $sfile too ?", 'false'); if ($r eq 'true') { unlink($sfile) || return "Unable to remove file $sfile, current config has been cleared"; return "Configuration cleared, saved-configuration file removed"; } return "Configuration cleared"; } sub setOptions { foreach my $n (@{$optorder{'global'}}) { if ($n eq undef) { print("\n"); next; } my $e = $optdesc{'global'}->{$n}; my $r = checkDepends($n, $e); if ($r) { print("$r\n") if ($DEBUG); $cf{'global'}->{$n} = undef; next; } $cf{'global'}->{$n} = askOpt($e, $cf{'global'}->{$n}); } $global_done = 1; pause(); return "Options have been set"; } sub printOptions { my $cnt = 1; foreach my $n (@{$optorder{'global'}}) { next if (!$n); my $e = $optdesc{'global'}->{$n}; next if ($e->{'type'} eq 'e' || $e->{'nosave'} eq 1); next if ($mode eq 'normal' && $e->{'adv'} eq 1); my $r = checkDepends($n, $e); if ($r) { printf('%02d.(%s - unset, missing dependency)'."\n", $cnt, $n); } elsif (exists($cf{'global'}->{$n})) { printf('%02d. %s = %s'."\n", $cnt, $n, $cf{'global'}->{$n}); } else { printf('%02d. %s - unset'."\n", $cnt, $n); } $cnt++; } pause(); return; } sub makeCert { my ($fh, $c, $o, $ou, $cn); $fh = new IO::File; $c = askval("SSL cert country :", undef, 1); $o = askval("SSL cert organisation :", "Sexy boys"); $ou = askval("SSL cert organisational unit :", "Bip"); $cn = askval("SSL cert common name :", "Bip"); $fh->open("> $tmpcrt"); return "Unable to write to $tmpcrt\n" if (!$fh); print $fh "HOME = . [ req ] distinguished_name = dn x509_extensions = v3_bip default_md = sha1 prompt = no [ dn ] C=$c O=$o OU=$ou CN=$cn [ v3_bip ] subjectKeyIdentifier=hash authorityKeyIdentifier=keyid:always"; # if (-e $certout) { # my @t = localtime(time); # my $ts = sprintf("%04d-%02d-%02d.%02d:%02d:%02d", 1900+$t[5], 1+$t[4], $t[3], $t[2], $t[1], $t[0]); # rename($certout, "$certout.$ts"); # print "Existing $certout found, renamed to $certout.$ts\n"; # } `openssl req -new -x509 -days 365 -nodes -config "$tmpcrt" -out "$certout" -keyout "$certout"`; # TODO check command status `openssl x509 -subject -dates -fingerprint -noout -in "$certout"`; # TODO check command status $cert_done = 1; print "Certificate/key pair has been generated in $certout\n"; unlink("$tmpcrt"); pause(); return "Certificate/key pair has been generated in $certout"; } sub writeConfig { my ($f) = @_; my ($fh, $ts, @t); $ts = localtime(time); $fh = new IO::File; if (!$fh->open('> ' . $f)) { print("Unable to open $f for writing\n"); return; } print $fh "# vim:ft=bip:ts=2\n"; print $fh "# Auto-generated BIP IRC Proxy configuration $ts \n"; print $fh "#\n"; print $fh "### Global options\n"; foreach my $k (keys(%{$cf{'global'}})) { next if ($cf{'global'}->{$k} eq undef); next if ($optdesc{'global'}->{$k}->{'nosave'} eq 1); my $t = $optdesc{'global'}->{$k}->{'type'}; if ($t eq 's' || $t eq 'b') { print $fh "$k = \"" . $cf{'global'}->{$k} . "\";\n"; } else { print $fh "$k = " . $cf{'global'}->{$k} . ";\n"; } } print $fh "\n"; print $fh "### Networks\n"; foreach my $e (@{$cf{'networks'}}) { my $out = printBlock("", 'network', $e, 1); print $fh $out; } print $fh "\n"; print $fh "### Users\n"; foreach my $e (@{$cf{'users'}}) { my $out = printBlock("", 'user', $e, 1); print $fh $out; } print $fh "\n"; $fh->close; print("Configuration saved in $f\n"); my $u = (exists($cf{'users'}) ? scalar @{$cf{'users'}} : 0); my $n = (exists($cf{'networks'}) ? scalar @{$cf{'networks'}} : 0); print "You haven't set global options\n" if (!$global_done); print "$u users defined, $n networks defined\n"; print "The certificate/key pair is in $certout\n" if ($cert_done eq 1); print "Configuration has been generated in $CFILE\n"; print "You have to rename all generated files to use them\n"; return; } sub storeConfig { my ($f) = @_; my ($fh); $fh = new IO::File; $fh->open('> ' . $f) || return "Unable to open $f for writing"; print $fh serialize(\%cf); $fh->close; return "Configuration stored in $f"; } sub printBlock { my ($prefix, $name, $e, $level) = @_; my $out = ''; fatal("Too much recursion levels ($level)") if ($level ge $maxlevel); $out .= $prefix . $name . " {\n"; foreach my $k (keys(%{$e})) { next if ($e->{$k} eq undef); next if ($optdesc{$name}->{$k}->{'nosave'} eq 1); my $t = $optdesc{$name}->{$k}->{'type'}; if ($t eq 's' || $t eq 'b') { $out .= $prefix . "\t$k = \"" . $e->{$k} . "\";\n"; } elsif (ref($e->{$k}) eq 'ARRAY') { foreach my $e2 (@{$e->{$k}}) { $out .= printBlock($prefix . "\t", $k, $e2, $level+1); } } else { $out .= $prefix . "\t$k = " . $e->{$k} . ";\n"; } } $out .= $prefix . "}\n\n"; return $out; } sub addEntry { my ($section, $nopause) = @_; my ($e, $opts); $opts = $optdesc{$section}; foreach my $n (@{$optorder{$section}}) { if ($n eq undef) { print("\n"); next; } my $v = $optdesc{$section}->{$n}; my $r = checkDepends($n, $v); if ($r) { $e->{$n} = undef; print("$r\n") if ($DEBUG); next; } if ($v->{'type'} eq 'e') { my $first = 1; do { if ($v->{'optional'} eq 1 || !$first) { my $a = askbool("Do you want to add a new $n ?", 'true'); last if ($a eq 'false'); } print("\nAdding a new $n :\n"); my $e2 = addEntry($n, 1); if (ref($e->{$n}) eq 'ARRAY') { push(@{$e->{$n}}, $e2); } else { $e->{$n} = [ $e2 ]; } $first = 0; } while (1); } else { $e->{$n} = askOpt($v); } } pause() if (!$nopause); return $e; } sub pause { my ($txt) = @_; $txt = "Press any key to continue" if (!$txt); print("\n" . $txt . "\n"); ; } sub printMenu { my ($mhead, $mopts, $mfoot, $mask) = @_; push(@{$mhead}, undef); if ($mode eq 'normal') { push(@{$mhead}, "WARNING: non-advanced mode, some 'expert' " . "options'll be hidden !"); } else { push(@{$mhead}, undef); } push(@{$mhead}, undef); print($clear_string); print("###########################################################" . "###################\n# "); print(join("\n# ", @{$mhead})); print("\n"); print("\n"); foreach my $n (sort {$a <=> $b} keys(%{$mopts})) { if ($mopts->{$n} eq undef) { print("\n"); next; } printf(' %2d. %s%s', $n, $mopts->{$n}, "\n"); } print("\n"); print(join("\n", @{$mfoot})); print("\n"); print("\n"); return askval($mask, undef, 1); } sub printUsers { my ($txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $num, $warn, $act, $out); $mhead = [ "Bip's user list", ]; $mfoot = [ $txt ]; $mask = "Enter id of the user to edit ?"; $mopts = { 0 => 'Return to main menu'}; $mopts->{"0.5"} = undef; $num = 1; foreach my $n (@{$cf{'users'}}) { $mopts->{$num} = $n->{'name'} . ': ' . (scalar @{$n->{'connection'}}) . ' connections.'; $num++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act =~ /^\d+$/) { my $n = $cf{'users'}; my $c = $num-1; if (($num-$act) le 0) { $out = "There are only $c users"; } else { $out = printEditUser($act-1); } } else { $out = "Invalid user ID"; } printUsers($out); } sub printNetworks { my ($txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $num, $warn, $act, $out); $mhead = [ "Bip's network list", ]; $mfoot = [ $txt ]; $mask = "Enter ID of the network to edit ?"; $mopts = { 0 => 'Return to main menu'}; $mopts->{"0.5"} = undef; $num = 1; foreach my $n (@{$cf{'networks'}}) { $mopts->{$num} = $n->{'name'} . ': ' . (scalar @{$n->{'server'}}) . ' servers, SSL ' . ($n->{'ssl'} eq 'true' ? 'enabled' : 'disabled'); $num++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act =~ /^\d+$/) { my $n = $cf{'networks'}; my $c = $num-1; if (($num-$act) le 0) { $out = "There are only $c networks"; } else { $out = printEditNetwork($act-1); } } else { $out = "Invalid network ID"; } printNetworks($out); } sub addChannel { my ($uid, $cid) = @_; my ($cnt, @o, $n, $c, $name); return "Invalid user ID $uid" if ((scalar @{$cf{'users'}}) le $uid); $n = $cf{'users'}[$uid]; return "Invalid connection ID $cid" if ((scalar @{$n->{'connection'}}) le $cid); my $e = addEntry('channel'); if ($e) { push(@{$n->{'connection'}[$cid]->{'channel'}}, $e); return "Channel " . $e->{'name'} . " added"; } else { return "Channel add failed"; } } sub addServer { my ($id) = @_; return "Invalid network ID $id" if ((scalar @{$cf{'networks'}}) le $id); my $e = addEntry('server'); if ($e) { push(@{$cf{'networks'}[$id]->{'server'}}, $e); return "Server " . $e->{'host'} . " added"; } else { return "Server add failed"; } } sub addConnection { my ($id) = @_; return "Invalid user ID $id" if ((scalar @{$cf{'users'}}) le $id); my $e = addEntry('connection'); if ($e) { push(@{$cf{'users'}[$id]->{'connection'}}, $e); return "Connection " . $e->{'name'} . " added"; } else { return "Connection add failed"; } } sub deleteServer { my ($net, $sid) = @_; my ($sname, $ss, $cnt, @o); return "Invalid network ID $net" if ((scalar @{$cf{'networks'}}) le $net); $ss = $cf{'networks'}[$net]->{'server'}; return "Invalid server ID $sid" if ((scalar @{$ss}) lt $sid); @o = (); $cnt = 0; foreach my $s (@{$ss}) { if ($sid ne $cnt) { push(@o, $s); } else { $sname = $s->{'host'}; } $cnt++; } $cf{'networks'}[$net]->{'server'} = [ @o ]; return "Server $sname removed"; } sub delUser { my ($id) = @_; my ($cnt, @o, $name); return "Invalid user ID $id" if ((scalar @{$cf{'users'}}) le $id); $cnt = 0; @o = (); foreach my $n (@{$cf{'users'}}) { if ($id ne $cnt) { push(@o, $n); } else { $name = $n->{'name'}; } $cnt++; } $cf{'users'} = [ @o ]; return "User $name removed"; } sub delNetwork { my ($id) = @_; my ($cnt, @o, $name); return "Invalid network ID $id" if ((scalar @{$cf{'networks'}}) le $id); $cnt = 0; @o = (); foreach my $n (@{$cf{'networks'}}) { if ($id ne $cnt) { push(@o, $n); } else { $name = $n->{'name'}; } $cnt++; } $cf{'networks'} = [ @o ]; return "Network $name removed"; } sub deleteConn { my ($uid, $cid) = @_; my ($cnt, @o, $n, $name); return "Invalid user ID $uid" if ((scalar @{$cf{'users'}}) le $uid); $n = $cf{'users'}[$uid]; return "Invalid connection ID $cid" if ((scalar @{$n->{'connection'}}) le $cid); $cnt = 0; @o = (); foreach my $n (@{$n->{'connection'}}) { if ($cid ne $cnt) { push(@o, $n); } else { $name = $n->{'name'}; } $cnt++; } $cf{'users'}[$uid]->{'connection'} = [ @o ]; return "Connection $name removed"; } sub deleteChannel { my ($uid, $cid, $chid) = @_; my ($cnt, @o, $n, $c, $name); return "Invalid user ID $uid" if ((scalar @{$cf{'users'}}) le $uid); $n = $cf{'users'}[$uid]; return "Invalid connection ID $cid" if ((scalar @{$n->{'connection'}}) le $cid); $c = $n->{'connection'}[$cid]; return "Invalid channel ID $chid" if ((scalar @{$c->{'channel'}}) le $chid); $cnt = 0; @o = (); foreach my $n (@{$c->{'channel'}}) { if ($chid ne $cnt) { push(@o, $n); } else { $name = $n->{'name'}; } $cnt++; } $cf{'users'}[$uid]->{'connection'}[$cid]->{'channel'} = [ @o ]; return "Channel $name removed"; } sub printEditConnOptions { my ($num, $num2, $txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out); my ($n, $c, $name, $sub, $cnt); return "Invalid user ID $num" if ((scalar @{$cf{'users'}}) le $num); $n = $cf{'users'}[$num]; return "Invalid connection ID $num2" if ((scalar @{$n->{'connection'}}) le $num2); $c = $n->{'connection'}[$num2]; $name = $c->{'name'}; $mhead = [ "Edit connection options $name/" . $n->{'name'}, ]; $mfoot = [ $txt ]; $mopts = { 0 => 'Return to connection ' . $name, "0.5" => undef, }; $cnt = 1; my %oo = (); foreach my $s (@{$optorder{'connection'}}) { next if (!$s); next if ($optdesc{'connection'}->{$s}->{'type'} eq 'e'); next if ($optdesc{'connection'}->{$s}->{'nosave'} eq 1); next if ($mode eq 'normal' && $optdesc{'connection'}->{$s}->{'adv'} eq 1); $mopts->{$cnt} = "Change $s: "; $mopts->{$cnt} .= $c->{$s} if (defined $c->{$s}); $oo{$cnt} = $s; $cnt++; } $act = int(printMenu($mhead, $mopts, $mfoot, $mask)); print($clear_string); if ($act eq 0) { return; } elsif ($act =~ /^\d+$/) { my $c = $cnt-1; if (($cnt-$act) le 0) { $out = "There are only $c options"; } else { my $on = $oo{$act}; $cf{'users'}[$num]->{'connection'}[$num2]->{$on} = askOpt($optdesc{'connection'}->{$on}, $cf{'users'}[$num]->{'connection'}[$num2]->{$on}); $out = "Option $on set"; pause(); } } else { $out = "Invalid option ID"; } printEditConnOptions($num, $num2, $out); } sub printEditConnection { my ($num, $num2, $txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out); my ($n, $name, $sub, $cnt, $c); return "Invalid user ID $num" if ((scalar @{$cf{'users'}}) le $num); $n = $cf{'users'}[$num]; return "Invalid connection ID $num2" if ((scalar @{$n->{'connection'}}) le $num2); $c = $n->{'connection'}[$num2]; $name = $c->{'name'}; $sub = $c->{'channel'}; $mhead = [ "Edit connection $name/" . $n->{'name'}, ]; $mfoot = [ $txt ]; $mask = "What do you want to do ?"; $mopts = { 0 => 'Return to user ' . $n->{'name'}, 1 => 'Add a channel', 2 => 'Edit options', 3 => 'Remove this connection', "3.5" => undef, }; $cnt = 4; foreach my $s (@{$sub}) { $mopts->{$cnt} = "Delete channel " . $s->{'name'}; $mopts->{$cnt} .= '/' . $s->{'key'} if (defined $s->{'key'} && $s->{'key'} ne ''); $cnt++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act eq 1) { $out = addChannel($num, $num2); } elsif ($act eq 2) { return printEditConnOptions($num, $num2); } elsif ($act eq 3) { return deleteConn($num, $num2); } elsif ($act =~ /^\d+$/) { my $c = $cnt-4; if (($cnt-$act) le 0) { $out = "This connection has only $c channels"; } else { $out = deleteChannel($num, $num2, $act-4); } } else { $out = "Invalid channel ID"; } printEditConnection($num, $num2, $out); } sub printEditUserOptions { my ($num, $txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out); my ($n, $name, $sub, $cnt); return "Invalid user ID $num" if ((scalar @{$cf{'users'}}) le $num); $n = $cf{'users'}[$num]; $name = $n->{'name'}; $mhead = [ "Edit user $name options", ]; $mfoot = [ $txt ]; $mask = "What do you want to do ?"; $mopts = { 0 => 'Return to user ' . $name, "0.5" => undef, }; $cnt = 1; my %oo = (); foreach my $s (@{$optorder{'user'}}) { next if (!$s); next if ($optdesc{'user'}->{$s}->{'type'} eq 'e'); next if ($optdesc{'user'}->{$s}->{'nosave'} eq 1); next if ($mode eq 'normal' && $optdesc{'user'}->{$s}->{'adv'} eq 1); $mopts->{$cnt} = "Change $s: "; $mopts->{$cnt} .= $n->{$s} if (defined $n->{$s}); $oo{$cnt} = $s; $cnt++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act =~ /^\d+$/) { my $c = $cnt-1; if (($cnt-$act) le 0) { $out = "There are only $c options"; } else { my $on = $oo{$act}; $cf{'users'}[$num]->{$on} = askOpt( $optdesc{'user'}->{$on}, $cf{'users'}[$num]->{$on}); $out = "Option $on set"; pause(); } } else { $out = "Invalid option ID"; } printEditUserOptions($num, $out); } sub printEditUser { my ($num, $txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out); my ($n, $name, $sub, $cnt); return "Invalid user ID $num" if ((scalar @{$cf{'users'}}) le $num); $n = $cf{'users'}[$num]; $name = $n->{'name'}; $sub = $n->{'connection'}; $mhead = [ "Edit user $name", ]; $mfoot = [ $txt ]; $mask = "What do you want to do ?"; $mopts = { 0 => 'Return to users list', 1 => 'Add a connection', 2 => 'Edit options', 3 => 'Remove this user', "3.5" => undef, }; $cnt = 4; foreach my $s (@{$sub}) { $mopts->{$cnt} = "Edit connection " . $s->{'name'}; $cnt++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act eq 1) { $out = addConnection($num); } elsif ($act eq 2) { return printEditUserOptions($num); } elsif ($act eq 3) { return delUser($num); } elsif ($act =~ /^\d+$/) { my $c = $cnt-4; if (($cnt-$act) le 0) { $out = "This user has only $c connections"; } else { $out = printEditConnection($num, $act-4) } } else { $out = "Invalid connection ID"; } printEditUser($num, $out); } sub printEditNetwork { my ($num, $txt) = @_; my ($mopts, $mhead, $mfoot, $mask, $warn, $act, $out); my ($n, $name, $sub, $cnt); return "Invalid network ID $num" if ((scalar @{$cf{'networks'}}) le $num); $n = $cf{'networks'}[$num]; $name = $n->{'name'}; $sub = $n->{'server'}; $mhead = [ "Edit network $name", ]; $mfoot = [ $txt ]; $mask = "What do you want to do ?"; $mopts = { 0 => 'Return to networks list', 1 => 'Add a server', 2 => 'Remove this network', "2.5" => undef, }; $cnt = 3; foreach my $s (@{$sub}) { $mopts->{$cnt} = "Delete server: " . $s->{'host'} . '/' . $s->{'port'}; $cnt++; } $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { return; } elsif ($act eq 1) { $out = addServer($num); } elsif ($act eq 2) { return delNetwork($num); } elsif ($act =~ /^\d+$/) { my $c = $cnt-3; if (($cnt-$act) le 0) { $out = "This network has only $c servers"; } else { $out = deleteServer($num, $act-3) } } else { $out = "Invalid server ID"; } printEditNetwork($num, $out); } sub main_menu { my ($txt) = @_; my ($act, $out, $warn, $mopts, $mhead, $mfoot); my ($mhead, $mask); $mopts = { 1 => 'Set global options', 2 => 'Add a new network', 3 => 'Add a new user', 3.5 => undef, 4 => 'View global options', 5 => 'View/Edit/Delete networks', 6 => 'View/Edit/Delete users', 7 => 'Generate a server certificate/key pair', 8 => 'Switch to ' . invMode($mode) . ' mode', 8.5 => undef, 10 => 'Exit: store, write configuration and exit', 11 => 'Exit without saving', 12 => 'Store configuration for later use', 12.5 => undef, 20 => 'Reset config options', 21 => 'Load stored config', 22 => 'Parse and load current config (todo)', }; $mhead = [ "Welcome to bip configuration program.", "This script will help you build a configuration file", ]; $mfoot = [ $txt ]; $mask = "What do you want to do ?"; $act = printMenu($mhead, $mopts, $mfoot, $mask); print($clear_string); if ($act eq 0) { } elsif ($act eq 1) { $out = setOptions(); } elsif ($act eq 2) { $out = addEntry('network'); if ($out) { push(@{$cf{'networks'}}, $out); $out = "New network added"; } else { $out = "Network add failed"; } } elsif ($act eq 3) { $out = addEntry('user'); if ($out) { push(@{$cf{'users'}}, $out); $out = "New user added"; } else { $out = "User add failed"; } } elsif ($act eq 4) { $out = printOptions(); } elsif ($act eq 5) { $out = printNetworks(); } elsif ($act eq 6) { $out = printUsers(); } elsif ($act eq 7) { $out = makeCert(); } elsif ($act eq 8) { $mode = invMode(); $out = "Ok, configuration mode set to $mode"; } elsif ($act eq 10) { print Dumper(\%cf) if ($DEBUG); $out = storeConfig($sfile); print ("$out\n") if ($out); writeConfig($CFILE); exit(0); } elsif ($act eq 11) { print Dumper(\%cf) if ($DEBUG); exit(0); } elsif ($act eq 12) { $out = storeConfig($sfile); print ("$out\n") if ($out); pause(); } elsif ($act eq 20) { $out = resetConfig(); } elsif ($act eq 21) { $out = loadConfig($sfile); } main_menu($out); } sub invMode { return ($mode eq 'advanced' ? 'normal' : 'advanced'); } main_menu(); #sets config backlog #different user/nick/real ? #################### # Serialize code, from Scott Hurring's serialize serialize module # see http://hurring.com/ for more # TODO maybe use Storable ? sub serialize { my ($value) = @_; return serialize_value($value); } sub serialize_key { my ($value) = @_; my $s; # Serialize this as an integer if ($value =~ /^\d+$/) { # Kevin Haidl - PHP can only handle (((2**32)/2) - 1) # before value must be serialized as a double if (abs($value) > ((2**32)/2-1)) { $s = "d:$value;"; } else { $s = "i:$value;"; } } # Serialize everything else as a string else { my $vlen = length($value); $s = "s:$vlen:\"$value\";"; } return $s; } sub serialize_value { my ($value) = @_; my $s; $value = defined($value) ? $value : ''; # This is a hash ref if ( ref($value) =~ /hash/i) { #The data in the hashref my $num = keys(%{$value}); $s .= "a:$num:{"; foreach my $k ( keys(%$value) ) { $s .= serialize_key( $k ); $s .= serialize_value( $$value{$k} ); } $s .= "}"; } # This is an array ref elsif ( ref($value) =~ /array/i) { #The data in the arrayref my $num = @{$value}; $s .= "a:$num:{"; for (my $k=0; $k < @$value; $k++ ) { $s .= serialize_key( $k ); $s .= serialize_value( $$value[$k] ); } $s .= "}"; } # This is a double # Thanks to Konrad Stepien # for pointing out correct handling of negative numbers. elsif ($value =~ /^\-?(\d+)\.(\d+)$/) { $s = "d:$value;"; } # This is an integer elsif ($value =~ /^\-?\d+$/) { # Kevin Haidl - PHP can only handle (((2**32)/2) - 1) # before value must be serialized as a double if (abs($value) > ((2**32)/2-1)) { $s = "d:$value;"; } else { $s = "i:$value;"; } } # This is a NULL value # # Only values of "\0" will be serialized as NULL # Empty strings are not NULL, they are simply empty strings. # @note Differs from v0.7 where string "NULL" was serialized as "N;" elsif ($value eq "\0") { $s = "N;"; } # Anything else is interpreted as a string else { my $vlen = length($value); $s = "s:$vlen:\"$value\";"; } return $s; } sub unserialize { my ($string) = @_; return unserialize_value($string); } sub unserialize_value { my ($value) = @_; # Thanks to Ron Grabowski [ronnie (at) catlover.com] for suggesting # the need for single-value unserialize code # This is an array if ($value =~ /^a:(\d+):\{(.*)\}$/) { serialize_dbg("Unserializing array"); my @chars = split(//, $2); # Add one extra char at the end so that the loop has one extra # cycle to hit the 'set' state and set the final value # Otherwise it'll terminate before setting the last value push(@chars, ';'); return unserialize_sub({}, $1*2, \@chars); } # This is a single string elsif ($value =~ /^s:(\d+):(.*);$/) { serialize_dbg("Unserializing single string ($value)"); #$string =~ /^s:(\d+):/; return $2; #return substr($string, length($1) + 4, $1); } # This is a single integer or double value elsif ($value =~ /^(i|d):(\-?\d+\.?\d+?);$/) { serialize_dbg("Unserializing integer or double ($value)"); return $2 #substr($string, 2) + 0; } # This is a NULL value # Thanks to Julian Jares [jjares at uolsinectis.com.ar] elsif ($value == /^N;$/i) { serialize_dbg("Unserializing NULL value ($value)"); return "\0"; } # This is a boolean # Thanks to Charles M Hall (cmhall at hawaii dot edu) elsif ($value =~/^b:(\d+);$/) { serialize_dbg("Unserializing boolean value ($value)"); return $1; } # Invalid data else { serialize_dbg("Unserializing BAD DATA!\n($value)"); die("Trying to unserialize bad data!"); return ''; } } sub unserialize_sub { my ($hashref, $keys, $chars) = @_; my ($temp, $keyname, $skip, $strlen); my $mode = 'normal'; #default mode serialize_dbg("> unserialize: $hashref, $keys, $chars"); # Loop through the data char-by-char, eating them as we go... while ( defined(my $c = shift @{$chars}) ) { serialize_dbg("\twhile [$mode] = $c (skip=$skip)"); # Processing a serialized string # Format: s:length:"data" if ($mode eq 'string') { $skip = 1; #how many chars should 'readstring' skip? #skip initial quote " at the beginning. #find out how many chars need to be read if ($c =~ /\d+/) { #get the length of string $strlen = $strlen . $c; } #if we already have a length, and see ':', we know that #the actual string is coming next (see format above) if (($strlen =~ /\d+/) && ($c eq ':')) { serialize_dbg("[string] length = $strlen"); $mode = 'readstring'; } } # Read $strlen number of characters into $temp elsif ($mode eq 'readstring') { next if ($skip && ($skip-- > 0)); $mode = 'set', next if (!$strlen--); $temp .= $c; } # Process a serialized integer # Format: i:data elsif ($mode eq 'integer') { next if ($c eq ':'); $mode = 'set', next if ($c eq ';'); # Grab the digits # Thanks to Konrad Stepien # for pointing out correct handling of negative numbers. if ($c =~ /\-|\d+/) { if ($c eq '-') { $temp .= $c unless $temp; } else { $temp .= $c; } } } # Process a serialized double # Format: d:data elsif ($mode eq 'double') { next if ($c eq ':'); $mode = 'set', next if ($c eq ';'); # Grab the digits # Thanks to Konrad Stepien # for pointing out correct handling of negative numbers. if ($c =~ /\-|\d+|\./) { if ($c eq '-') { $temp .= $c unless $temp; } else { $temp .= $c; } } } # Process a serialized NULL value # Format: N # Thanks to Julian Jares [jjares at uolsinectis.com.ar] elsif ($mode eq 'null') { # Set $temp to something perl will recognize as null "\0" # Don't unserialize as an empty string, becuase PHP # serializes empty srings as empty strings, not null. $temp = "\0"; $mode = 'set', next; } # Process an array # Format: a:num_of_keys:{...} elsif ($mode eq 'array') { # Start of array definition, start processing it if ($c eq '{') { $temp = unserialize_sub( $$hashref{$keyname}, ($temp*2), $chars ); # If temp is an empty array, change to {} # Thanks to Charles M Hall (cmhall at hawaii dot edu) if(!defined($temp) || $temp eq "") { $temp = {}; } $mode = 'set', next; } # Reading in the number of keys in this array elsif ($c =~ /\d+/) { $temp = $temp . $c; serialize_dbg("array_length = $temp ($c)"); } } # Do something with the $temp variable we read in. # It's either holding data for a key or a value. elsif ($mode eq 'set') { # The keyname has already been set, so that means # $temp holds the value if (defined($keyname)) { serialize_dbg("set [$keyname]=$temp"); $$hashref{$keyname} = $temp; # blank out keyname undef $keyname; } # $temp holds a keyname else { serialize_dbg("set KEY=$temp"); $keyname = $temp; } undef $temp; $mode = 'normal'; # dont eat any chars } # Figure out what the upcoming value is and set the state for it. if ($mode eq 'normal') { # Blank out temp vars used by previous state. $strlen = $temp = ''; if (!$keys) { serialize_dbg("return normally, finished processing keys"); return $hashref; } # Upcoming information is integer if ($c eq 'i') { $mode = 'integer'; $keys--; } # Upcoming information is a bool, # process the same as an integer if ($c eq 'b') { $mode = 'integer'; $keys--; } # Upcoming information is a double if ($c eq 'd') { $mode = 'double'; $keys--; } # Upcoming information is string if ($c eq 's') { $mode = 'string'; $keys--; } # Upcoming information is array/hash if ($c eq 'a') { $mode = 'array'; $keys--; } # Upcoming information is a null value if ($c eq 'N') { $mode = 'null'; $keys--; } } } #while there are chars to process # You should never hit this point. # If you do hit this, it means that the code was expecting more # characters than it was given. # Perhaps your data was unexpectedly truncated or mutilated? serialize_dbg("> unserialize_sub ran out of chars when it was expecting more."); die("unserialize_sub() ran out of characters when it was expecting more."); return 0; } sub serialize_dbg { my ($string) = @_; if ($SERIALIZE_DBG) { print $string ."\n"; } }