view release on metacpan or  search on metacpan

lib/Dita/GB/Standard.pm  view on Meta::CPAN

#!/usr/bin/perl -I/home/phil/perl/cpan/DataTableText/lib/
#-------------------------------------------------------------------------------
# The Gearhart-Brenan Dita Topic Naming Standard
# Philip R Brenan at gmail dot com, Appa Apps Ltd Inc., 2019
#-------------------------------------------------------------------------------
# podDocumentation
# gbBinaryStandardFileName produces different results when given the file name versus the file content - it should be the same
package Dita::GB::Standard;
our $VERSION = 20201030;
require v5.16;
use warnings FATAL => qw(all);
use strict;
use Carp qw(confess);
use Data::Dump qw(dump);
use Data::Table::Text qw(:all);
use utf8;

sub useWords{0}                                                                 #r Use word representation of md5 sum if true

# Each word is 5 characters long so we can gain 5 bits per word using capitalization. There are 2177 words below or 11 bits - enough room to reach 16 bits per word with the 5 extra from capitalization.
my @words = qw(aback abate abbey abhor abide abort about above abuse abyss acorn acrid actor acute adage adapt adept admit adobe adopt adore adorn adult affix after again agent agile aging agony agree ahead aisle alarm album aleck alert algae alias a...

!useWords or @words > 2**11 or confess "Not enough words";

sub hex4ToBits($)                                                               #P Represent 4 hex digits as (1, 1, 1, 1, 1, 12) bits
 {my ($h) = @_;
  my $n   = hex($h);
  my $n11 = $n % 2**11;
  my $n12 = ($n>>11) % 2;
  my $n13 = ($n>>12) % 2;
  my $n14 = ($n>>13) % 2;
  my $n15 = ($n>>14) % 2;
  my $n16 = ($n>>15) % 2;
 ($n16, $n15, $n14, $n13, $n12, $n11);
 }

sub hexAsWords($)                                                               #P Given a hex string represent it as words at a rate of 16 bits per word
 {my ($hex) = @_;

  my $d     = length($hex) % 4;
     $hex  .= '0' x (4-$d) if $d;

  my @w;

  for my $p(1..length($hex) / 4)                                                # Each block of hex representing 16 bits
   {my ($a, $b, $c, $d, $e, $r) = hex4ToBits(substr($hex, 4*($p-1), 4));
    my $w = $words[$r];
       $w =                  uc(substr($w, 0, 1)).substr($w, 1) if $a;
       $w = substr($w, 0, 1).uc(substr($w, 1, 1)).substr($w, 2) if $b;
       $w = substr($w, 0, 2).uc(substr($w, 2, 1)).substr($w, 3) if $c;
       $w = substr($w, 0, 3).uc(substr($w, 3, 1)).substr($w, 4) if $d;
       $w = substr($w, 0, 4).uc(substr($w, 4, 1)).substr($w, 5) if $e;
    push @w, $w;
   }

  join '_', @w;
 }

#D1 Make and manage utf8 files                                                  # Make and manage files that conform to the L<GBStandard> and are coded in utf8.

sub gbStandardFileName($$%)                                                     #E Return the L<GBStandard> file name given the content and extension of a proposed file.
 {my ($content, $extension, %options) = @_;                                     # Content, extension, options
  defined($content) or confess "Content must be defined";
  $content     =~ s(\s*xtr[cf]="[^"]*") ()gs;                                   # Suppress xtrc|f attributes as we use them to hold file names and line numbers during a conversion but they are not germane to the final result and thus prevent files fr...

  $extension && ($extension =~ m(\A\S{2,}\Z)s) or
    confess "Extension must be non blank and at least two characters long";
  my $name = $options{g} || nameFromStringRestrictedToTitle($content, %options);# Human readable component either as supplied in exceptional cases, or ideally, as taken from the title tag according to the prescription of the Monroe Title Method.
  my $md5  = $options{md5} // stringMd5Sum($content);                           # Md5 sum either as supplied or computed

  fpe($name.q(_).(&useWords ? hexAsWords($md5) : $md5),                         # Add extension
      fe($extension)||$extension);                                              # fe returns blank given an extension name without a .
 }

sub gbStandardCompanionFileName($)                                              #E Return the name of the L<Companion File> given a file whose name complies with the L<GBStandard>.
 {my ($file) = @_;                                                              # L<GBStandard> file name
  setFileExtension($file);                                                      # Remove extension to get companion file name
 }

sub gbStandardCompanionFileContent($)                                           #E Return the content of the L<Companion File> given a file whose name complies with the L<GBStandard>.
 {my ($file) = @_;                                                              # L<GBStandard> file name