dbk

   1 #!/usr/bin/env perl
   2
   3 #==============================================================================
   4 # dbk
   5 # File ID: c1080bc6-f742-11dd-acb1-000475e441b9
   6 # Ny versjon av DBK-systemet.
   7 #
   8 # Character set: UTF-8
   9 # ©opyleft 1999– Øyvind A. Holm <sunny@sunbase.org>
  10 # License: GNU General Public License version 2 or later, see end of file for
  11 # legal stuff.
  12 #==============================================================================
  13
  14 use strict;
  15 use warnings;
  16 use Getopt::Long;
  17 # use diagnostics;
  18 use Time::Local;
  19 use Fcntl ':flock';
  20
  21 local $| = 1;
  22
  23 our %Opt = (
  24
  25         'batch' => 0,
  26         'force' => 0,
  27         'help' => 0,
  28         'insert-file' => "",
  29         'now' => 0,
  30         'quiet' => 0,
  31         'verbose' => 0,
  32         'version' => 0,
  33         'zone' => 0,
  34
  35 );
  36
  37 our $progname = $0;
  38 $progname =~ s/^.*\/(.*?)$/$1/;
  39 our $VERSION = '0.2.0';
  40
  41 my $STD_DIR = "$ENV{HOME}/dbk";
  42 my $STD_VIEWER = "lynx -assume_charset=UTF-8";
  43
  44 Getopt::Long::Configure('bundling');
  45 GetOptions(
  46
  47         'batch|b' => \$Opt{'batch'},
  48         'force|f' => \$Opt{'force'},
  49         'help|h' => \$Opt{'help'},
  50         'insert-file|i=s' => \$Opt{'insert-file'},
  51         'now|t' => \$Opt{'now'},
  52         'quiet|q+' => \$Opt{'quiet'},
  53         'verbose|v+' => \$Opt{'verbose'},
  54         'version' => \$Opt{'version'},
  55         'zone|z' => \$Opt{'zone'},
  56
  57 ) || die("$progname: Option error. Use -h for help.\n");
  58
  59 $Opt{'verbose'} -= $Opt{'quiet'};
  60 $Opt{'help'} && usage(0);
  61 if ($Opt{'version'}) {
  62         print_version();
  63         exit(0);
  64 }
  65
  66 my $time_not_found = 0;
  67
  68 exit(main());
  69
  70 sub main {
  71         my $Retval = 0;
  72
  73         my $Editor = "v --";
  74         my $dbk_dir;
  75         if (defined($ENV{'DBK_DIR'}) && length($ENV{'DBK_DIR'})) {
  76                 $dbk_dir = $ENV{'DBK_DIR'};
  77         } else {
  78                 $dbk_dir = $STD_DIR;
  79         }
  80         my $Viewer;
  81         if (defined($ENV{'DBK_VIEWER'}) && length($ENV{'DBK_VIEWER'})) {
  82                 $Viewer = $ENV{'DBK_VIEWER'};
  83         } else {
  84                 $Viewer = $STD_VIEWER;
  85         }
  86         my $dbk_ext = ".html";
  87         my $dbk_lockext = ".lock";
  88         my $dir_mode = 0770;
  89
  90         my $curr_time = time;
  91         my @day_name = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
  92
  93         msg(3, "$0: \$Opt{'now'} = $Opt{'now'}");
  94
  95         my ($Sec, $Min, $Hour, $Day, $Mon, $Year, $Wday, $Yday, $is_dst)
  96            = localtime($curr_time);
  97
  98         $Year += 1900;
  99         $Mon += 1;
 100
 101         msg(3, "\$curr_time: $Year-$Mon-$Day $Hour:$Min:$Sec,"
 102                . " \$Wday = $Wday, \$Yday = $Yday, \$is_dst = $is_dst");
 103
 104         # Parameterparsing og initialisering av datovariabler
 105         my $arg_count;
 106         my $time_str = ""; # Strengen som det vil bli leita etter og som blir
 107                            # satt inn.
 108
 109         foreach (@ARGV) {
 110                 /^\d\d:/ && (splice(@ARGV, $arg_count, 1),
 111                              $time_str = $_,
 112                              $Opt{'now'} = 1);
 113                 $arg_count++;
 114         }
 115
 116         $Year = $ARGV[2] if $#ARGV >= 2;
 117         $Mon = sprintf("%02u", $ARGV[1]) if $#ARGV >= 1;
 118         $Day = sprintf("%02u", $ARGV[0]) if $#ARGV >= 0;
 119
 120         # Når vi nærmer oss 2030 begynner dette å bli en fixme. :)
 121         if ($Year < 30) {
 122                 $Year += 2000;
 123         } elsif ($Year < 100) {
 124                 $Year += 1900;
 125         }
 126
 127         $Mon =~ s/^(\d)$/0$1/;
 128         $Day =~ s/^(\d)$/0$1/;
 129         $Hour =~ s/^(\d)$/0$1/;
 130         $Min =~ s/^(\d)$/0$1/;
 131         $Sec =~ s/^(\d)$/0$1/;
 132
 133         die("$0: $Day: Feil format på datoen\n") unless ($Day =~ /^\d\d$/);
 134         die("$0: $Mon: Feil format på måneden\n") unless ($Mon =~ /^\d\d$/);
 135         die("$0: $Year: Feil format på året\n") unless ($Year =~ /^\d\d\d\d$/);
 136
 137         my $time_utc = timegm($Sec, $Min, $Hour, $Day, $Mon-1, $Year);
 138         my $time_sec = timelocal($Sec, $Min, $Hour, $Day, $Mon-1, $Year);
 139         my @time_arr = localtime($time_sec);
 140         my $week_day = $time_arr[6];
 141         my $utc_diff = ($time_utc-$time_sec)/3600;
 142
 143         msg(3, "Etter ARGV: $Year-$Mon-$Day");
 144         msg(3, "\$dbk_dir = $dbk_dir");
 145         msg(3, "\$Opt{'insert-file'} = \"$Opt{'insert-file'}\"");
 146
 147         # Sjekk at alle katalogene er på plass
 148         my $year_dir = "$dbk_dir/$Year";
 149         my $dbk_file = "$year_dir/${Year}${Mon}${Day}${dbk_ext}";
 150         my $lock_dir = "$year_dir/${Year}${Mon}${Day}${dbk_lockext}";
 151
 152         umask(0);
 153         unless (-d $dbk_dir) {
 154                 mkdir($dbk_dir, $dir_mode)
 155                 || die("$0: $dbk_dir: Kan ikke lage directoryen: $!\n");
 156         }
 157         unless (-d $year_dir) {
 158                 mkdir($year_dir, $dir_mode)
 159                 || die("$0: $year_dir: Kan ikke lage directoryen: $!\n");
 160         }
 161
 162         msg(3, "\$dbk_file = $dbk_file");
 163
 164         if ($Opt{'force'}) {
 165                 rmdir($lock_dir) || warn("$0: $lock_dir:"
 166                                          . " Kan ikke fjerne gammel lockdir"
 167                                          . " med makt: $!\n");
 168         }
 169
 170         create_lock($lock_dir);
 171
 172         open(CheckFP, ">$year_dir/.check")
 173         || die("$0: $year_dir/.check: Klarte ikke å lage fila: $!\n");
 174         close(CheckFP);
 175         unlink("$year_dir/.check")
 176         || die("$0: $year_dir/.check: Cannot delete file, aborting");
 177
 178         unless (-f $dbk_file) {
 179                 open(FP, ">$dbk_file")
 180                 || die("$0: $dbk_file: Kan ikke åpne fila for skriving: $!\n");
 181                 print(FP "<h1>$day_name[$week_day] $Year-$Mon-$Day</h1>\n")
 182                 || die("$0: $dbk_file: Kan ikke skrive header til fila: $!\n");
 183                 close(FP);
 184         }
 185
 186         my $min_size = 0; # Minimum size of file to prevent deletion
 187
 188         if ($Opt{'now'}) {
 189                 # Legg til klokkeslettet akkurat nå i fila og gå inn i editoren
 190                 my $utc_str = sprintf("%s%02u00",
 191                                       $utc_diff < 0 ? "-" : "+", $utc_diff);
 192                 $utc_str = "" unless $Opt{'zone'};
 193                 if (length($time_str)) {
 194                         $time_str .= $utc_str;
 195                 } else {
 196                         $time_str = "$Hour:$Min:$Sec$utc_str";
 197                 }
 198                 open(dbkFP, "+<$dbk_file")
 199                 || die("$0: $dbk_file:"
 200                        . " Kan ikke åpne fila for lesing+skriving+flock:"
 201                        . " $!\n");
 202                 flock(dbkFP, LOCK_EX)
 203                 || die("$0: $dbk_file: Klarte ikke flock(): $!\n");
 204                 my $which_line = find_line($dbk_file, $time_str);
 205                 if ($time_not_found) {
 206                         seek(dbkFP, 0, 2)
 207                         || die("$0: $dbk_file: Klarte ikke å seeke"
 208                                . " til slutten for å legge til LF: $!\n");
 209                         print(dbkFP "\n")
 210                         || warn("$0: $dbk_file: Feil under skriving til fila:"
 211                                 . " $!\n");
 212                         $which_line++;
 213                 }
 214                 length($Opt{'insert-file'})
 215                         ? insert_file($dbk_file, $Opt{'insert-file'},
 216                                       $which_line, $time_str)
 217                         : insert_time($dbk_file, $time_str, $which_line);
 218                 close(dbkFP);
 219                 $which_line++;
 220                 system("$Editor +$which_line $dbk_file") unless
 221                     (length($Opt{'insert-file'}) || length($Opt{'batch'}));
 222                 $min_size = 49;
 223         } else {
 224                 $min_size = 25;
 225         }
 226
 227         unless ($Opt{'batch'}) {
 228                 system("$Viewer $dbk_file");
 229         }
 230
 231         my @stat_info = stat($dbk_file);
 232         my $file_size = $stat_info[7];
 233         if ($file_size < $min_size) {
 234                 print("Ingenting ble skrevet, så jeg sletter driten.\n");
 235                 unlink($dbk_file)
 236                 || warn("$0: $dbk_file: Klarte ikke å slette fila: $!\n");
 237                 rmdir($year_dir);
 238         }
 239
 240         remove_lock($lock_dir);
 241
 242         return $Retval;
 243 }
 244
 245 #### SUBRUTINER ####
 246
 247 sub create_lock {
 248         my $lock_dir = shift;
 249         my $print_ok = 0;
 250
 251         until (mkdir($lock_dir, 0777)) {
 252                 $print_ok || print(STDERR "Venter på at lockdir $lock_dir"
 253                                           . " skal forsvinne ($!)..");
 254                 print(".");
 255                 sleep(1);
 256                 $print_ok = 1;
 257         }
 258         $print_ok && print("OK\n");
 259
 260         return;
 261 }
 262
 263 sub remove_lock {
 264         my $lock_dir = shift;
 265
 266         rmdir($lock_dir)
 267         || die("$0: $lock_dir: Klarte ikke å slette lockdir: $!\n");
 268
 269         return;
 270 }
 271
 272 sub find_line {
 273         my ($dbk_file, $srch_time) = @_;
 274         my $last_line = 0;
 275         my $Found = 0;
 276         seek(dbkFP, 0, 0)
 277         || die("$dbk_file: Klarte ikke å gå til begynnelsen av fila: $!\n");
 278         while (<dbkFP>) {
 279                 if (/^(?:<p>)?<b>(\d\d:\d\d:\d\d)/i
 280                     || /^(?:<p>)?<b>(\d\d:\d\d)/i) {
 281                         my $found_time = $1;
 282                         return($.) if ($srch_time lt $found_time);
 283                 }
 284         }
 285         $time_not_found = 1;
 286         return($. + 1);
 287 }
 288
 289 sub insert_time {
 290         my ($dbk_file, $time_str, $line_num) = @_;
 291         seek(dbkFP, 0, 0)
 292         || die("$dbk_file: Klarte ikke å gå"
 293                . " til begynnelsen av fila i insert_time(): $!\n");
 294         my @Linjer = <dbkFP>;
 295         splice(
 296             @Linjer,
 297             $line_num-1,
 298             0,
 299             sprintf("<b>$time_str</b> -\n%s", $time_not_found ? "" : "\n")
 300         );
 301         seek(dbkFP, 0, 0)
 302         || die("$0: $dbk_file: Klarte ikke å seeke til starten"
 303                . " i insert_time(): $!\n");
 304         truncate(dbkFP, 0)
 305         || die("$0: $dbk_file: Klarte ikke å trunce fila til 0: $!\n");
 306         foreach (@Linjer) {
 307                 print(dbkFP $_)
 308                 || warn("$0: $dbk_file: Å neiiii, katastrofe!"
 309                         . " Feil under skriving til fila: $!\n");
 310         }
 311 }
 312
 313 sub is_utf8 {
 314         # Sjekker om en tekst inneholder ulovlige UTF-8-sekvenser og returnerer
 315         # i så fall 0
 316         my $Str = shift;
 317         my $Retval = 1;
 318         # Henta fra "find_inv_utf8,v 1.1 2001/09/07 08:54:31 sunny" og
 319         # modifisert litt. FIXME: Klager ikke på overlange sekvenser og tegn i
 320         # UTF-16-surrogatområdet
 321         $Str =~ s/([\xFC-\xFD][\x80-\xBF][\x80-\xBF]
 322                    [\x80-\xBF][\x80-\xBF][\x80-\xBF])//gx;
 323         $Str =~ s/([\xF8-\xFB][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])//g;
 324         $Str =~ s/([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])//g;
 325         $Str =~ s/([\xE0-\xEF][\x80-\xBF][\x80-\xBF])//g;
 326         $Str =~ s/([\xC0-\xDF][\x80-\xBF])//g;
 327         $Retval = 0 if ($Str =~ /[\x80-\xFD]/);
 328         msg(3, "is_utf8() returnerer $Retval.");
 329         return $Retval;
 330 }
 331
 332 sub insert_file {
 333         my ($dbk_file, $file_name, $line_num, $time_str) = @_;
 334         local *LocFP;
 335         seek(dbkFP, 0, 0)
 336         || die("$0: $dbk_file: Klarte ikke å gå til begynnelsen av fila"
 337                . " i insert_file(): $!\n");
 338         my @Linjer = <dbkFP>;
 339         my @InsLinj = "<b>$time_str</b> -\n";
 340         open(LocFP, "<$file_name")
 341         || die("$0: $file_name: Kan ikke åpne fila for lesing: $!\n");
 342         push(@InsLinj, <LocFP>);
 343         push(@InsLinj, "\n") unless $time_not_found; # Denne likte jeg egentlig
 344                                                      # fantastisk dårlig, men
 345                                                      # hvem bruker vel å ha to
 346                                                      # LF’er på slutten av
 347                                                      # fila?
 348         for (@InsLinj) {
 349                 msg(3, "\$_ = \"$_\"");
 350                 if (!is_utf8($_)) {
 351                         warn("$0: Ugyldig UTF-8 funnet,"
 352                              . " behandler teksten som ISO-8859-1.\n");
 353                         my @Ny = ();
 354                         for my $Curr (@InsLinj) {
 355                                 msg(3, "FØR  : \$Curr = \"$Curr\"");
 356                                 $Curr =~ s/([\x80-\xFF])/widechar(ord($1))/ge;
 357                                 msg(3, "ETTER: \$Curr = \"$Curr\"");
 358                                 push(@Ny, $Curr);
 359                         }
 360                         @InsLinj = @Ny;
 361                         last;
 362                 }
 363         }
 364         splice(@Linjer, $line_num-1, 0, @InsLinj);
 365         close(LocFP);
 366         seek(dbkFP, 0, 0)
 367         || die("$0: $dbk_file: Klarte ikke å seeke til starten"
 368                . " i insert_file(): $!\n");
 369         truncate(dbkFP, 0)
 370         || die("$0: $dbk_file: Klarte ikke å trunce fila til 0: $!\n");
 371         msg(3, "scalar(\@Linjer): \"" . scalar(@Linjer) . "\".");
 372         foreach my $Curr (@Linjer) {
 373                 $Curr =~ s/&#(\d{1,10});/widechar($1)/ge;
 374                 $Curr =~ s/&#x([0-9a-f]{1,8});/widechar(hex($1))/gei;
 375                 print(dbkFP $Curr)
 376                 || warn("$0: $dbk_file: Knallkrise."
 377                         . " Feil under skriving til fila: $!\n");
 378         }
 379 }
 380
 381 sub print_version {
 382         # Print program version
 383         print("$progname $VERSION\n");
 384         return;
 385 }
 386
 387 sub usage {
 388         # Send the help message to stdout
 389         my $Retval = shift;
 390
 391         if ($Opt{'verbose'}) {
 392                 print("\n");
 393                 print_version();
 394         }
 395         print(<<"END");
 396
 397 Syntax: $progname [valg] [dag [måned [år]]] [HH:MM]
 398
 399 Options:
 400
 401   -b, --batch
 402     Batch mode, ikke start editor eller viewer.
 403   -f, --force
 404     Force, start dbk selv om lockdir eksisterer.
 405   -h, --help
 406     Show this help.
 407   -i x, --insert-file x
 408     Sett inn filen x istedenfor å bruke tastatur. Forventer -t eller
 409     klokkeslett.
 410   -q, --quiet
 411     Be more quiet. Can be repeated to increase silence.
 412   -t, --now
 413     Legg til klokkeslettet akkurat nå i fila og gå inn i editoren
 414   -v, --verbose
 415     Increase level of verbosity. Can be repeated.
 416   --version
 417     Print version information.
 418   -z, --zone
 419     Legg til tidssone til klokkeslett
 420
 421 Klokkeslettet kan spesifiseres hvor som helst, men må starte med
 422 formatet "HH:" der HH er to siffer.
 423
 424 Environment variables:
 425
 426   DBK_DIR
 427     Path to directory where files will be stored.
 428     Default: "$STD_DIR"
 429   DBK_VIEWER
 430     Specify HTML browser to use when viewing files.
 431     Default: "$STD_VIEWER"
 432
 433 END
 434         exit($Retval);
 435 }
 436
 437 sub msg {
 438         # Print a status message to stderr based on verbosity level
 439         my ($verbose_level, $Txt) = @_;
 440
 441         if ($Opt{'verbose'} >= $verbose_level) {
 442                 print(STDERR "$progname: $Txt\n");
 443         }
 444         return;
 445 }
 446
 447 sub widechar {
 448         # Konverterer en tegnverdi til UTF-8
 449         # Henta fra "h2u,v 1.5 2002/11/20 00:09:40 sunny".
 450         my $Val = shift;
 451         my $allow_invalid = 0;
 452
 453         if ($Val < 0x80) {
 454                 return sprintf("%c", $Val);
 455         } elsif ($Val < 0x800) {
 456                 return sprintf("%c%c", 0xC0 | ($Val >> 6),
 457                                        0x80 | ($Val & 0x3F));
 458         } elsif ($Val < 0x10000) {
 459                 unless ($allow_invalid) {
 460                         if (($Val >= 0xD800 && $Val <= 0xDFFF)
 461                             || ($Val eq 0xFFFE)
 462                             || ($Val eq 0xFFFF)) {
 463                                 $Val = 0xFFFD;
 464                         }
 465                 }
 466                 return sprintf("%c%c%c", 0xE0 |  ($Val >> 12),
 467                                          0x80 | (($Val >>  6) & 0x3F),
 468                                          0x80 |  ($Val        & 0x3F));
 469         } elsif ($Val < 0x200000) {
 470                 return sprintf("%c%c%c%c", 0xF0 |  ($Val >> 18),
 471                                            0x80 | (($Val >> 12) & 0x3F),
 472                                            0x80 | (($Val >>  6) & 0x3F),
 473                                            0x80 |  ($Val        & 0x3F));
 474         } elsif ($Val < 0x4000000) {
 475                 return sprintf("%c%c%c%c%c", 0xF8 |  ($Val >> 24),
 476                                              0x80 | (($Val >> 18) & 0x3F),
 477                                              0x80 | (($Val >> 12) & 0x3F),
 478                                              0x80 | (($Val >>  6) & 0x3F),
 479                                              0x80 | ( $Val        & 0x3F));
 480         } elsif ($Val < 0x80000000) {
 481                 return sprintf("%c%c%c%c%c%c", 0xFC |  ($Val >> 30),
 482                                                0x80 | (($Val >> 24) & 0x3F),
 483                                                0x80 | (($Val >> 18) & 0x3F),
 484                                                0x80 | (($Val >> 12) & 0x3F),
 485                                                0x80 | (($Val >>  6) & 0x3F),
 486                                                0x80 | ( $Val        & 0x3F));
 487         } else {
 488                 return widechar(0xFFFD);
 489         }
 490 }
 491
 492 __END__
 493
 494 # This program is free software; you can redistribute it and/or modify it under
 495 # the terms of the GNU General Public License as published by the Free Software
 496 # Foundation; either version 2 of the License, or (at your option) any later
 497 # version.
 498 #
 499 # This program is distributed in the hope that it will be useful, but WITHOUT
 500 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
 501 # FOR A PARTICULAR PURPOSE.
 502 # See the GNU General Public License for more details.
 503 #
 504 # You should have received a copy of the GNU General Public License along with
 505 # this program.
 506 # If not, see L<http://www.gnu.org/licenses/>.
 507
 508 # vim: set ts=8 sw=8 sts=8 noet fo+=w tw=79 fenc=UTF-8 :