]> scm.dxcluster.org Git - spider.git/blob - perl/convert_users.pl
fix pc20 disconnect
[spider.git] / perl / convert_users.pl
1 #!/usr/bin/perl
2 #
3 # Export the user file in a form that can be directly imported
4 # back with a do statement
5 #
6
7 require 5.004;
8
9 # search local then perl directories
10 BEGIN {
11         umask 002;
12         
13         # root of directory tree for this system
14         $root = "/spider"; 
15         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
16         
17         unshift @INC, "$root/perl";     # this IS the right way round!
18         unshift @INC, "$root/local";
19 }
20
21 use DXVars;
22 use DB_File;
23 use Fcntl;
24 use Carp;
25
26 $userfn = $ARGV[0] if @ARGV;
27 unless ($userfn) {
28         croak "need a filename";
29 }
30
31 DXUser->init($userfn);
32 unlink "$userfn.asc";
33 open OUT, ">$userfn.asc" or die;
34
35 %newu = ();
36 $t = scalar localtime;
37 print OUT "#!/usr/bin/perl
38 #
39 # The exported userfile for a DXSpider System
40
41 # Input file: $userfn
42 #       Time: $t
43 #
44
45 package DXUser;
46
47 %u = (
48 ";
49
50 @all = DXUser::get_all_calls();
51
52 for $a (@all) {
53         my $ref = DXUser->get($a);
54         my $s = $ref->encode() if $ref;
55         print OUT "'$a' => q{$s},\n" if $a;
56         $count++;
57 }
58
59 DXUser->finish();
60
61 print OUT ");
62 #
63 # there were $count records
64 #\n";
65
66         close(OUT);
67
68 exit(0);
69
70
71 package DXUser;
72
73
74 use MLDBM qw(DB_File);
75 use Fcntl;
76 use Carp;
77
78 #
79 # initialise the system
80 #
81 sub init
82 {
83         my ($pkg, $fn, $mode) = @_;
84   
85         confess "need a filename in User" if !$fn;
86         if ($mode) {
87                 $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
88         } else {
89                 $dbm = tie (%u, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)";
90         }
91         
92         $filename = $fn;
93 }
94
95 #
96 # close the system
97 #
98
99 sub finish
100 {
101         untie %u;
102 }
103
104 #
105 # get - get an existing user - this seems to return a different reference everytime it is
106 #       called - see below
107 #
108
109 sub get
110 {
111         my $pkg = shift;
112         my $call = uc shift;
113         #  $call =~ s/-\d+$//o;       # strip ssid
114         return $u{$call};
115 }
116
117 #
118 # get all callsigns in the database 
119 #
120
121 sub get_all_calls
122 {
123         return (sort keys %u);
124 }
125
126
127
128 # create a string from a user reference
129 #
130 sub encode
131 {
132         my $self = shift;
133         my $out;
134         my $f;
135
136         $out = "bless( { ";
137         for $f (sort keys %$self) {
138                 my $val = $$self{$f};
139             if (ref $val) {          # it's an array (we think)
140                         $out .= "'$f'=>[ ";
141                         foreach (@$val) {
142                                 my $s = $_;
143                                 $out .= "'$s',";
144                         }
145                         $out .= " ],";
146             } else {
147                         $val =~ s/'/\\'/og;
148                         $val =~ s/\@/\\@/og;
149                         $out .= "'$f'=>'$val',";
150                 }
151         }
152         $out .= " }, 'DXUser')";
153         return $out;
154 }
155