726 lines
19 KiB
Perl
Executable File
726 lines
19 KiB
Perl
Executable File
#! /usr/bin/perl
|
|
|
|
# This version of pp_rate originates from rates4linux:
|
|
# $Id: pp_rate,v 1.9 2003/11/22 17:25:50 tobiasb Exp $
|
|
# The rates4linux homepage: http://www.sourceforge.net/projects/rates4linux/
|
|
# It bases on Rev. 1.5 of isdn4k-utils/isdnlog/tools/dest/pp_rate
|
|
# in the CVS at http://www.isdn4linux.de.
|
|
#
|
|
|
|
use wld;
|
|
use strict;
|
|
use IO::File;
|
|
$|=1;
|
|
# perl 5.8.0 could use UTF-8 as default encoding, which has to be prevented.
|
|
eval q( use open ':encoding(iso-8859-1)' );
|
|
use vars qw( %names $COUNTRY %myalias $co_dat );
|
|
use vars qw( $rtags_filename @rtags );
|
|
$COUNTRY = '../country';
|
|
$COUNTRY = '' unless (-x $COUNTRY); # disable country query if not available
|
|
# unique global determination of countryfile to use:
|
|
# The guessed filename country.dat works used within rates4linux.
|
|
$co_dat = '';
|
|
eval 'use i4lconf; $co_dat = locate_countryfile(\'country.dat\');';
|
|
unless ($co_dat) { # old behaviour as last ressort
|
|
$co_dat = '/usr/lib/isdn/country-de.dat';
|
|
}
|
|
|
|
&get_country;
|
|
&get_alias;
|
|
&prep_rate;
|
|
&process_rtags;
|
|
1;
|
|
|
|
sub get_country {
|
|
my ($name, $alias, $key, $nn, $na);
|
|
sub add1 {
|
|
my (@all, $a);
|
|
$names{lc $name}=$key;
|
|
$nn++;
|
|
@all=split(/\s*,\s*/, $alias);
|
|
foreach $a (@all) {
|
|
$na++;
|
|
$names{lc $a}=$key;
|
|
}
|
|
}
|
|
open(IN,$co_dat) || die("Cant read $co_dat");
|
|
while (<IN>) {
|
|
chomp;
|
|
s/\s*#.*$//;
|
|
s/\s+$//;
|
|
if (/^N:(.*)/) {
|
|
&add1;
|
|
$alias='';
|
|
$name=$1;
|
|
}
|
|
elsif (/^[AE]:(.*)/) {
|
|
$alias = $alias ne '' ? "$alias,$1" : $1;
|
|
}
|
|
elsif (/^T:(.*)/) {
|
|
$key=$1;
|
|
}
|
|
}
|
|
&add1;
|
|
close IN;
|
|
print "$nn Countrys $na Aliases loaded from $co_dat\n";
|
|
}
|
|
|
|
sub get_alias {
|
|
`cp ~/.country-alias .country-alias`;
|
|
open(IN, ".country-alias");
|
|
while (<IN>) {
|
|
chomp;
|
|
my($c,$a) = split(/\t/);
|
|
$myalias{$c}=$a;
|
|
}
|
|
close(IN);
|
|
}
|
|
|
|
# prototypes for lower case tag processing
|
|
sub complete_T ($\@);
|
|
sub fill_T (\@$$$$);
|
|
sub same_hours (@);
|
|
sub find_ranges (@);
|
|
|
|
sub prep_rate {
|
|
my ($l, $infile, $outfile);
|
|
my (@lines, @files, @ofiles, @streams, @outf, @Ttags);
|
|
my ($include, $wrinclude);
|
|
my $MAX_INCLUDE=3;
|
|
$wrinclude = $include = 0;
|
|
my $inc_mode;
|
|
$infile = $ARGV[0] || '/usr/lib/isdn/rate-at.dat';
|
|
$outfile = $ARGV[1] || "$infile.new";
|
|
$rtags_filename = $outfile;
|
|
$files[$include]=$infile;
|
|
$ofiles[$wrinclude]=$outfile;
|
|
wopen:
|
|
$outf[$wrinclude] = new IO::File ("$ofiles[$wrinclude]",'w');
|
|
die("Cant write $ofiles[$wrinclude]") unless defined $outf[$wrinclude];
|
|
ropen:
|
|
$lines[$include] = $l = 0;
|
|
$streams[$include] = new IO::File($files[$include]) || die("Can't read $files[$include]");
|
|
ragain:
|
|
print("\nReading $files[$include]\n");
|
|
print("Writing $ofiles[$wrinclude]\n");
|
|
while ($_=$streams[$include]->getline) {
|
|
my($a,@a, $c, $oc, $r, $d, @keys, $name, $m, $tf);
|
|
$l++;
|
|
print "$l\r";# if $l % 10 == 0;
|
|
if (/^([Ii]):\s*(\S+)/) {
|
|
my $f = $2;
|
|
$inc_mode = $1;
|
|
$f =~ s/\s*#.*$//;
|
|
if ($include >= $MAX_INCLUDE+1) {
|
|
print("Include nested to deeply - ignored\n");
|
|
next;
|
|
}
|
|
$lines[$include] = $l;
|
|
$include++;
|
|
if ($f =~ m#/#) {
|
|
$files[$include] = $f;
|
|
}
|
|
else {
|
|
my $n = $files[0];
|
|
$n =~ s#(.*/).*#$1#;
|
|
$n .= $f;
|
|
$files[$include] = $n;
|
|
}
|
|
if ($inc_mode eq 'i') { # include and put contents in same outfile
|
|
goto ropen;
|
|
}
|
|
else { # make real include file
|
|
$wrinclude++;
|
|
if ($f =~ m#/#) {
|
|
$ofiles[$wrinclude] = "$f.inc";
|
|
}
|
|
else {
|
|
my $n = $ofiles[0];
|
|
$n =~ s#(.*/).*#$1#;
|
|
$n .= $f;
|
|
$ofiles[$wrinclude] = $n;
|
|
}
|
|
if($ofiles[$wrinclude] eq $files[$include]) {
|
|
$ofiles[$wrinclude] .= '.inc';
|
|
}
|
|
$f = $ofiles[$wrinclude];
|
|
$f =~ s#.*/##;
|
|
$outf[$wrinclude-1]->print ("I:$f\n");
|
|
goto wopen;
|
|
}
|
|
}
|
|
elsif (/^A:(.*)/) {
|
|
$a=$1;
|
|
my $acmt = '';
|
|
if ( $a =~ s/(\s*#.*$)// ) { # preserve comments in A: lines
|
|
$acmt = $1;
|
|
$acmt = '' unless ( $acmt =~/#\s*\S/ ); # only non-empty
|
|
}
|
|
$a =~ s/[,\s]+$//;
|
|
@a=split(/\s*,\s*/, $a);
|
|
foreach $c (@a) {
|
|
next if ($c eq '');
|
|
$c = lc $c;
|
|
ok:
|
|
if ($c =~ /^\+?\d+/ || $c eq '+') {
|
|
push(@keys,$c);
|
|
}
|
|
elsif ($d=$names{$c}) {
|
|
push(@keys,$d);
|
|
}
|
|
elsif ($d=$names{$myalias{$c}}) {
|
|
push(@keys,$d);
|
|
}
|
|
else {
|
|
$oc = $c;
|
|
again:
|
|
print "'$c'";
|
|
$m=99; $tf='';
|
|
if ($COUNTRY) {
|
|
my $cc = `$COUNTRY "$c"`;
|
|
($tf, $m) = $cc =~ /<.*?>=<(.*?)>\sd=(\d+)/;
|
|
$m=99 if ($cc =~/unknown/);
|
|
$tf = lc $tf;
|
|
}
|
|
else {
|
|
foreach $name (keys(%names)) {
|
|
if (($r=wld($name,$c,$m)) < $m) {
|
|
$m=$r; $tf=$name;
|
|
print "\r'$c' searching (d<$m) ..";
|
|
last if($m==0);
|
|
}
|
|
}
|
|
print "\r'$c'";
|
|
}
|
|
if ($tf && $m<=1) {
|
|
push(@keys,$names{$tf});
|
|
$names{$oc}=$names{$tf};
|
|
$myalias{$oc}=$tf;
|
|
print " -> $tf\n";
|
|
}
|
|
else {
|
|
choice:
|
|
my($x);
|
|
print "\nLine $l: $c => $tf ($m)\n ? [j,q,i,[+|=]...,/] : ";
|
|
$x = <STDIN>;
|
|
chomp($x);
|
|
if ($x =~ /^=(.*)/) {
|
|
$c = $1 if($1 ne '');
|
|
goto again;
|
|
}
|
|
elsif ($x =~ /^\+(.*)/) {
|
|
$c = $oc . $1;
|
|
goto again;
|
|
}
|
|
elsif ($x =~ /^\/(.*)/) {
|
|
print `grep -3 -i $1 $co_dat`;
|
|
goto choice;
|
|
}
|
|
if ($x eq 'j') {
|
|
$c = $tf;
|
|
$myalias{$oc}=$tf;
|
|
$names{$oc}=$names{$tf};
|
|
goto ok;
|
|
}
|
|
elsif ($x eq 'h') {
|
|
print "j => Vorschlag annehmen\n";
|
|
print "q => abbrechen\n";
|
|
print "n => [ohne Funktion] unbekannt ignorieren (gilt dann fuer die gesamte Datei)\n";
|
|
print "i => Eintrag ignorieren\n";
|
|
print "+xx => xx an unbekannt anhaengen\n";
|
|
print "= SO => SO uebernehmen\n";
|
|
print "= => unbekannt uebernehmen\n";
|
|
$co_dat =~ m{/([^/]*)$};
|
|
print "/xx => in $1 nach xx greppen\n";
|
|
print "xx => xx ausprobieren\n";
|
|
goto choice;
|
|
}
|
|
elsif ($x eq 'q') {
|
|
exit;
|
|
}
|
|
elsif ($x eq 'i') {
|
|
next;
|
|
}
|
|
else {
|
|
$c = $x;
|
|
}
|
|
goto again;
|
|
}
|
|
} # else found
|
|
} # foreach
|
|
$outf[$wrinclude]->print ("A:", join(',',@keys),"$acmt\n") || die("can't write");
|
|
} # if A
|
|
elsif (/^t:(.*)/) {
|
|
$outf[$wrinclude]->print( complete_T($1, @Ttags) );
|
|
}
|
|
else { # all other lines remain unchanged
|
|
$outf[$wrinclude]->print( $_);
|
|
push @Ttags, $_ if (/^T:/);
|
|
@Ttags = () if (/^Z:/);
|
|
push @rtags, $1 if (/^r:(.*)/ and $include==0);
|
|
}
|
|
} # while IN
|
|
close($streams[$include]);
|
|
if($include) {
|
|
$include--;
|
|
$l = $lines[$include];
|
|
$infile=$files[$include];
|
|
if ($inc_mode eq 'I') { # write separate files
|
|
close($outf[$wrinclude]);
|
|
$wrinclude--;
|
|
}
|
|
goto ragain;
|
|
}
|
|
close($outf[$wrinclude]);
|
|
open(OUT, ">.country-alias") || die("Can't write .country-alias");
|
|
foreach my $c (sort(keys(%myalias))) {
|
|
print OUT "$c\t",$myalias{$c},"\n";
|
|
}
|
|
close(OUT);
|
|
`mv .country-alias ~/.country-alias`;
|
|
print "\nOk.\n";
|
|
} # prep_rate
|
|
|
|
sub process_rtags { # handle r: tags
|
|
return unless (@rtags);
|
|
print "\n$rtags_filename contains " . scalar(@rtags)
|
|
. " r: tags to process.\n";
|
|
|
|
rename($rtags_filename, $rtags_filename . ".tmp")
|
|
or die "Can't generate temporary file $rtags_filename.tmp";
|
|
open(RIN, "<" . $rtags_filename . ".tmp")
|
|
or die "Can't open $rtags_filename.tmp for input";
|
|
open(ROUT, ">". $rtags_filename)
|
|
or die "Can't open $rtags_filename for output";
|
|
|
|
# step 1 - find out requested source data
|
|
my ($src, $i, $prov, $zone, @ignore, @zones, @provs);
|
|
foreach $i (0 .. $#rtags) {
|
|
if ( $rtags[$i] =~ /^\s*(\d+|\d+\s*,\s*\d+)\s*;\s*(\d+)-\s*(#.*)?$/ ) {
|
|
$prov = $1;
|
|
$zone = $2;
|
|
$ignore[$i]=0;
|
|
}
|
|
else {
|
|
print "Illegal r: tag format: $rtags[$i], this will be ignored and remain unaltered.";
|
|
$ignore[$i]=1;
|
|
next;
|
|
}
|
|
$prov =~ s/\s+//g;
|
|
$provs[$i] = $prov;
|
|
$zones[$i] = $zone;
|
|
if ( not defined $src->{$prov}->{start} or
|
|
$zone < $src->{$prov}->{start} ) {
|
|
$src->{$prov}->{start} = $zone;
|
|
}
|
|
}
|
|
|
|
# step 2 - get this source data
|
|
print "Fetching required source data from $rtags_filename.tmp:\n";
|
|
my ($line, $getP, $getZ);
|
|
$getP = $getZ = 0;
|
|
while ($line = <RIN>) {
|
|
if ($line =~ /^P:\s*(\d+(\s*,\s*\d+)?)/) {
|
|
$prov = $1;
|
|
$prov =~ s/\s+//g;
|
|
if (defined $src->{$prov}) {
|
|
$getP = 1;
|
|
print "\t$prov: ";
|
|
}
|
|
else {
|
|
print "\n" if ($getP);
|
|
$getP = 0;
|
|
}
|
|
$getZ = 0;
|
|
next;
|
|
}
|
|
next unless ($getP);
|
|
if ($line =~ /^Z:\s*(\d+)/) {
|
|
$zone = $1;
|
|
if ($zone >= $src->{$prov}->{start}) {
|
|
unless ($getZ) {
|
|
$getZ = 1;
|
|
}
|
|
push @{$src->{$prov}->{$zone}}, $line;
|
|
print ".";
|
|
}
|
|
elsif ($getZ) {
|
|
$getZ = 0;
|
|
}
|
|
next;
|
|
}
|
|
next unless ($getZ);
|
|
if ($line =~ /^\s*#/) { # comment only line
|
|
next;
|
|
}
|
|
else {
|
|
push @{$src->{$prov}->{$zone}}, $line;
|
|
}
|
|
}
|
|
print "\n" if ($getP);
|
|
|
|
# step 3 - copy entire file and replace r: tags
|
|
my $l = 0;
|
|
my ($sline, %seen, @szones, $watch_a);
|
|
$i = -1;
|
|
seek(RIN, 0, 0) or die "Can't seek to start of $rtags_filename.tmp";
|
|
print "Rewriting to $rtags_filename:\n";
|
|
while ($line = <RIN>) {
|
|
$l++;
|
|
print "$l\r";
|
|
# TODO: watch A: lines only for providers with r: tags
|
|
if ($line =~ /^P:\s*(\d+|\d+\s*,\s*\d+)/) {
|
|
my $sprov = $1;
|
|
$sprov =~ s/\s+//g;
|
|
$rtags[$i+1] =~ /^\s*(\d+|\d+\s*,\s*\d+)/;
|
|
my $dprov = $1;
|
|
$dprov =~ s/\s+//g;
|
|
$watch_a = ($sprov eq $dprov) ? 1 : 0;
|
|
undef %seen;
|
|
}
|
|
if ($watch_a and $line =~ /^A:\s*([^#]+)/) {
|
|
my $a = $1;
|
|
my $b;
|
|
$a =~ s/\s+//g;
|
|
foreach $b (split(/,/, $a)) {
|
|
$seen{$b}++;
|
|
}
|
|
}
|
|
if ($line !~ /^r:/) {
|
|
print ROUT $line;
|
|
next;
|
|
}
|
|
# r: tag line
|
|
$i++;
|
|
if ($ignore[$i]) {
|
|
print "ignoring illegal r: tag: $line";
|
|
print ROUT $line;
|
|
next;
|
|
}
|
|
print "Processing: $line";
|
|
print ROUT "# $line";
|
|
$prov = $provs[$i];
|
|
foreach $zone (keys %{$src->{$prov}}) {
|
|
next unless ($zone =~ /^\d/);
|
|
push @szones, $zone if ($zone >= $zones[$i]);
|
|
}
|
|
foreach $zone (sort {$a<=>$b} @szones) {
|
|
my $have_a = 0;
|
|
my (@zlines, $zline);
|
|
foreach $zline (@{$src->{$prov}->{$zone}}) {
|
|
if ($zline !~ /^A:/) {
|
|
push @zlines, $zline;
|
|
next;
|
|
}
|
|
my $l = $zline;
|
|
my $right = "";
|
|
$right = $1 if ($l =~ s/(\s+#.*)$//);
|
|
chomp $l;
|
|
$right .= "\n";
|
|
$l =~ /^(A:\s*)(.*)$/;
|
|
my $left = $1;
|
|
my $dests = $2;
|
|
$dests =~ s/\s+//g;
|
|
my ($d, $nd);
|
|
foreach $d (split /,/, $dests) {
|
|
$nd .= ",$d" if (not defined $seen{$d});
|
|
}
|
|
$nd =~ s/^,//;
|
|
if ($nd) {
|
|
$have_a++;
|
|
push @zlines, "$left$nd$right";
|
|
}
|
|
}
|
|
if ($have_a) { # zone has new destinations
|
|
print ROUT join("", @zlines);
|
|
$l += scalar( @zlines );
|
|
print "$l\r";
|
|
}
|
|
}
|
|
print ROUT "# /$line";
|
|
print "$l\r";
|
|
|
|
}
|
|
|
|
close(RIN);
|
|
close(ROUT);
|
|
unlink "$rtags_filename.tmp"
|
|
or warn "Can't remove temporary file $rtags_filename.tmp";
|
|
print "\nProcessing of r: tags completed.\n";
|
|
} # /process_rtags
|
|
|
|
# handle lines with t: tag
|
|
sub complete_T ($\@) {
|
|
my $tline = shift @_ or return ""; # all after t: from input line
|
|
my $Ttags = shift @_ or return ""; # ref to array with previous A: lines
|
|
my @addT; # additional T: lines
|
|
my $range = "";
|
|
if ($tline =~ s/^\s*(\[[^\]]+\])//) {
|
|
$range = $1;
|
|
}
|
|
if ($tline =~ /^\s*(\?H?)\s*=(.*)$/) {
|
|
fill_T(@addT, $range, $1, $2, $Ttags);
|
|
}
|
|
elsif ($range and $tline =~ s/^\s*=\s*\[([^\]]+)\]//) {
|
|
my $srcrange = $1; # (start of) date range to copy from
|
|
my $re = quotemeta($srcrange);
|
|
my $newname = "";
|
|
if ( $tline =~ /^\s*([^#]+)/ ) {
|
|
$newname = $1;
|
|
$newname = "" unless ($newname =~ /\S/);
|
|
}
|
|
$re = "^T:\\s*\\[" . $re;
|
|
$re = qr/$re/;
|
|
my ($Aline, $newline);
|
|
foreach $Aline (@$Ttags) {
|
|
if ($Aline =~ $re) {
|
|
$newline = $Aline;
|
|
$newline =~ s/^(T:\s*)\[[^\]]+\]/$1.$range/e;
|
|
if ($newname) {
|
|
$newline =~ s/^([^=]+=\S+\s+)[^#]+/$1.$newname/e;
|
|
if ($newline =~ /#/) {
|
|
$Aline =~ /(\s*#)/;
|
|
my $cmtstart = $1;
|
|
$newline =~ s/(\s*#)/$cmtstart/e;
|
|
}
|
|
}
|
|
push @addT, $newline;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
print "unrecognized format for t: tag: $tline!\n";
|
|
}
|
|
|
|
push @$Ttags, @addT; # save new T: lines for next t: line
|
|
return join("", @addT);
|
|
} # /sub complete_T
|
|
|
|
sub fill_T (\@$$$$) {
|
|
my $addT = shift @_; # ref to array for new T: lines
|
|
my $range = shift @_; # date range [..] or empty
|
|
my $modus = shift @_; # fill modus: ? or ?H
|
|
my $content = shift @_; # chars right of =
|
|
my $Ttags = shift @_; # ref to array with previous A: lines
|
|
my $holiday = 0;
|
|
$holiday = 1 if ($modus =~ /H/);
|
|
|
|
# step 1 - get already definied day/hour sets.
|
|
my ($dh, $Tline, $numday, $only_anyday);
|
|
$numday = 0;
|
|
$only_anyday = 1; # only T: for day "*" present
|
|
foreach $Tline (@$Ttags) {
|
|
my ($day, $aday, @days, $hour, $ahour, @hours);
|
|
if ($Tline =~ /^T:\s*(\[[^\]]+\])\s*([1-7WEH,*-]+)\s*\/\s*([0-9,*-]+)\s*=/ ) {
|
|
next if ($range and $1 ne $range); # only T: for same date range
|
|
$day = $2;
|
|
$hour = $3;
|
|
}
|
|
elsif ($Tline =~ /^T:\s*([1-7WEH,*-]+)\s*\/\s*([0-9,*-]+)\s*=/ ) {
|
|
$day = $1;
|
|
$hour = $2;
|
|
}
|
|
else {
|
|
print "Unrecognized T: format: $Tline";
|
|
next;
|
|
}
|
|
$numday = 1 if ($day =~ /\d/); # use numbers (1-7) instead of W|E|H
|
|
$only_anyday = 0 if ($day ne "*");
|
|
foreach $aday (split(/,/, $day)) {
|
|
if ($aday =~ /^(\d)-(\d)$/) {
|
|
push @days, ($1 .. $2);
|
|
}
|
|
elsif ($aday =~ /^([\dWEH*])$/) {
|
|
push @days, ($1);
|
|
if ($1 eq "*") {
|
|
push @days, (1..7);
|
|
push @days, ("H");
|
|
}
|
|
elsif ($1 eq "W") {
|
|
push @days, (1..5);
|
|
}
|
|
elsif ($1 eq "E") {
|
|
push @days, (6, 7);
|
|
}
|
|
}
|
|
else {
|
|
print "Unknown day part: $Tline";
|
|
next;
|
|
}
|
|
}
|
|
@days = ("*") if ($only_anyday); # day "*" matches all other days
|
|
foreach $ahour (split(/,/, $hour)) {
|
|
$ahour =~ s/(^|-)0?(\d)/$1$2/g; # remove leading zeros, 00 -> 0
|
|
if ($ahour eq "*") {
|
|
push @hours, (0 .. 23, "*");
|
|
}
|
|
elsif ($ahour =~ /^(\d+)-(\d+)$/) {
|
|
my $a = $1; my $b = $2-1; # 09-18 means 9 .. 17
|
|
$b = 23 if ($b == -1);
|
|
if ($a > $b) {
|
|
push @hours, ($a .. 23);
|
|
push @hours, (0 .. $b);
|
|
}
|
|
else {
|
|
push @hours, ($a .. $b);
|
|
}
|
|
}
|
|
elsif ($ahour =~ /^(\d+)$/) {
|
|
push @hours, ($1);
|
|
}
|
|
else {
|
|
print "Unknown hour part: $Tline";
|
|
next
|
|
}
|
|
}
|
|
foreach $aday (@days) {
|
|
foreach $ahour (@hours) {
|
|
$dh->{$aday}->{$ahour}++;
|
|
}
|
|
}
|
|
} # /read all previous T: lines
|
|
|
|
# step 2 - find missing day/hour pairs
|
|
my ($d, $h, $x, $y, @adays, @bdays, @hours, %hd);
|
|
# step 2.1 - find days with complete hours
|
|
foreach $d (keys %$dh) {
|
|
if (defined $dh->{$d}->{"*"}) {
|
|
$dh->{$d}->{"_bits"} = 0xFFFFFF;
|
|
next;
|
|
}
|
|
my $bits=0;
|
|
$x=1;
|
|
for $h (0..23) {
|
|
if (defined $dh->{$d}->{$h}) {
|
|
$bits |= 1<<$h;
|
|
}
|
|
else {
|
|
$x = 0;
|
|
}
|
|
}
|
|
$dh->{$d}->{"*"}++ if ($x);
|
|
$dh->{$d}->{"_bits"} = $bits;
|
|
}
|
|
# step 2.2 - find days with hour gaps
|
|
# priority for _partial_ W or E entries
|
|
# as long as the days 1..5 / 6..7 have identical hours
|
|
# a better approach separate between common and different hours
|
|
if ( defined($dh->{W}) and scalar(%{$dh->{W}})
|
|
and not defined $dh->{W}->{"*"}
|
|
and same_hours($dh->{1},$dh->{2},$dh->{3},$dh->{4},$dh->{5}) ) {
|
|
push @adays, ("W");
|
|
map { $dh->{$_}->{"*"}++} (1..5, "W");
|
|
}
|
|
if ( defined($dh->{E}) and scalar(%{$dh->{E}})
|
|
and not defined $dh->{E}->{"*"}
|
|
and same_hours($dh->{6},$dh->{7}) ) {
|
|
push @adays, ("E");
|
|
map { $dh->{$_}->{"*"}++} (6, 7, "E");
|
|
}
|
|
if ($only_anyday) {
|
|
push @adays, ("*");
|
|
}
|
|
elsif ($numday) {
|
|
for $d (1..7) {
|
|
push @adays, ($d) unless (defined $dh->{$d}->{"*"});
|
|
}
|
|
}
|
|
else { # only W|E(|H) as day
|
|
push @adays, ("W") unless (defined $dh->{W}->{"*"});
|
|
push @adays, ("E") unless (defined $dh->{E}->{"*"});
|
|
}
|
|
if ( ($holiday or defined($dh->{H}) and scalar %{$dh->{H}})
|
|
and not defined $dh->{H}->{"*"} ) {
|
|
push @adays, ("H");
|
|
}
|
|
# step 2.3 - get hours for non empty days
|
|
foreach $d (@adays) {
|
|
unless( defined($dh->{$d}) and
|
|
scalar(%{$dh->{$d}}) ) { # hash $dh->{$d} exists at all cases
|
|
push @bdays, ($d); # day complete empty
|
|
}
|
|
else {
|
|
my $hlist="";
|
|
$x = 0; # 0 = hour already there, 1 hour missing
|
|
for $h (0..23) {
|
|
$y = not defined $dh->{$d}->{$h};
|
|
if ($x != $y) { # change existing/missing hour
|
|
if ($y) { # now missing
|
|
push @hours, ($h);
|
|
}
|
|
else {
|
|
push @hours, ($h);
|
|
}
|
|
$x = $y;
|
|
}
|
|
}
|
|
push @hours, ("0") if ($x); # terminate last hour range
|
|
if ($hours[0] == 0 and $hours[-1] == 0 ) {
|
|
$hours[0] = $hours[-2];
|
|
$#hours -= 2;
|
|
}
|
|
while (scalar @hours) {
|
|
$x = shift @hours;
|
|
$y = shift @hours;
|
|
if ($x == $y) {
|
|
$hlist .= sprintf(",%02d", $x);
|
|
}
|
|
else {
|
|
$hlist .= sprintf(",%02d-%02d", $x, $y);
|
|
}
|
|
}
|
|
$hlist =~ s/^,//;
|
|
$hd{$hlist}.=",$d"
|
|
} # /day with some hours missing
|
|
} # /foreach $d (@adays)
|
|
# step 2.4 generate T:-lines
|
|
foreach $h (sort keys %hd) {
|
|
next if $h =~ /^$/; # hourlist must not be empty
|
|
$hd{$h} =~ s/^,//;
|
|
$hd{$h} = find_ranges(split(/,/, $hd{$h}));
|
|
push @$addT, "T:$range$hd{$h}/$h=$content\n";
|
|
}
|
|
$d = find_ranges(@bdays); # generate dayranges (1-5) if possible
|
|
push @$addT, "T:$range$d/*=$content\n" if ($d);
|
|
} # /sub fill_T
|
|
|
|
# compare hours of given days (given as $dh->{day})
|
|
sub same_hours (@) {
|
|
my ($d, @days);
|
|
# use only days with hour definitions
|
|
foreach $d (@_) {
|
|
push @days, $d if (defined($d) and scalar(%$d));
|
|
}
|
|
return 1 unless (scalar(@days)); # no days, no differences
|
|
my ($and, $or);
|
|
$d = shift @days;
|
|
$and = $or = $d->{"_bits"};
|
|
foreach $d (@days) {
|
|
$or |= $d->{"_bits"};
|
|
$and &= $d->{"_bits"};
|
|
}
|
|
return ($and == $or);
|
|
} # /sub same_hours
|
|
|
|
# convert list of numbers to ranges, e.g. 1,2,3,W -> 1-3,W
|
|
sub find_ranges (@) {
|
|
my @days = sort @_;
|
|
my ($d, $x);
|
|
$x = -1; # previous day
|
|
foreach $d (@days) {
|
|
next if ($d !~ /^\d$/);
|
|
if ($x+1 == $d) {
|
|
$x = $d;
|
|
$d = "-$d";
|
|
}
|
|
else {
|
|
$x = $d;
|
|
}
|
|
}
|
|
$d = "," . join(",", @days);
|
|
while ($d =~ s/,-\d(,-\d)/$1/g) {};
|
|
$d =~ s/(,\d),(-\d)/$1$2/g;
|
|
$d =~ s/^,//;
|
|
return $d;
|
|
} # /sub find_ranges
|