bip/bip
bip/bip
3
0
Fork 1
Code Issues Pull Requests 2 Releases Activity
83b19b7c5a
bip/scripts/bipgenconfig
Loïc Gomez 671a455219 Fix UTF-8 in all files
2008-01-09 23:45:40 +01:00

1730 lines
42 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/env perl
#
# This file is part of the bip project
# Copyright (C) 2004 2007 Arnaud Cornet and Loïc Gomez
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# See the file "COPYING" for the exact licensing terms.
#
use strict;
use IO::File;
use Data::Dumper;
my $bipdir = $ENV{'HOME'} . '/.bip';
my $CFILE = $bipdir . '/bip.conf.autogen';
my $sfile = $bipdir . '/bipgenconfig.store';
my $certout = $bipdir . '/bip.pem.autogen';
my $SERIALIZE_DBG = 1;
my %cf;
my $DEBUG = 0;
my $global_done = 0;
my $cert_done = 0;
my $mode = 'normal';
# maximum level of nested blocks { { { } } }
my $maxlevel = 5;
my $bipmkpw;
my $tmpcrt = "/tmp/bip-cert.cnf";
my %optcompat = (
"bl_msg_only" => "backlog_msg_only",
"blreset_on_talk" => "backlog_reset_on_talk",
"always_backlog" => "backlog_always",
);
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 ?' },
'client_side_ssl_pem' => { 'type' => 's', 'adv' => 1, 'optional' => 1,
'default' => '',
'desc' => 'Where is the bip.pem file (cert/key pair) ?' },
'pid_file' => { 'type' => 's', 'adv' => 1, 'optional' => 1,
'default' => $bipdir . '/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 channel logging ?' },
'log_system' => { 'type' => 'b', 'adv' => 0, 'default' => 'true',
'optional' => 1,
'desc' => 'Do you want to enable system logging ?' },
'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' => $bipdir . '/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}:' },
},
'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 ?' },
'admin' => { 'type' => 'b', 'adv' => 0, 'default' => 'false',
'optional' => 1,
'desc' => 'Is user an admin ?' },
'password' => { 'type' => 'p', 'adv' => 0, 'default' => '',
'optional' => 0,
'desc' => 'Set a password for his bip account:' },
'bip_use_notice' => { 'type' => 'b', 'adv' => 0, 'default' => 'false',
'optional' => 1,
'desc' => 'Do you prefer bip to use notices instead of privmsgs ?' },
'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' },
'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 ?' },
'backlog_msg_only' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Only playback users messages {chan/priv}, no nick/join/... ?' },
'backlog_always' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Always backlog {false means backlog pointers are reset after each backlog} ?' },
'backlog_reset_on_talk' => { 'type' => 'b', 'adv' => 0,
'optional' => 1,
'default' => 'false', 'depends' => 'backlog', 'depval' => 'true',
'desc' => 'Reset backlog each time an attached client "talks" ?' },
'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' },
'ssl_check_mode' => { 'type' => 's', 'adv' => 1,
'optional' => 1, 'default' => '',
'desc' => 'Type of SSL servers certificate\'s checks' },
'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' ,
'client_side_ssl_pem' ,
'pid_file' ,
undef,
'log' ,
'log_system' ,
'log_sync_interval' ,
'log_level' ,
'log_root' ,
'log_format' ,
],
'network' => [
'name' ,
'ssl' ,
'server' ,
],
'user' => [
'name' ,
'password' ,
'ssl_check_mode' ,
'ssl_check_store' ,
undef,
'default_nick' ,
'default_user' ,
'default_realname' ,
undef,
'backlog' ,
'backlog_lines' ,
'backlog_no_timestamp' ,
'backlog_msg_only' ,
'backlog_always' ,
'backlog_reset_on_talk' ,
'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' ,
'ssl_check_mode' ,
'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 = <STDIN>) {
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) = @_;
which_bipmkpw();
print("$text ? ");
my $pass = `$bipmkpw`;
chomp($pass);
$pass =~ s/^Password:\s*\n?//si;
chomp($pass);
return $pass;
}
sub which_bipmkpw {
my ($which);
return if ($bipmkpw ne '' && -x "$bipmkpw");
if (-x "/usr/bin/bipmkpw") {
$bipmkpw = '/usr/bin/bipmkpw';
return;
}
$which = `which bipmkpw`;
if ($which ne '' && -x "$which") {
$bipmkpw = $which;
return;
}
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);
}
return;
}
sub askval {
my ($text, $default, $skipblank, $star) = @_;
$text .= " ";
$text .= "[$default] " if ($default ne undef);
$text = "* $text" if $star;
print(align("$text"));
while (my $l = <STDIN>) {
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};
$cf{'networks'} = [ values %{$cf{'networks'}} ];
$cf{'users'} = [ values %{$cf{'users'}} ];
sanitizeCompat(\%cf);
foreach (@{$cf{'networks'}}) {
$_->{'server'} = [ values %{$_->{'server'}} ];
}
foreach my $tcu (@{$cf{'users'}}) {
$tcu->{'connection'} = [ values %{$tcu->{'connection'}} ];
foreach my $tcc (@{$tcu->{'connection'}}) {
$tcc->{'channel'} = [ values %{$tcc->{'channel'}} ];
}
}
return "Config loaded from $f";
}
sub sanitizeCompat {
my ($d) = @_;
foreach (keys %$d) {
if (ref($d->{$_}) eq 'ARRAY') {
foreach my $d2 (@{$d->{$_}}) {
sanitizeCompat($d2);
}
}
$d->{$optcompat{$_}} = $d->{$_} if (defined $optcompat{$_});
}
}
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') {
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 (@{$optorder{$name}}) {
next if ($k eq undef);
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 'p') {
$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");
<STDIN>;
}
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');
}
if (! -e $bipdir) {
mkdir($bipdir) || fatal("Unable to create bip's dir `$bipdir'");
} elsif (! -d $bipdir) {
fatal("Bip's dir `$bipdir' already exists and is not a directory");
} elsif (! -w $bipdir) {
fatal("Bip's dir `$bipdir' already exists and is not writable");
}
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 <konrad@interdata.net.pl>
# 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 <konrad@interdata.net.pl>
# 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 <konrad@interdata.net.pl>
# 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";
}
}
View Git Blame Copy Permalink