test BackupPC_ASA_ArchiveStart
[BackupPC.git] / makeDist
1 #!/usr/bin/env perl
2 #
3 # makeDist: Build a BackupPC distribution
4 #
5 # DESCRIPTION
6 #
7 #   This script should be run with no arguments to build a
8 #   distribution.  The $Version and $ReleaseDate should be
9 #   edited below to specify the version name and the release
10 #   date.  The distribution is createede in the sub-directory
11 #   dist.  The dsitribution is in the file name:
12 #
13 #           dist/BackupPC-$Version.tar.gz.
14 #
15 #   Often the language files are not up to date, and makeDist
16 #   exits after complaining about the lang files being inconsistent.
17 #   Use the -nolangCheck option to turn off that behavior.
18 #
19 # AUTHOR
20 #   Craig Barratt <cbarratt@users.sourceforge.net>
21 #
22 # COPYRIGHT
23 #   Copyright (C) 2001-2010  Craig Barratt
24 #
25 #   This program is free software; you can redistribute it and/or modify
26 #   it under the terms of the GNU General Public License as published by
27 #   the Free Software Foundation; either version 2 of the License, or
28 #   (at your option) any later version.
29 #
30 #   This program is distributed in the hope that it will be useful,
31 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
32 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
33 #   GNU General Public License for more details.
34 #
35 #   You should have received a copy of the GNU General Public License
36 #   along with this program; if not, write to the Free Software
37 #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
38 #
39 #========================================================================
40
41 use strict;
42 use File::Path;
43 use File::Copy;
44 use Getopt::Long;
45 use Data::Dumper;
46
47 use lib "./lib";
48 use BackupPC::Lib;
49 use BackupPC::Config::Meta qw(:all);
50
51 my $bpc;
52 die("BackupPC::Lib->new failed\n")
53         if ( !($bpc = BackupPC::Lib->new(".", ".", "./conf", 1)) );
54
55 umask(0022);
56
57 my @PerlSrc = qw(
58     bin/BackupPC
59     bin/BackupPC_archive
60     bin/BackupPC_archiveHost
61     bin/BackupPC_archiveStart
62     bin/BackupPC_attribPrint
63     bin/BackupPC_dump
64     bin/BackupPC_fixupBackupSummary
65     bin/BackupPC_link
66     bin/BackupPC_nightly
67     bin/BackupPC_restore
68     bin/BackupPC_sendEmail
69     bin/BackupPC_serverMesg
70     bin/BackupPC_trashClean
71     bin/BackupPC_tarExtract
72     bin/BackupPC_tarCreate
73     bin/BackupPC_tarPCCopy
74     bin/BackupPC_zipCreate
75     bin/BackupPC_zcat
76     lib/BackupPC/Attrib.pm
77     lib/BackupPC/Config.pm
78     lib/BackupPC/FileZIO.pm
79     lib/BackupPC/Lib.pm
80     lib/BackupPC/PoolWrite.pm
81     lib/BackupPC/Storage.pm
82     lib/BackupPC/View.pm
83     lib/BackupPC/CGI/AdminOptions.pm
84     lib/BackupPC/CGI/Archive.pm
85     lib/BackupPC/CGI/ArchiveInfo.pm
86     lib/BackupPC/CGI/Browse.pm
87     lib/BackupPC/CGI/DirHistory.pm
88     lib/BackupPC/CGI/EditConfig.pm
89     lib/BackupPC/CGI/EmailSummary.pm
90     lib/BackupPC/CGI/GeneralInfo.pm
91     lib/BackupPC/CGI/HostInfo.pm
92     lib/BackupPC/CGI/Lib.pm
93     lib/BackupPC/CGI/LOGlist.pm
94     lib/BackupPC/CGI/Queue.pm
95     lib/BackupPC/CGI/ReloadServer.pm
96     lib/BackupPC/CGI/RestoreFile.pm
97     lib/BackupPC/CGI/RestoreInfo.pm
98     lib/BackupPC/CGI/Restore.pm
99     lib/BackupPC/CGI/RSS.pm
100     lib/BackupPC/CGI/StartServer.pm
101     lib/BackupPC/CGI/StartStopBackup.pm
102     lib/BackupPC/CGI/StopServer.pm
103     lib/BackupPC/CGI/Summary.pm
104     lib/BackupPC/CGI/View.pm
105     lib/BackupPC/Config/Meta.pm
106     lib/BackupPC/Lang/cz.pm
107     lib/BackupPC/Lang/de.pm
108     lib/BackupPC/Lang/en.pm
109     lib/BackupPC/Lang/es.pm
110     lib/BackupPC/Lang/fr.pm
111     lib/BackupPC/Lang/it.pm
112     lib/BackupPC/Lang/nl.pm
113     lib/BackupPC/Lang/pl.pm
114     lib/BackupPC/Lang/pt_br.pm
115     lib/BackupPC/Lang/zh_CN.pm
116     lib/BackupPC/Storage/Text.pm
117     lib/BackupPC/Xfer.pm
118     lib/BackupPC/Xfer/Archive.pm
119     lib/BackupPC/Xfer/Ftp.pm
120     lib/BackupPC/Xfer/Protocol.pm
121     lib/BackupPC/Xfer/Rsync.pm
122     lib/BackupPC/Xfer/RsyncDigest.pm
123     lib/BackupPC/Xfer/RsyncFileIO.pm
124     lib/BackupPC/Xfer/Smb.pm
125     lib/BackupPC/Xfer/Tar.pm
126     lib/BackupPC/Zip/FileMember.pm
127     lib/Net/FTP/AutoReconnect.pm
128     lib/Net/FTP/RetrHandle.pm
129     cgi-bin/BackupPC_Admin
130 );
131
132 my %opts;
133 $opts{langCheck}   = 1;
134 $opts{syntaxCheck} = 1;
135 if ( !GetOptions(
136                  \%opts,
137                  "langCheck!",
138                  "syntaxCheck!",
139                  "version=s",
140                  "releasedate=s",
141            ) || @ARGV != 0
142              || !defined($opts{version})
143         ) {
144     print STDERR <<EOF;
145 usage: $0 [--nolangCheck] [--nosyntaxCheck] [--releasedate 'DD MMM YYYY'] --version X.Y.Z
146 EOF
147     exit(1);
148 }
149
150 my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime();
151 $year += 1900;
152
153 my @month_abbr  = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
154
155 my $Version     = $opts{version} || "3.2.0";
156 my $ReleaseDate = $opts{releasedate} || "$mday $month_abbr[$mon] $year";
157 my $DistDir     = "dist/BackupPC-$Version";
158
159 #
160 # Check config parameters
161 #
162 my $ConfVars = {};
163 my $errCnt;
164
165 $errCnt += CheckConfigParams("conf/config.pl", $ConfVars, 0);
166
167 $errCnt += CheckConfigParams("doc-src/BackupPC.pod", $ConfVars, 1);
168
169 $errCnt += CheckMetaDataVsConfig($ConfVars, "lib/BackupPC/Config/Meta.pm");
170
171 $errCnt += CheckEditorVsConfig($ConfVars, "lib/BackupPC/CGI/EditConfig.pm");
172
173 #
174 # These config parameters are not used in the code, so ignore them.
175 #
176 $ConfVars->{BackupPCUser} = 2;
177 $ConfVars->{CgiDir}       = 2;
178 $ConfVars->{TopDir}       = 2;
179 $ConfVars->{LogDir}       = 2;
180 $ConfVars->{ConfDir}      = 2;
181 $ConfVars->{InstallDir}   = 2;
182 $ConfVars->{CgiImageDir}  = 2;
183 $ConfVars->{ClientCharsetLegacy}  = 2;      # actually used
184
185 #
186 # These config parameters are used in the code to be backward compatible,
187 # but are not present in the current config file, so ignore them.
188 #
189 $ConfVars->{BlackoutHourBegin} = 2;
190 $ConfVars->{BlackoutHourEnd}   = 2;
191 $ConfVars->{BlackoutWeekDays}  = 2;
192 $ConfVars->{RsyncLogLevel}     = 2;
193
194 if ( $opts{syntaxCheck} ) {
195     system("perl -Ilib -c conf/config.pl >& /dev/null")
196             && die("$0: conf/config.pl contains a syntax error (or someone killed me)\n");
197 }
198 foreach my $file ( @PerlSrc ) {
199     if ( $opts{syntaxCheck} ) {
200         system("perl -Ilib -c $file >& /dev/null")
201             && die("$0: $file contains a syntax error (or someone killed me)\n");
202     }
203     #
204     # Skip checking of bundled libraries not explicitly part of
205     # BackupPC
206     #
207     next if ( $file =~ m/lib\/Net\/FTP/ );
208     $errCnt += CheckConfigParams($file, $ConfVars, 1);
209 }
210 if ( !$opts{langCheck} ) {
211     $errCnt += CheckLangUsage();
212     $errCnt += CheckLangTags();
213 }
214 if ( $errCnt ) {
215     print("Exiting because of errors\n");
216     exit(1)
217 }
218
219 $errCnt = 0;
220 foreach my $var ( sort(keys(%$ConfVars) ) ) {
221     next if ( $ConfVars->{$var} >= 2 || $var =~ /^\$/ );
222     printf("Unused config parameter $var\n");
223     $errCnt++;
224 }
225 if ( $errCnt ) {
226     print("Exiting because of errors\n");
227     exit(1)
228 }
229
230 rmtree($DistDir, 0, 0);
231 mkpath($DistDir, 0, 0777);
232
233 foreach my $dir ( qw(bin doc conf images init.d/src cgi-bin httpd/src
234                      lib/BackupPC/CGI
235                      lib/BackupPC/Config
236                      lib/BackupPC/Lang
237                      lib/BackupPC/Storage
238                      lib/BackupPC/Xfer
239                      lib/BackupPC/Zip
240                      lib/Net/FTP
241                 ) ) {
242     mkpath("$DistDir/$dir", 0, 0777);
243 }
244
245 my %ConfName;
246 my $ConfPod = config2pod();
247
248 rmtree("doc", 0, 0);
249 mkpath("doc", 0, 0777);
250 InstallFile("doc-src/BackupPC.pod", "doc/BackupPC.pod");
251
252 use Pod::Html;
253 pod2html("doc/BackupPC.pod",
254         "--backlink=Back to Top",
255         "--header",
256         "--title=BackupPC",
257         "--outfile=doc/BackupPC.html");
258
259 foreach my $file ( (@PerlSrc,
260             <images/*.gif>,
261             <images/*.png>,
262             <images/*.ico>,
263             qw(
264                 conf/config.pl
265                 conf/hosts
266                 conf/BackupPC_stnd.css
267                 conf/BackupPC_stnd_orig.css
268                 conf/sorttable.js
269                 init.d/README
270                 init.d/src/debian-backuppc
271                 init.d/src/freebsd-backuppc
272                 init.d/src/freebsd-backuppc2
273                 init.d/src/gentoo-backuppc
274                 init.d/src/gentoo-backuppc.conf
275                 init.d/src/linux-backuppc
276                 init.d/src/slackware-backuppc
277                 init.d/src/solaris-backuppc
278                 init.d/src/suse-backuppc
279                 httpd/src/BackupPC.conf
280                 doc/BackupPC.pod
281                 doc/BackupPC.html
282                 README
283                 LICENSE
284                 ChangeLog
285                 configure.pl
286         )) ) {
287     InstallFile("$file", "$DistDir/$file");
288 }
289 rmtree("doc", 0, 0);
290 system("cd dist ; tar zcf BackupPC-$Version.tar.gz BackupPC-$Version");
291 print("Distribution written to dist/BackupPC-$Version.tar.gz\n");
292 unlink("pod2htmd.x~~");
293 unlink("pod2htmi.x~~");
294 unlink("pod2htmd.tmp");
295 unlink("pod2htmi.tmp");
296
297 ###########################################################################
298 # Subroutines
299 ###########################################################################
300
301 sub InstallFile
302 {
303     my($file, $dest) = @_;
304
305     unlink($dest) if ( -d $dest );
306     if ( $file =~ /\.gif/ || $file =~ /\.png/ || $file =~ /\.ico/ ) {
307         die("can't copy($file, $dest)\n") unless copy($file, $dest);
308     } else {
309         open(FILE, $file)   || die("can't open $file for reading\n");
310         open(OUT, ">$dest") || die("can't open $dest for writing\n");
311         binmode(FILE);
312         binmode(OUT);
313         while ( <FILE> ) {
314             s/^([#*\s]+)Version \d+\.\d+[\.\w]*, released \d+ \w+ \d{4}\.?/$1Version __VERSION__, released __RELEASEDATE__./;
315             s/__VERSION__/$Version/g;
316             s/__RELEASEDATE__/$ReleaseDate/g;
317             if ( $file =~ /BackupPC\.html$/ ) {
318                 #
319                 # fixup for conf links
320                 #
321                 if ( !/a name="_conf/i ) {
322                     s/\$Conf{([^}]*)}/
323                         defined($ConfName{$1})
324                             ? "\L<a href=\"#$ConfName{$1}\">\E\$Conf{$1}<\/a>"
325                             : "\$Conf{$1}"/eg;
326                 }
327                 s/^<DD>/<DD><P>/;
328                 s/^<li><\/li>/<li>/;
329             }
330             if ( /__CONFIGPOD__/ ) {
331                 print OUT $ConfPod;
332             } elsif ( /^use lib ".*BackupPC\/lib";/
333                     || /^use lib "\/home\/pcbackup\/install\/lib";/ ) {
334                 print OUT "use lib \"__INSTALLDIR__/lib\";\n";
335             } elsif ( $file =~ /Lib.pm/ && /^(\s*\$topDir\s*=\s*)'.*'(\s*if\s.*)/ ) {
336                 print OUT "$1'__TOPDIR__'$2\n";
337             } elsif ( $file =~ /Lib.pm/ && /^(\s*\$installDir\s*=\s*)'.*'(\s*if\s.*)/ ) {
338                 print OUT "$1'__INSTALLDIR__'$2\n";
339             } elsif ( $file =~ /Lib.pm/ && /^(\s*ConfDir\s*=\>\s*\$confDir eq.*)'.*'(.*)/ ) {
340                 print OUT "$1'__CONFDIR__'$2\n";
341             } elsif ( $file =~ /Lib.pm/ && /^(\s*my \$useFHS\s*=\s*)\d;/ ) {
342                 print OUT "${1}0;\n";
343             } elsif ( $file =~ /Lib.pm/ && /(.*Version *=> .*)'[\w\d\.]+',/ ) {
344                 print OUT "$1'$Version',\n";
345             } elsif ( $file =~ /configure.pl/ && /__CONFIGURE_BIN_LIST__/ ) {
346                 print OUT "        ", join("\n        ", grep(/^bin\//, @PerlSrc)), "\n";
347             } elsif ( $file =~ /configure.pl/ && /__CONFIGURE_LIB_LIST__/ ) {
348                 print OUT "        ", join("\n        ", grep(/^lib\//, @PerlSrc)), "\n";
349             } elsif ( $file =~ /BackupPC_Admin/ && /(my *\$installDir *= *)'.*'/ ) {
350                 print OUT "$1'__INSTALLDIR__/lib';\n";
351             } else {
352                 print OUT;
353             }
354         }
355         close(FILE);
356         close(OUT);
357     }
358     if ( -x $file ) {
359         chmod(0555, $dest);
360     } else {
361         chmod(0444, $dest);
362     }
363 }
364
365 sub config2pod
366 {
367     open(C, "conf/config.pl") || die("can't open conf/config.pl");
368     binmode(C);
369     my($str, $out, $getHdr, @conf);
370     my $first = 1;
371     while ( <C> ) {
372         chomp;
373         s/ +$//;
374         if ( /^#########################/ ) {
375             if ( $getHdr ) {
376                 $str =~ s/\n.*//sg;
377                 $out .= "=back\n\n" if ( !$first );
378                 $out .= "=head2 $str\n\n=over 4\n\n";
379                 $str = "";
380                 $first = 0;
381             }
382             $getHdr = !$getHdr;
383             next;
384         }
385         if ( /^#/ ) {
386             s/# ?//;
387             next if ( $str eq "" && /^$/ );
388             $str .= $_ . "\n";
389             $str .= "\n" if ( $str =~ /examples?:\n$/i );
390         } elsif ( /^\$Conf{([^}]*)/ ) {
391             my $var = $1;
392             s/  +/ /g;
393             s/;\s*#.*/;/;
394             if ( !s/\[$/[ ... ];/ && !s/<<'EOF'/.../ ) {
395                 s/([^;])\s*$/$1 .../;
396             }
397             push(@conf, $_);
398             my $text = "_conf_${var}_";
399             $text =~ s{[\W\s]}{_}g;
400             $ConfName{$var} = "$text";
401         } elsif ( /^$/ ) {
402             if ( $str ne "" && @conf ) {
403                 $out .= "=item " . join("\n\n=item ", @conf) . "\n\n";
404                 $out .= $str;
405                 $out .= "\n" if ( $str !~ /\n$/ );
406             }
407             $str = "";
408             @conf = ();
409         }
410     }
411     if ( $str ne "" && @conf ) {
412         $out .= "=item " . join("\n\n=item ", @conf) . "\n\n";
413         $out .= $str;
414         $out .= "\n" if ( $str !~ /\n$/ );
415     }
416     $out .= "=back\n\n" if ( !$first );
417     return $out;
418 }
419
420 sub CheckConfigParams
421 {
422     my($file, $vars, $check) = @_;
423     my $errors;
424
425     open(F, $file) || die("can't open $file\n");
426     binmode(F);
427     if ( $check ) {
428         while ( <F> ) {
429             s/\$(self|bpc)->{Conf}{([^}\$]+)}/if ( !defined($vars->{$2}) ) {
430                     print("Unexpected Conf var $2 in $file\n");
431                     $errors++;
432                 } else {
433                     $vars->{$2}++;
434                 }/eg;
435             s/\$[Cc]onf(?:->)?{([^}\$]+)}/if ( !defined($vars->{$1}) ) {
436                     print("Unexpected Conf var $1 in $file\n");
437                     $errors++;
438                 } else {
439                     $vars->{$1}++;
440                 }/eg;
441             s/UserCommandRun\("([^"]*)"/if ( !defined($vars->{$1}) ) {
442                     print("Unexpected Conf var $1 in $file\n");
443                     $errors++;
444                 } else {
445                     $vars->{$1}++;
446                 }/eg;
447         }
448     } else {
449         while ( <F> ) {
450             s/^[^#]*\$self->{Conf}{([^}]*)/$vars->{$1} = 1;/eg;
451             s/^[^#]*\$Conf{([^}]*)/$vars->{$1} = 1;/eg;
452         }
453     }
454     close(F);
455     return $errors;
456 }
457
458 sub CheckMetaDataVsConfig
459 {
460     my($confVars, $file) = @_;
461     my $done = {};
462     my $errors;
463
464     #
465     # Check that the meta file mentions all the config
466     # parameters
467     #
468     open(F, $file) || die("can't open $file");
469
470     while ( <F> ) {
471         next if ( !/^\s{4}(\w+)\s+=>/ );
472         if ( $confVars->{$1} ) {
473             $done->{$1} = 1;
474             next;
475         }
476         next if ( $1 eq "Hosts" );
477         print("$file has $1 but missing from conf/config.pl\n");
478         $errors++;
479     }
480     close(F);
481     foreach my $v ( keys(%$confVars) ) {
482         next if ( $done->{$v} );
483         print("$file missing $v from conf/config.pl\n");
484         $errors++;
485     }
486
487     #
488     # Do extra checks that the CgiUserConfigEdit hash in the Meta
489     # file matches the config file
490     #
491     foreach my $p ( keys(%{$ConfigMeta{CgiUserConfigEdit}{child}}) ) {
492         if ( !defined($bpc->{Conf}{CgiUserConfigEdit}{$p}) ) {
493             print("lib/BackupPC/Config/Meta.pm has $p in CgiUserConfigEdit,"
494                 . " but conf/config.pl CgiUserConfigEdit does not\n");
495             $errors++;
496         }
497     }
498     foreach my $p ( keys(%{$bpc->{Conf}{CgiUserConfigEdit}}) ) {
499         if ( !defined($ConfigMeta{CgiUserConfigEdit}{child}{$p}) ) {
500             print("conf/config.pl CgiUserConfigEdit has $p, but"
501                 . " lib/BackupPC/Config/Meta.pm does not\n");
502             $errors++;
503         }
504     }
505     return $errors;
506 }
507
508 sub CheckEditorVsConfig
509 {
510     my($confVars, $file) = @_;
511     my $done = {};
512     my $errors;
513
514     #
515     # Check that the config editor file mentions all the config
516     # parameters
517     #
518     open(F, $file) || die("can't open $file");
519
520     while ( <F> ) {
521         next if ( !/name\s*=>\s*"(\w+)"/ );
522         if ( $confVars->{$1} ) {
523             $done->{$1} = 1;
524             next;
525         }
526         next if ( $1 eq "Hosts" );
527         print("$file has $1 but missing from conf/config.pl\n");
528         $errors++;
529     }
530     close(F);
531     foreach my $v ( keys(%$confVars) ) {
532         next if ( $done->{$v} );
533         print("$file missing $v from conf/config.pl\n");
534         $errors++;
535     }
536     return $errors;
537 }
538
539 #
540 # Make sure that every lang variable in cgi-bin/BackupPC_Admin matches
541 # the strings in each lib/BackupPC/Lang/*.pm file.  This makes sure
542 # we didn't miss any translations in any of the languages.
543 #
544 sub CheckLangUsage
545 {
546     my $errors;
547     my $vars = {};
548
549     foreach my $file ( (
550                 qw(cgi-bin/BackupPC_Admin bin/BackupPC_sendEmail),
551                 <lib/BackupPC/CGI/*pm>,
552                 <lib/BackupPC/Lang/en.pm>,
553             ) ) {
554         open(F, $file) || die("can't open $file");
555         binmode(F);
556         while ( <F> ) {
557             next if ( /^\s*#/ );
558             s/\$Lang->{([^}]*)}/$vars->{$1} = 1;/eg;
559             s/(text|comment)\s*=>\s*"(CfgEdit_.*)"/$vars->{$2} = 1;/eg;
560         }
561         close(F);
562     }
563
564     foreach my $f ( <lib/BackupPC/Lang/*.pm> ) {
565         my $done = {};
566         open(F, $f) || die("can't open $f\n");
567         binmode(F);
568         while ( <F> ) {
569             s/#.*//g;
570             s/\$Lang{([^}]*)}/
571                     my $var = $1;
572                     next if ( $var =~ m{^(Reason_|Status_|backupType_|Disabled_)} );
573                     next if ( $var eq "Documentation" );
574                     if ( !defined($vars->{$var}) ) {
575                         print("Unexpected Lang var $var in $f\n");
576                         $errors++;
577                     } else {
578                         $done->{$var} = 1;
579                     }/eg;
580         }
581         close(F);
582         foreach my $v ( keys(%$vars) ) {
583             #
584             # skip "variables" with "$", since they are like expressions
585             #
586             next if ( $v =~ /\$/ );
587             if ( !defined($done->{$v}) ) {
588                 print("Lang var $v missing from $f\n");
589                 $errors++;
590             }
591         }
592     }
593     return $errors;
594 }
595
596 #
597 # Pedantically check that all the html tags in each language file
598 # match.
599 #
600 sub CheckLangTags
601 {
602     my($en, $enVars) = LangParse("lib/BackupPC/Lang/en.pm");
603     my($errors);
604
605     foreach my $lang ( qw(cz.pm fr.pm de.pm es.pm it.pm nl.pm pl.pm pt_br.pm zh_CN.pm) ) {
606         my($d, $dVars) = LangParse("lib/BackupPC/Lang/$lang");
607         foreach my $v1 ( @$en ) {
608             my $v2 = shift(@$d);
609             if ( $v1->{var} ne $v2->{var} ) {
610                 print("Botch: got $lang var $v2->{var} vs en.pm $v1->{var}\n");
611                 exit;
612             }
613             my $t1 = LangTextStrip($v1->{val});
614             my $t2 = LangTextStrip($v2->{val});
615             if ( $t1 ne $t2 ) {
616                 my $i;
617                 for ( $i = 0 ; $i < length($t1) ; $i++ ) {
618                     last if ( substr($t1, 0, $i) ne substr($t2, 0, $i) );
619                 }
620                 print("$v1->{var}: ($i) got en.pm $t1\nvs $lang $t2\n\n");
621                 $errors++;
622             }
623         }
624     }
625     return $errors;
626 }
627
628 sub LangTextStrip
629 {
630     my($t) = @_;
631
632     $t = "" if ( $t !~ /<.*>/ );
633     $t =~ s/^[^<]*</</s;
634     $t =~ s/([}>])[^<]*</$1</g;
635     $t =~ s/>[^<]*$/>/;
636     $t =~ s/(value=)"[^"]*"/$1""/sg;
637     $t =~ s/({h[12]\()"[^"]*"/$1""/g;
638     $t =~ s/ENG[\s\n]*//sg;
639     $t =~ s/^(<<EOF;\n)[^<]*/$1/g;
640     return $t;
641 }
642
643 sub LangParse
644 {
645     my($file) = @_;
646     open(C, $file) || die("can't open $file");
647     binmode(C);
648     my($out, @lang, $var);
649     my $comment = 1;
650     my $allVars = {};
651     my $endLine = undef;
652     while ( <C> ) {
653         if ( /^#/ && !defined($endLine) ) {
654             if ( $comment ) {
655                 $out .= $_;
656             } else {
657                 if ( $out ne "" ) {
658                     $allVars->{$var} = @lang if ( defined($var) );
659                     push(@lang, {
660                         text => $out,
661                         var => $var,
662                     });
663                 }
664                 $var = undef;
665                 $comment = 1;
666                 $out = $_;
667             }
668         } elsif ( /^\s*\$Lang\{([^}]*)/ ) {
669             $comment = 0;
670             if ( defined($var) ) {
671                 $allVars->{$var} = @lang if ( defined($var) );
672                 push(@lang, {
673                     text => $out,
674                     var => $var,
675                 });
676                 $out = $_;
677             } else {
678                 $out .= $_;
679             }
680             $var = $1;
681             $endLine = $1 if ( /^\s*\$Lang\{[^}]*} *= *<<(.*);/ );
682             $endLine = $1 if ( /^\s*\$Lang\{[^}]*} *= *<<'(.*)';/ );
683         } else {
684             $endLine = undef if ( defined($endLine) && /^\Q$endLine[\n\r]*$/ );
685             $out .= $_;
686         }
687     }
688     if ( $out ne "" ) {
689         $allVars->{$var} = @lang if ( defined($var) );
690         push(@lang, {
691             text => $out,
692             var  => $var,
693         });
694     }
695     close(C);
696     foreach my $v ( @lang ) {
697         if ( $v->{text} =~ /\$Lang{$v->{var}}\s*=\s*(.*)/s ) {
698             $v->{val} = $1;
699         }
700     }
701     return (\@lang, $allVars);
702 }