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