martes, 18 de febrero de 2014

Tokens V2

Tokens: Programme to discover tokens, where there are not.

Now available at https://puszcza.gnu.org.ua/projects/tokens/
This is Version 2, for version 1, go here.

Synopsis:
use TokensV2;

sub printFile;
my @FORMAT = (
['<Message Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From>(?:<User FriendlyName=".*?"/>)+</From><To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style=".*?")?>.*?</Text></Message>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Message Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?">(<From>(?:<User FriendlyName=".*?"/>)+</From>)<To>(?:<User FriendlyName=".*?"/>)+</To><Text(?: Style="(.*?)")?>(.*?)</Text></Message>|;
    my $F = join '<br />', $f =~ m|<User FriendlyName="(.*?)"/>|g;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $F<br /><span style=\"$s\">$T</span></p>";
  }
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></Invitation>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><File>.*?</File><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><File>.*?</File><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
],
['<Invitation Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></Invitation>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Invitation Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></Invitation>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
],
['<InvitationResponse Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><From><User FriendlyName=".*?"/></From><Application>.*?</Application><Text(?: Style=".*?")?>.*?</Text></InvitationResponse>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<InvitationResponse Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><From><User FriendlyName="(.*?)"/></From><Application>.*?</Application><Text(?: Style="(.*?)")?>(.*?)</Text></InvitationResponse>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
],
['<Join Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Join>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Join Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Join>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
],
['<Leave Date=".*?" Time=".*?" DateTime=".*?" SessionID=".*?"><User FriendlyName=".*?"/><Text(?: Style=".*?")?>.*?</Text></Leave>',
  sub {
    my $fh = $_[1];
    my ($d, $t, $f, $s, $T) = $_[0] =~ m|<Leave Date="(.*?)" Time="(.*?)" DateTime=".*?" SessionID=".*?"><User FriendlyName="(.*?)"/><Text(?: Style="(.*?)")?>(.*?)</Text></Leave>|;
    print $fh "<p><font size=\"-2\">($d&nbsp;$t)</font> $f<br /><span style=\"$s\">$T</span></p>";
  }
]
);

sub printFile {
  return if @_==1;
  if (@_==2) {
    my $fh = $_[1];
    ${_[0]} =~ s/</&lt;/g;
    print $fh "<p>${_[0]}</p>\n";
    return;
  }
  # @_==5
  printFile @{$_[1]}, $_[4];
  my $coderef = $FORMAT[$_[3]][1];
  &$coderef($_[0], $_[4]);
  my $fh = $_[4];
  print $fh "\n";
  printFile @{$_[2]}, $_[4];
}

sub joinParseTree {
  return if @_==0;
  if (@_==1) {
    return ${_[0]};
  }
  # @_==4
  return joinParseTree(@{$_[1]}) . $_[0] . joinParseTree(@{$_[2]});
}

open my $fH, "<:encoding(utf8)", "tokens-processed.txt"; # H for HASH, not handle
my %HASH = map { /([^\s]*)/; $1 => undef } grep $_ ne "\n", <$fH>;
close $fH;
open $fH, ">>:encoding(utf8)", "tokens-processed.txt";
print $fH "----------bookmark----------\n";

local $/ = undef;

my $regex = join "\n", map $$_[0], @FORMAT;
while(glob "TXT/**") {
  print "$_\n";
  next if exists $HASH{$_};
  open my $fh, "<:encoding(utf8)", $_;
  my $text = <$fh>;
  my $oName = $_;
  $oName =~ s/TXT/HTML/;
  $oName =~ s/\.txt/.html/;
  my @parse_tree;
    eval {
            local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
            alarm 5;
      @parse_tree = parse($text, $regex);
            alarm 0;
    };
    if ($@) {
            die unless $@ eq "alarm\n";   # propagate unexpected errors
      # timed out
      print $fH "$_ timed out\n";
      next;
    }
  my $parse_text = joinParseTree @parse_tree;
  open $fhHTML, ">:encoding(utf8)", $oName;
  print $fhHTML <<ENDDOC
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">

<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
</head>
<body>
ENDDOC
;
  printFile @parse_tree, $fhHTML;
  $text =~ s/-( *)(?=-)/- \1/g;
  $text =~ s/(.{1,512})/<!-- \1 -->\n/g;
  print $fhHTML "
<!-- Original text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$text";
  $parse_text =~ s/-( *)(?=-)/- \1/g;
  $parse_text =~ s/(.{1,512})/<!-- \1 -->\n/g;
  print $fhHTML "
<!-- Parsed text (cut on every 512 Char, -( *)(?=-) sequences escaped as - \\1):-->
$parse_text
</body>
</html>";
  close $fhHTML;
  print $fH "$_\n";
}




TokensV2.pm file:

=pod
  Tokens: Programme to discover tokens, where there are not.

 Copyright 2013 Gabriel Czernikier



    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see .
=cut
use strict;
#package declarations
sub digest_single;
sub parse_programme;
sub printAll;

my @REGEX;
my @MASK;
my $long_tokens;
my @DIGEST_SINGLE;
my $literal_char_count;

sub digest_single {   # $target, $regex, $eaten_left_literal_chars, $eaten_right_literal_chars
  #return unless $_[1] ne '';
  #return if length $_[1] < 8;   # x>(.*?)<
  return unless ($_[2]+$_[3])/$literal_char_count<0.999999;
  return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
  pos($_[0]) = undef;
  goto VISITING unless $_[0] =~ /(${_[1]})/g;
  my $digit = 2;
  while( my $cg = eval '$'.$digit++ ) {
    my @suspicious_tokens = $cg =~ /$long_tokens/g;
    goto VISITING if @suspicious_tokens>=2;
  }
  my $pff = (pos $_[0]);
  my $pii = $pff - (length $1) if defined $pff;
  $DIGEST_SINGLE[$_[2]][$_[3]] = [$_[2], $_[3], $pii, $pff];
  return @{$DIGEST_SINGLE[$_[2]][$_[3]]};

  VISITING:
  my $re = $_[1];
  # strip off left shelter, also understood as walking righwards across the regex .+? stopping at a hopefuly serviceable string
  goto VISITING_2 unless $re =~ s/(.+?)(.\(\.\*\?\).|\([^.])/\2/;  # .+? is also the "shelter"
  my $increment_eaten_literal_chars = $+[1];
  $increment_eaten_literal_chars -= 5 if $1 =~ /\(\.\*\?\)/;   # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
  # expansions
  $re =~ s/^\(\?:(?:[^)]|\)[^?+*])+\)\*//;
  $re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\+/\1\(\?:\1\)\*/;
  $re =~ s/^\(\?:((?:[^)]|\)[^?+*])+)\)\?/\1/;
  my ($el, $er, $pi, $pf) = digest_single $_[0], $re, $_[2]+$increment_eaten_literal_chars, $_[3];

  VISITING_2:
  $re = $_[1];
  # strip off right shelter, also understood as walking leftwards across the regex .+? stopping at a hopefuly serviceable string
  goto SUBDIGEST unless $re =~ s/(.*(?:.\(\.\*\?\).|\)[?+*]))(.+?)$/\1/;  # .+? is the "shelter"

  $increment_eaten_literal_chars = $+[2] - $-[2];
  $increment_eaten_literal_chars -= 5 if $2 =~ /\(\.\*\?\)/;   # discount the single occurrence of non-literal chars: (.*?), left alone surrounding ""
  # expansions
  $re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\*$//;
  $re =~ s/\(\?:((?:[^)]|\)[^?+*])+)\)\+$/\(\?:\1\)\*\1/;
  $re =~ s/\(\?:(?:[^)]|\)[^?+*])+\)\?$//;
  my ($el2, $er2, $pi2, $pf2) = digest_single $_[0], $re, $_[2], $_[3]+$increment_eaten_literal_chars;

  SUBDIGEST:
  $DIGEST_SINGLE[$_[2]][$_[3]] = [$el, $er, $pi, $pf] if (defined $pi) && ($er+$el<=$er2+$el2 || !defined $pi2);
  return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
  $DIGEST_SINGLE[$_[2]][$_[3]] = [$el2, $er2, $pi2, $pf2] if (defined $pi2) && ($er2+$el2<$er+$el || !defined $pi);
  return @{$DIGEST_SINGLE[$_[2]][$_[3]]} if defined $DIGEST_SINGLE[$_[2]][$_[3]];
  $DIGEST_SINGLE[$_[2]][$_[3]] = [];
  return @{$DIGEST_SINGLE[$_[2]][$_[3]]};
}

sub digest_multiple {
  my $regex_num = 0;
  my $Pos_Ini;
  my $Eaten_Left;
  my $Eaten_Right;
  my $Pos_Fin;
  my $Regex_Num;

  my @DIGEST_MULTIPLE = ();
  for my $regex (@REGEX) {
    @DIGEST_SINGLE = undef;
    my @literal_chars = $regex =~ /[^.*(?:)+]/g;
    $literal_char_count = scalar @literal_chars;
    my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = digest_single $_[0], $regex, 0, 0;
    return $eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num if(($eaten_right+$eaten_left)/$literal_char_count<0.2);
    push @DIGEST_MULTIPLE, [$eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num] if defined $pos_ini && $pos_fin!=0;
    $regex_num++;
  }

  $regex_num = 0;
  while(@DIGEST_MULTIPLE!=0) {
    my ($eaten_left, $eaten_right, $pos_ini, $pos_fin) = @{shift @DIGEST_MULTIPLE};
    if($eaten_right+$eaten_left<$Eaten_Right+$Eaten_Left || !defined $Pos_Ini) {
      $Pos_Ini = $pos_ini;
      $Eaten_Left = $eaten_left;
      $Eaten_Right = $eaten_right;
      $Pos_Fin = $pos_fin;
      $Regex_Num = $regex_num;
    }
    $regex_num++;
  }
  return $Eaten_Left, $Eaten_Right, $Pos_Ini, $Pos_Fin, $Regex_Num if defined $Pos_Ini;
}

sub parse_programme {
  return if $_[0] eq '';
  return $_[0] if length $_[0] < 8; # <x>y</x>
  my ($eaten_left, $eaten_right, $pos_ini, $pos_fin, $regex_num) = digest_multiple($_[0]);
  if(not defined $pos_ini) {
    #my $oldfh = select;
    #select STDERR;
    #print "$ARGV[1], [ini-no-parseable]${target}[fin-no-parseable]\n";
    #select $oldfh;
    return $_[0];
  }
  my $mask_right = @MASK[$regex_num];
  $mask_right =~ s/.*(.{$eaten_right})/\1/;
  my $mask_left = @MASK[$regex_num];
  $mask_left =~ s/(.{$eaten_left}).*/\1/;
  my $match_length = $pos_fin-$pos_ini;
  my ($target_left,$match,$target_right) = $_[0] =~ /(.{$pos_ini})(.{$match_length})(.*)/;
  shift;  # discard unused argument
  return $mask_left.$match.$mask_right, +[parse_programme $target_left], +[parse_programme $target_right], $regex_num;
}

sub printAll {
  return if @_==0;
  if (@_==1) {
    print "[ini-nonparse]${_[0]}[fin-nonparse]\n";
    return;
  }
  printAll @{$_[1]};
  print "[ini-prod]${_[0]}[fin-prod]\n";
  printAll @{$_[2]};
}

sub parse {
  @REGEX = ();
  @MASK = ();
  my $target = shift;
  my $regex = shift;
  while($regex =~ /^(.+)$/mg) {
    my $_ = $1;
    my $other = $_;
    # strip out non-literal chars from MASK
    $other =~ s/\(\?:(.+?)\)\+/\1/g;
    $other =~ s/\(\?:(.+?)\)\?/\1/g;
    $other =~ s/\.\*\?//g;
    push @MASK, $other;
    # surround wildcards with capturing group for REGEX
    s/(\.\*\?)/\(\1\)/g;
    push @REGEX, $_;
  }

  $long_tokens = '\b' . join '\b|\b', grep length>=3,keys %{+{  map +($_=>undef), map /\w+/g, @REGEX  }};
  $long_tokens = $long_tokens . '\b';

  parse_programme $target;
}

1;

martes, 11 de febrero de 2014

Subir archivos a un sistema z/OS a través de TSO

La subida de archivos a Mainframe a través del lenguaje de TSO (entendido en dicho lenguaje como 'IND$FILE PUT'), cuando el destino no es un 'dataset' sino un 'member', no acepta los mismos parámetros que la bajada ('IND$FILE GET').
En particular, no se aceptan las opciones: LRECL(n), BLKSIZE(n), RECFM(x), and SPACE(n,[n1]) unit (Referencia: http://www3.rocketsoftware.com/bluezone/help/v51/en/bz/DISPLAY/IND$FILE/IND$FILE_Technical_Reference.htm).

El panel de upload/download del emulador de Windows (por ejemplo Terminal 3270) genera esas opciones por defecto, para configurar qué opciones se incluyen en el string del comando TSO, hay un menú: Edición -> Preferencias -> Transferir.
Ahí, hay que crear un nuevo tipo de transferencia, y quitar las opciones Formato de registro y Longitud de registro, las cuales corresponden con las opciones TSO
LRECL(n), RECFM(x). Otras opciones también se pueden configurar desde acá, ver la referencia más citada arriba

Los tipos de transferencia son settings predeterminados de opciones, que se apendean a la línea de comando TSO cuando son seleccionados (por ejemplo: si dentro del panel de download selecciono tipo de transferencia='text', al generarse la línea de comando TSO se apendean las opciones ASCII CRLF RECFM LRECL) .

Cuando la subida de archivos es hacia un dataset, todas las opciones de línea de comando son aceptadas, pudiendo por ende utilizar algún tipo de transferencia instalado por default en el software de subida de archivos.

Para detectar si el destino del upload es un dataset o un mienbro dentro de un dataset particionado:
Dataset: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET', siempre separado por (.)
Member: tienen la forma 'IND$FILE PUT HOST$.LIBRERIA.DATASET(MIEMBRO)', con paréntesis al rededor del miembro.