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                 chomp(my $file_id = `suuid -t fileid,dbk`);
 182                 print(FP "<!-- File ID: $file_id -->\n\n")
 183                 || die("$0: $dbk_file: Cannot write suuid to file: $!\n");
 184                 print(FP "<h1>$day_name[$week_day] $Year-$Mon-$Day</h1>\n")
 185                 || die("$0: $dbk_file: Kan ikke skrive header til fila: $!\n");
 186                 close(FP);
 187         }
 188
 189         my $min_size = 0; # Minimum size of file to prevent deletion
 190
 191         if ($Opt{'now'}) {
 192                 # Legg til klokkeslettet akkurat nå i fila og gå inn i editoren
 193                 my $utc_str = sprintf("%s%02u00",
 194                                       $utc_diff < 0 ? "-" : "+", $utc_diff);
 195                 $utc_str = "" unless $Opt{'zone'};
 196                 if (length($time_str)) {
 197                         $time_str .= $utc_str;
 198                 } else {
 199                         $time_str = "$Hour:$Min:$Sec$utc_str";
 200                 }
 201                 open(dbkFP, "+<$dbk_file")
 202                 || die("$0: $dbk_file:"
 203                        . " Kan ikke åpne fila for lesing+skriving+flock:"
 204                        . " $!\n");
 205                 flock(dbkFP, LOCK_EX)
 206                 || die("$0: $dbk_file: Klarte ikke flock(): $!\n");
 207                 my $which_line = find_line($dbk_file, $time_str);
 208                 if ($time_not_found) {
 209                         seek(dbkFP, 0, 2)
 210                         || die("$0: $dbk_file: Klarte ikke å seeke"
 211                                . " til slutten for å legge til LF: $!\n");
 212                         print(dbkFP "\n")
 213                         || warn("$0: $dbk_file: Feil under skriving til fila:"
 214                                 . " $!\n");
 215                         $which_line++;
 216                 }
 217                 length($Opt{'insert-file'})
 218                         ? insert_file($dbk_file, $Opt{'insert-file'},
 219                                       $which_line, $time_str)
 220                         : insert_time($dbk_file, $time_str, $which_line);
 221                 close(dbkFP);
 222                 $which_line++;
 223                 system("$Editor +$which_line $dbk_file") unless
 224                     (length($Opt{'insert-file'}) || length($Opt{'batch'}));
 225                 $min_size = 100;
 226         } else {
 227                 $min_size = 81;
 228         }
 229
 230         unless ($Opt{'batch'}) {
 231                 system("$Viewer $dbk_file");
 232         }
 233
 234         my @stat_info = stat($dbk_file);
 235         my $file_size = $stat_info[7];
 236         if ($file_size < $min_size) {
 237                 print("Ingenting ble skrevet, så jeg sletter driten.\n");
 238                 unlink($dbk_file)
 239                 || warn("$0: $dbk_file: Klarte ikke å slette fila: $!\n");
 240                 rmdir($year_dir);
 241         }
 242
 243         remove_lock($lock_dir);
 244
 245         return $Retval;
 246 }
 247
 248 #### SUBRUTINER ####
 249
 250 sub create_lock {
 251         my $lock_dir = shift;
 252         my $print_ok = 0;
 253
 254         until (mkdir($lock_dir, 0777)) {
 255                 $print_ok || print(STDERR "Venter på at lockdir $lock_dir"
 256                                           . " skal forsvinne ($!)..");
 257                 print(".");
 258                 sleep(1);
 259                 $print_ok = 1;
 260         }
 261         $print_ok && print("OK\n");
 262
 263         return;
 264 }
 265
 266 sub remove_lock {
 267         my $lock_dir = shift;
 268
 269         rmdir($lock_dir)
 270         || die("$0: $lock_dir: Klarte ikke å slette lockdir: $!\n");
 271
 272         return;
 273 }
 274
 275 sub find_line {
 276         my ($dbk_file, $srch_time) = @_;
 277         my $last_line = 0;
 278         my $Found = 0;
 279         seek(dbkFP, 0, 0)
 280         || die("$dbk_file: Klarte ikke å gå til begynnelsen av fila: $!\n");
 281         while (<dbkFP>) {
 282                 if (/^(?:<p>)?<b>(\d\d:\d\d:\d\d)/i
 283                     || /^(?:<p>)?<b>(\d\d:\d\d)/i) {
 284                         my $found_time = $1;
 285                         return($.) if ($srch_time lt $found_time);
 286                 }
 287         }
 288         $time_not_found = 1;
 289         return($. + 1);
 290 }
 291
 292 sub insert_time {
 293         my ($dbk_file, $time_str, $line_num) = @_;
 294         seek(dbkFP, 0, 0)
 295         || die("$dbk_file: Klarte ikke å gå"
 296                . " til begynnelsen av fila i insert_time(): $!\n");
 297         my @Linjer = <dbkFP>;
 298         splice(
 299             @Linjer,
 300             $line_num-1,
 301             0,
 302             sprintf("<b>$time_str</b> -\n%s", $time_not_found ? "" : "\n")
 303         );
 304         seek(dbkFP, 0, 0)
 305         || die("$0: $dbk_file: Klarte ikke å seeke til starten"
 306                . " i insert_time(): $!\n");
 307         truncate(dbkFP, 0)
 308         || die("$0: $dbk_file: Klarte ikke å trunce fila til 0: $!\n");
 309         foreach (@Linjer) {
 310                 print(dbkFP $_)
 311                 || warn("$0: $dbk_file: Å neiiii, katastrofe!"
 312                         . " Feil under skriving til fila: $!\n");
 313         }
 314 }
 315
 316 sub is_utf8 {
 317         # Sjekker om en tekst inneholder ulovlige UTF-8-sekvenser og returnerer
 318         # i så fall 0
 319         my $Str = shift;
 320         my $Retval = 1;
 321         # Henta fra "find_inv_utf8,v 1.1 2001/09/07 08:54:31 sunny" og
 322         # modifisert litt. FIXME: Klager ikke på overlange sekvenser og tegn i
 323         # UTF-16-surrogatområdet
 324         $Str =~ s/([\xFC-\xFD][\x80-\xBF][\x80-\xBF]
 325                    [\x80-\xBF][\x80-\xBF][\x80-\xBF])//gx;
 326         $Str =~ s/([\xF8-\xFB][\x80-\xBF][\x80-\xBF][\x80-\xBF][\x80-\xBF])//g;
 327         $Str =~ s/([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])//g;
 328         $Str =~ s/([\xE0-\xEF][\x80-\xBF][\x80-\xBF])//g;
 329         $Str =~ s/([\xC0-\xDF][\x80-\xBF])//g;
 330         $Retval = 0 if ($Str =~ /[\x80-\xFD]/);
 331         msg(3, "is_utf8() returnerer $Retval.");
 332         return $Retval;
 333 }
 334
 335 sub insert_file {
 336         my ($dbk_file, $file_name, $line_num, $time_str) = @_;
 337         local *LocFP;
 338         seek(dbkFP, 0, 0)
 339         || die("$0: $dbk_file: Klarte ikke å gå til begynnelsen av fila"
 340                . " i insert_file(): $!\n");
 341         my @Linjer = <dbkFP>;
 342         my @InsLinj = "<b>$time_str</b> -\n";
 343         open(LocFP, "<$file_name")
 344         || die("$0: $file_name: Kan ikke åpne fila for lesing: $!\n");
 345         push(@InsLinj, <LocFP>);
 346         push(@InsLinj, "\n") unless $time_not_found; # Denne likte jeg egentlig
 347                                                      # fantastisk dårlig, men
 348                                                      # hvem bruker vel å ha to
 349                                                      # LF’er på slutten av
 350                                                      # fila?
 351         for (@InsLinj) {
 352                 msg(3, "\$_ = \"$_\"");
 353                 if (!is_utf8($_)) {
 354                         warn("$0: Ugyldig UTF-8 funnet,"
 355                              . " behandler teksten som ISO-8859-1.\n");
 356                         my @Ny = ();
 357                         for my $Curr (@InsLinj) {
 358                                 msg(3, "FØR  : \$Curr = \"$Curr\"");
 359                                 $Curr =~ s/([\x80-\xFF])/widechar(ord($1))/ge;
 360                                 msg(3, "ETTER: \$Curr = \"$Curr\"");
 361                                 push(@Ny, $Curr);
 362                         }
 363                         @InsLinj = @Ny;
 364                         last;
 365                 }
 366         }
 367         splice(@Linjer, $line_num-1, 0, @InsLinj);
 368         close(LocFP);
 369         seek(dbkFP, 0, 0)
 370         || die("$0: $dbk_file: Klarte ikke å seeke til starten"
 371                . " i insert_file(): $!\n");
 372         truncate(dbkFP, 0)
 373         || die("$0: $dbk_file: Klarte ikke å trunce fila til 0: $!\n");
 374         msg(3, "scalar(\@Linjer): \"" . scalar(@Linjer) . "\".");
 375         foreach my $Curr (@Linjer) {
 376                 $Curr =~ s/&#(\d{1,10});/widechar($1)/ge;
 377                 $Curr =~ s/&#x([0-9a-f]{1,8});/widechar(hex($1))/gei;
 378                 print(dbkFP $Curr)
 379                 || warn("$0: $dbk_file: Knallkrise."
 380                         . " Feil under skriving til fila: $!\n");
 381         }
 382 }
 383
 384 sub print_version {
 385         # Print program version
 386         print("$progname $VERSION\n");
 387         return;
 388 }
 389
 390 sub usage {
 391         # Send the help message to stdout
 392         my $Retval = shift;
 393
 394         if ($Opt{'verbose'}) {
 395                 print("\n");
 396                 print_version();
 397         }
 398         print(<<"END");
 399
 400 Syntax: $progname [valg] [dag [måned [år]]] [HH:MM]
 401
 402 Options:
 403
 404   -b, --batch
 405     Batch mode, ikke start editor eller viewer.
 406   -f, --force
 407     Force, start dbk selv om lockdir eksisterer.
 408   -h, --help
 409     Show this help.
 410   -i x, --insert-file x
 411     Sett inn filen x istedenfor å bruke tastatur. Forventer -t eller
 412     klokkeslett.
 413   -q, --quiet
 414     Be more quiet. Can be repeated to increase silence.
 415   -t, --now
 416     Legg til klokkeslettet akkurat nå i fila og gå inn i editoren
 417   -v, --verbose
 418     Increase level of verbosity. Can be repeated.
 419   --version
 420     Print version information.
 421   -z, --zone
 422     Legg til tidssone til klokkeslett
 423
 424 Klokkeslettet kan spesifiseres hvor som helst, men må starte med
 425 formatet "HH:" der HH er to siffer.
 426
 427 Environment variables:
 428
 429   DBK_DIR
 430     Path to directory where files will be stored.
 431     Default: "$STD_DIR"
 432   DBK_VIEWER
 433     Specify HTML browser to use when viewing files.
 434     Default: "$STD_VIEWER"
 435
 436 END
 437         exit($Retval);
 438 }
 439
 440 sub msg {
 441         # Print a status message to stderr based on verbosity level
 442         my ($verbose_level, $Txt) = @_;
 443
 444         if ($Opt{'verbose'} >= $verbose_level) {
 445                 print(STDERR "$progname: $Txt\n");
 446         }
 447         return;
 448 }
 449
 450 sub widechar {
 451         # Konverterer en tegnverdi til UTF-8
 452         # Henta fra "h2u,v 1.5 2002/11/20 00:09:40 sunny".
 453         my $Val = shift;
 454         my $allow_invalid = 0;
 455
 456         if ($Val < 0x80) {
 457                 return sprintf("%c", $Val);
 458         } elsif ($Val < 0x800) {
 459                 return sprintf("%c%c", 0xC0 | ($Val >> 6),
 460                                        0x80 | ($Val & 0x3F));
 461         } elsif ($Val < 0x10000) {
 462                 unless ($allow_invalid) {
 463                         if (($Val >= 0xD800 && $Val <= 0xDFFF)
 464                             || ($Val eq 0xFFFE)
 465                             || ($Val eq 0xFFFF)) {
 466                                 $Val = 0xFFFD;
 467                         }
 468                 }
 469                 return sprintf("%c%c%c", 0xE0 |  ($Val >> 12),
 470                                          0x80 | (($Val >>  6) & 0x3F),
 471                                          0x80 |  ($Val        & 0x3F));
 472         } elsif ($Val < 0x200000) {
 473                 return sprintf("%c%c%c%c", 0xF0 |  ($Val >> 18),
 474                                            0x80 | (($Val >> 12) & 0x3F),
 475                                            0x80 | (($Val >>  6) & 0x3F),
 476                                            0x80 |  ($Val        & 0x3F));
 477         } elsif ($Val < 0x4000000) {
 478                 return sprintf("%c%c%c%c%c", 0xF8 |  ($Val >> 24),
 479                                              0x80 | (($Val >> 18) & 0x3F),
 480                                              0x80 | (($Val >> 12) & 0x3F),
 481                                              0x80 | (($Val >>  6) & 0x3F),
 482                                              0x80 | ( $Val        & 0x3F));
 483         } elsif ($Val < 0x80000000) {
 484                 return sprintf("%c%c%c%c%c%c", 0xFC |  ($Val >> 30),
 485                                                0x80 | (($Val >> 24) & 0x3F),
 486                                                0x80 | (($Val >> 18) & 0x3F),
 487                                                0x80 | (($Val >> 12) & 0x3F),
 488                                                0x80 | (($Val >>  6) & 0x3F),
 489                                                0x80 | ( $Val        & 0x3F));
 490         } else {
 491                 return widechar(0xFFFD);
 492         }
 493 }
 494
 495 __END__
 496
 497 # This program is free software; you can redistribute it and/or modify it under
 498 # the terms of the GNU General Public License as published by the Free Software
 499 # Foundation; either version 2 of the License, or (at your option) any later
 500 # version.
 501 #
 502 # This program is distributed in the hope that it will be useful, but WITHOUT
 503 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
 504 # FOR A PARTICULAR PURPOSE.
 505 # See the GNU General Public License for more details.
 506 #
 507 # You should have received a copy of the GNU General Public License along with
 508 # this program.
 509 # If not, see L<http://www.gnu.org/licenses/>.
 510
 511 # vim: set ts=8 sw=8 sts=8 noet fo+=w tw=79 fenc=UTF-8 :