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