API tools faq
paste
Advertisement
Azuhmier

tags.pl

Azuhmier
Oct 11th, 2019 (edited)
834
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Perl 24.68 KB | None | 0 0
raw download clone embed print report
  1. #!/usr/bin/perl
  2. ##===============================================================================
  3. #
  4. #         FILE: tags.pl
  5. #
  6. #        USAGE: ./tags.pl
  7. #
  8. #  DESCRIPTION: Helps with story tagging and organization, maybe more.
  9. #
  10. #       AUTHOR: Azuhmier (aka taganon), azuhmier@gmail.com
  11. # ORGANIZATION: HMOFA
  12. #      VERSION: 1.0
  13. #      CREATED: September 2019
  14. #===============================================================================
  15. use strict;
  16. use warnings;
  17. use autodie;
  18. use Storable qw(dclone);
  19. use Data::Dumper;
  20. use List::MoreUtils 'uniq';
  21. use lib ($ENV{HOME}.'/.hmofa/lib/', $ENV{HOME}.'/Documents/hmofa/lib/');
  22. use Dir_Setup;
  23. use hmofa_dspt ':all';
  24. {
  25.   #==================================|| GLOBAL ||===================================#
  26.     # DIRECTORIES #{{{
  27.     my $MASTER      = $Dir_Setup::PATHS{MASTER};
  28.  
  29.     my $output_dir  = $Dir_Setup::PATHS{output_dir};
  30.     my $output_dir2 = $Dir_Setup::PATHS{output_dir_2};
  31.     my $target      = $Dir_Setup::PATHS{target_dir };
  32.     #}}}
  33.     # FILE PATHS #{{{
  34.     my $Catalog           = $MASTER.'/'.$Dir_Setup::PATHS{paste_dir}.$Dir_Setup::PATHS{source_file}; # Library
  35.     my $Copy_Catalog        = $target.'/'.$Dir_Setup::PATHS{output_file_copy}; #relative pathname to lib-copy
  36.     my $Kosher_Catalog   = $MASTER.'/'.$Dir_Setup::PATHS{paste_dir}.$Dir_Setup::PATHS{output_file_kosher};
  37.  
  38.     # goto_files/
  39.     my $tag_file        = 'tag_bin.txt';
  40.     my $name_file       = 'tag_names.txt';
  41.     my $ops_file        = 'ops.txt';
  42.     my $ops_names_file  = 'op_names.txt';
  43.     my $ops_group_file  = 'op_groups.txt';
  44.     #}}}
  45.     # GLOBAL VARS #{{{
  46.     my $fh; # FileHandle of tag catalog
  47.     my @fixed;
  48.     #}}}
  49.     # FORWARD DECLARATIONS #{{{
  50.     sub Lib_analy;
  51.     sub get_tags;
  52.     sub libfix;
  53.     #}}}
  54.  
  55.   #==================================|| MAIN ||===================================#
  56.   {
  57.       #-----| Catalog Modification |------{{{
  58.  
  59.         # Analysis of Catalog
  60.         open my $fh_Catalog, '<', $Catalog
  61.           or die "Cannot open '$Catalog' in read-write mode: $!";
  62.  
  63.           ( my $dspt_Catalog,
  64.             my $original ) =  Lib_analy($fh_Catalog, $output_dir);
  65.        
  66.         close $fh_Catalog
  67.           or die "Cannot close $Catalog: $!";
  68.  
  69.         # Get Tags
  70.         $dspt_Catalog = get_tags($dspt_Catalog, $tag_file, $name_file, 1, $output_dir);
  71.  
  72.         # Formating the Catalog
  73.         lib_fmt($original);
  74.  
  75.       #}}}
  76.       #-----| Catalog Copy Modification |------{{{
  77.         # Clean up the Library
  78.         @fixed = libfix($fh, $Copy_Catalog, $dspt_Catalog, $Catalog);
  79.  
  80.         # Analysis of Catalog Copy
  81.         open my $fh_Copy_Catalog, '<', $Copy_Catalog
  82.           or die "Cannot open '$Copy_Catalog' in read-write mode: $!";
  83.          
  84.           ( my $dspt_Copy_Catalog,
  85.             my $modified ) =  Lib_analy($fh_Copy_Catalog, $output_dir2);
  86.        
  87.         close $fh_Copy_Catalog
  88.           or die "Cannot close $Copy_Catalog: $!";
  89.  
  90.         $dspt_Copy_Catalog =  get_tags($dspt_Copy_Catalog, $tag_file, $name_file, 1, $output_dir2);
  91.  
  92.       #}}}
  93.     #-----| Check |-----{{{
  94.     #  my @a = @{${$dspt->{tags}{analy}{tag_bin}}[0]};
  95.     #  my @b = @{${$dspt2->{tags}{analy}{tag_bin}}[0]};
  96.  
  97.     #  my @mine;
  98.     #  NUM: for my $duck (@b)
  99.     #  {
  100.     #    for my $TAG (@a)
  101.     #    {
  102.     #      if ($duck eq $TAG)
  103.     #      {
  104.     #        shift @a;
  105.     #        next NUM;
  106.     #      }
  107.     #    }
  108.     #      push @mine, $duck;
  109.     #  }
  110.     #  print "$_\n" for @mine;
  111.     #  print "*******************\n";
  112.  
  113.     #  my @mine2;
  114.     #  NUM: for my $duck (@a)
  115.     #  {
  116.     #    for my $TAG (@b)
  117.     #    {
  118.     #      if ($duck eq $TAG)
  119.     #      {
  120.     #        shift @b;
  121.     #        next NUM;
  122.     #      }
  123.     #    }
  124.     #      push @mine2, $duck;
  125.     #  }
  126.     #  print "$_\n" for @mine2;
  127.     #}}}
  128.       #-----| STDOUT |-----{{{
  129.       # find length of longest key
  130.       my $ub = 0;
  131.         for my $key (keys %$dspt_Catalog) {
  132.           if (length $key > $ub) {
  133.             $ub = length $key
  134.           }
  135.         }
  136.       my $ub2 = 0;
  137.         for my $key (keys %$dspt_Copy_Catalog) {
  138.           if (length scalar @{$dspt_Copy_Catalog->{$key}{LN}} > $ub2) {
  139.             $ub2 = length scalar @{$dspt_Copy_Catalog->{$key}{LN}}
  140.           }
  141.       }
  142.  
  143.       # print element number of each key
  144.       for my $key (sort keys %$dspt_Catalog) {
  145.         my $bin =  scalar @{$dspt_Catalog->{$key}{LN}};
  146.         my $bin2 =  scalar @{$dspt_Copy_Catalog->{$key}{LN}};
  147.         printf "$key"." " x ( 2 + ($ub - length $key))."%s\n", '| '.$bin.' '.
  148.                " " x ( $ub2 - length $bin2 ).'| '.$bin2;
  149.       }
  150.       #}}}
  151.   }
  152.  
  153.   #==================================|| SUBROUTINES ||===================================#
  154.     #-----|| Lib_analy() ||-------{{{
  155.     # Lib_analy:  
  156.  
  157.       sub Lib_analy {
  158.         # FUN ARGS {{{
  159.         my $fh = shift; # filehandle
  160.         my $output_dir_in = shift;
  161.         #}}}
  162.         # FUN VARS #{{{
  163.  
  164.         my @ORIGINAL;
  165.         my $dspt = gen_dspt();
  166.  
  167.         #}}}
  168.  
  169.         my $num_of_keys  = scalar keys %$dspt; # number of keys
  170.  
  171.         #-----| BLOCK: get lines |-----{{{
  172.           {
  173.  
  174.             while (my $line = <$fh>) {
  175.             # WHILE: line at file handle pointer
  176.  
  177.               my $count; # number regexp match fails
  178.               $line =~ s/
  179. //g; #removes carriage returns
  180.  
  181.               for my $key (keys %$dspt) {
  182.               # FOR: every first level key in the dispatch table
  183.  
  184.                 my $path = \$dspt->{$key}{file_path};
  185.                 my $key_reff = $dspt->{$key};
  186.                 $$path = $output_dir_in.'/'.$key.'.txt';
  187.  
  188.                 if ($key_reff->{re} && $line =~ /$key_reff->{re}/) {
  189.  
  190.                   push  @{$key_reff->{LN}}, $.;
  191.                   push  @{$key_reff->{match}}, $line;
  192.  
  193.                     if ($key_reff->{group1}) {push @{$key_reff->{group1}} , $1;}
  194.                     if ($key_reff->{group2}) {push @{$key_reff->{group2}} , $2;}
  195.                     if ($key_reff->{group3}) {push @{$key_reff->{group3}} , $3;}
  196.                     if ($key_reff->{group4}) {push @{$key_reff->{group4}} , $4;}
  197.                     if ($key_reff->{group5}) {push @{$key_reff->{group5}} , $5;}
  198.                     if ($key_reff->{group6}) {push @{$key_reff->{group6}} , $6;}
  199.                 }
  200.  
  201.                 else {  
  202.                 # ELSE: no matches if count = the number of keys
  203.  
  204.                   ++$count;
  205.  
  206.                 }
  207.               }
  208.  
  209.               if ($flag && $num_of_keys == $count) {
  210.  
  211.                 push  @{$dspt->{unkown}{LN}}, $.;
  212.                 push  @{$dspt->{unkown}{match}}, $line;
  213.                 $flag = 0;
  214.  
  215.               }
  216.  
  217.               push @ORIGINAL, $line;
  218.  
  219.             }
  220.           }
  221.  
  222.         #}}}
  223.  
  224.         return $dspt, \@ORIGINAL;
  225.       }
  226.  
  227.       #}}}
  228.     #-----|| get_tags ||-------{{{
  229.       sub get_tags {
  230.  
  231.         # FUN ARGS #{{{
  232.  
  233.           my $dspt = shift;
  234.           my $tag_file = shift;
  235.           my $name_file = shift;
  236.           my $output = shift;
  237.           my $output_dir_in = shift;
  238.  
  239.         #}}}
  240.         # FUN VARS #{{{
  241.  
  242.           my $tags_raw       = ${$dspt->{tags}{analy}{raw}}[0];
  243.           my $tags           = ${$dspt->{tags}{analy}{tag_bin}}[0];
  244.           my $tag_lnums      = ${$dspt->{tags}{analy}{tag_bin}}[1];
  245.           my $tag_names      = ${$dspt->{tags}{analy}{tag_names}}[0];
  246.           my $tag_name_lnums = ${$dspt->{tags}{analy}{tag_names}}[1];
  247.  
  248.           my $ops_raw              = ${$dspt->{tags}{analy}{raw_ops}}[0]; # raw operator
  249.           my $ops_raw_lnums        = ${$dspt->{tags}{analy}{raw_ops}}[1];
  250.           my $ops                  = ${$dspt->{tags}{analy}{ops_bin}}[0];
  251.           my $ops_lnums            = ${$dspt->{tags}{analy}{ops_bin}}[1];
  252.           my $ops_names            = ${$dspt->{tags}{analy}{ops_names}}[0];
  253.           my $ops_name_lnums       = ${$dspt->{tags}{analy}{ops_names}}[1];
  254.  
  255.         #}}}
  256.         #-----| GET RAW TAGS FROM TAGLINES |-----{{{
  257.  
  258.           for my $tagln_LN ( @{$dspt->{tags}{LN}} ) {
  259.           # FOR: tagline line numbers
  260.  
  261.             for my $key ( grep {m/group/} keys %{$dspt->{tags}} ) {
  262.             # FOR:  non-operater tag groups
  263.  
  264.               if ($key =~ /group[^356]/) {
  265.  
  266.                 my $tag_group = shift @{$dspt->{tags}{$key}};
  267.                 # get tag group even if UNDEF
  268.  
  269.                 if ($tag_group) {
  270.  
  271.                   while ( $tag_group =~ /([^$d]+)/g ) {
  272.                   # WHILE: current tag group contains characters
  273.                   # that are not the delemiter: $d
  274.  
  275.                     push( @$tags_raw, $1 );        
  276.                     # push captured group onto the RAW TAGS array
  277.                     push( @$tag_lnums, $tagln_LN );
  278.                     # push current tagline line number onto the...
  279.                     # ...TAG LINE NUMBERS array.
  280.                   }
  281.                 }
  282.               }
  283.  
  284.               else {
  285.  
  286.                 my $op_group = shift @{$dspt->{tags}{$key}}; # get tag group even if UNDEF
  287.                 if ($op_group) {
  288.  
  289.                   while ( $op_group =~ /(.+)/g ) {
  290.                   # WHILE: current tag group contains characters that
  291.                   # are not the delemiter: $d
  292.  
  293.                     my $var = $op_group;
  294.                     push( @$ops_raw, $1 );    
  295.                     # push captured group onto the RAW TAGS array
  296.                     push( @$ops_raw_lnums, $tagln_LN );
  297.                     # push current tagline line number onto the...
  298.                     while ( $var =~ /([^\s])\1*/g ) {
  299.  
  300.                       push( @$ops, $& );        
  301.                       # push captured group onto the RAW TAGS array
  302.                       push( @$ops_lnums, $tagln_LN );
  303.                       # push current tagline line number onto the...
  304.                     }
  305.                   }
  306.                 }
  307.               }
  308.             }
  309.           }
  310.  
  311.           #}}}
  312.         #-----| GETTING OP NAMES |-----{{{
  313.  
  314.           my @idx = sort {uc($$ops_raw[$a]) cmp uc($$ops_raw[$b])} 0 .. $#$ops_raw;
  315.           @$ops_raw      = @$ops_raw[@idx];
  316.           @$ops_raw_lnums = @$ops_raw_lnums[@idx];
  317.  
  318.           @idx = sort {uc($$ops[$a]) cmp uc($$ops[$b])} 0 .. $#$ops;
  319.           @$ops      = @$ops[@idx];
  320.           @$ops_lnums = @$ops_lnums[@idx];
  321.           #}}}
  322.         #-----| GETTING OP NAMES |-----{{{
  323.  
  324.           @$ops_names = uniq(@$ops);
  325.           #}}}
  326.         #-----| GET TAG NAME LINE NUMBERS IN THE TAG_BIN ARRAY |-----{{{
  327.  
  328.           my @ops_names_copy = @$ops_names; # make copy of tagnames
  329.           my $count = 0;                    # set count that will act as the line numbers
  330.  
  331.           for my $op ( @$ops ) {
  332.           # FOR: every tag in the tag bin
  333.  
  334.             ++$count;
  335.  
  336.             if ( $ops_names_copy[0] && $op =~ /\Q$ops_names_copy[0]\E/ ) {
  337.             # IF: current tag matches the current tag name              
  338.  
  339.               push( @$ops_name_lnums, $count );
  340.               # push current count to tag_name line numbers
  341.  
  342.               shift @ops_names_copy;            # get next tag name
  343.             }
  344.           }
  345.           #}}}
  346.         #-----| CLEANING TAGS |-----{{{
  347.  
  348.           for my $line ( @$tags_raw ) {
  349.           # FOR: raw tags
  350.          
  351.             $line =~ s/^\s*([^\s])/$1/g; # removes spaces before tag
  352.             $line =~ s/([^\s])\s*$/$1/g; # removes spaces after tag
  353.             $line =~ s/\?//g;            # removes "?" from tag
  354.             push @$tags, $line;          # push cleaned tag to tag_bin array
  355.           }
  356.           #}}}
  357.         #-----| SORTING TAGS: CASE INSENSITIVE |-----{{{
  358.  
  359.           @idx = sort {uc($$tags[$a]) cmp uc($$tags[$b])} 0 .. $#$tags;
  360.           @$tags      = @$tags[@idx];
  361.           @$tag_lnums = @$tag_lnums[@idx];
  362.           #}}}
  363.         #-----| GET TAG NAMES |-----{{{
  364.  
  365.           # get tag names and their linenumbers
  366.           @$tag_names = uniq( sort {uc($a) cmp uc($b)} @$tags );
  367.           #}}}
  368.         #-----| GET TAG NAME LINE NUMBERS IN THE TAG_BIN ARRAY |-----{{{
  369.  
  370.           my @tag_names_copy = @$tag_names; # make copy of tagnames
  371.           $count = 0;                    # set count that will act as the line numbers
  372.  
  373.           # FOR: every tag in the tag bin
  374.           for my $tag ( @$tags ) {
  375.  
  376.             ++$count;
  377.  
  378.             if ( $tag_names_copy[0] && $tag =~ /\Q$tag_names_copy[0]\E/ ) {
  379.             # IF: current tag matches the current tag name
  380.  
  381.               push( @$tag_name_lnums, $count );
  382.               # push current count to tag_name line numbers
  383.               shift @tag_names_copy;            # get next tag name
  384.  
  385.             }
  386.           }
  387.  
  388.           #}}}
  389.         #-----| OUTPUT FILES |-----{{{
  390.  
  391.           if ( $output ) {
  392.           # IF: output argument was provided and it's true
  393.  
  394.             # output fmtd_tgln
  395.             open $fh, '>', $output_dir_in.'/'.$name_file;
  396.               print $fh shift @$tag_name_lnums, " $_\n" for @$tag_names;
  397.             close $fh;
  398.  
  399.             open $fh, '>', $output_dir_in.'/'.'tags_only.txt';
  400.               print $fh "$_\n" for @$tag_names;
  401.             close $fh;
  402.  
  403.             # output tags
  404.             open $fh, '>', $output_dir_in.'/'.$tag_file;
  405.               print $fh shift @$tag_lnums ," $_\n" for @$tags;
  406.             close $fh;
  407.  
  408.             open $fh, '>', $output_dir_in.'/'.$ops_names_file;
  409.               print $fh shift @$ops_name_lnums, " $_\n" for @$ops_names;
  410.             close $fh;
  411.  
  412.             open $fh, '>', $output_dir_in.'/'.$ops_file;
  413.               print $fh shift @$ops_lnums," $_\n" for @$ops;
  414.             close $fh;
  415.  
  416.             open $fh, '>', $output_dir_in.'/'.$ops_group_file;
  417.               print $fh shift @$ops_raw_lnums ," $_\n" for @$ops_raw;
  418.             close $fh;
  419.  
  420.             open $fh, '>', $output_dir_in.'/url_only.txt';
  421.               my @line = @{$dspt->{url}{match}};
  422.               print $fh grep { /^https:\/\/pastebin.com\/\w[^\/]/ } @line;
  423.             close $fh;
  424.  
  425.             for my $key ( keys %$dspt ) {
  426.             # FOR: every key of dispatch table
  427.  
  428.               my $file_path =  $dspt->{$key}{file_path};
  429.               open $fh, '>', $file_path;
  430.                 my @line = @{$dspt->{$key}{LN}};
  431.                 print $fh shift @line," $_" for @{$dspt->{$key}{match}};
  432.               close $fh;
  433.  
  434.             }
  435.           }
  436.  
  437.           else {
  438.  
  439.           }
  440.  
  441.           #}}}
  442.  
  443.         return $dspt;
  444.       }
  445.       #}}}
  446.     #-----|| libfix() ||-------{{{
  447.       sub libfix {
  448.         # FUN ARGS #{{{
  449.         my $fh        = shift;  # FileHandle brah
  450.         my $Copy_Catalog  = shift;  # Path to Library Copy
  451.         my $dspt      = shift;  # Dispatch Table
  452.         my $fname_in     = shift;  # Path to Library
  453.         #}}}
  454.         # FUN VARS #{{{
  455.         my @COPY;  # Array to Store Copy of Library
  456.         my @FIXED; # Array to Store the Modified Copy of the Library
  457.         #}}}
  458.         #-----| MAKE ARRAY COPY OF LIBRARY |-----{{{
  459.         open($fh, '<', $fname_in); # Open Library for Reading
  460.  
  461.           # WHILE: a Line Exist at the FileHandle Pointer
  462.           while (my $line = <$fh>)
  463.           {
  464.             push @COPY, $line; # Push current line to @COPY
  465.           }
  466.  
  467.         close $fh;
  468.         #}}}
  469.         #-----| LIBRARY COPY FILE OPENING/CREATION |-----{{{
  470.         open($fh, '>', $Copy_Catalog); # Open or Create File for Library Copy
  471.         close $fh;
  472.         #}}}
  473.         #-----| WRITE TO LIB_COPY FILE AND MODIFY IT |-----{{{
  474.         open($fh, '+<', $Copy_Catalog); # Open Library Copy for Read/Write
  475.           print $fh @COPY;          # Write @COPY to Library Copy File
  476.           truncate $fh, tell($fh);  # Truncate File at Current Postion of the FileHandle...
  477.                                     # ... Pointer
  478.         #}}}
  479.           #-----| READ FILE AND MAKE FIXES TO LINES |-----{{{
  480.           seek $fh,0,0; # Put FileHandle Pointer at BOF
  481.  
  482.           # WHILE: a Line Exist at the FileHandle Pointer
  483.           while (my $line = <$fh>)
  484.           {
  485.             # UNDER A TITLE
  486.             # IF: Current Line is Under a Title
  487.             if ($flag)
  488.             {
  489.               # TAGLINE
  490.               # IF: Current Line is a TagLine
  491.               if ($line =~ /$dspt->{tags}{re}/) # Also sets Regexp Capture Groups
  492.               {
  493.                 # Regexp Capture  Groups:
  494.                   # [atag][btag]$3 | COMPLETE
  495.                   # [halftag]$5    | INCOMPLETE
  496.                   # $6             | INCOMPLETE
  497.  
  498.                 #-----| FIX INCOMPLETE TAGS |-----{{{
  499.                 my $atag = \$1;          # Anthro Tags reff
  500.                 my $btag = \$2;          # Story Tags reff
  501.                 my $halftag = \$4;       # HalfTag reff
  502.                 my @ops = (\$3,\$5,\$6); # Operators reff
  503.                 # HALFTAG
  504.                 # IF: Current Line is HalfTag
  505.                 if ($kind eq "half")
  506.                 {
  507.                    $line =~ s/.*/\[\]$&/; # Insert Single Tag Bracket
  508.                 }
  509.  
  510.                 # Only Operater(s)
  511.                 # ELSIF: Current Line only cosists of Operators
  512.                 elsif (${$ops[2]})
  513.                 {
  514.                    $line =~ s/.*/\[\]\[\]$&/; # Insert Empty Tag Brackets
  515.                 }
  516.                 #}}}
  517.                 #-----| TAGLINE CLEANING |-----{{{
  518.                 $line =~ /$dspt->{tags}{re}/; # Reset Capture Groups Now That...
  519.                                               # ... All Taglines are Complete
  520.  
  521.                 $line =~ s/$d+\s*($d)/$1/g;              # Remove extra Commas to the Left
  522.                 $line =~ s/($d)\s*$d+/$1/g;              # Remove extra Commas to the Right
  523.                 $line =~ s/\s*(\[)\s*/$1/g;              # Remove extra Spaces around Left Brace
  524.                 $line =~ s/\s*(\])[ ]*([^ ])[ ]*/$1$2/g; # Remove extra Spaces around Right Brace
  525.                 $line =~ s/$d*(\[)$d/$1/g;               # Remove extra Commas around Left Brace
  526.                 $line =~ s/$d*(\])$d*/$1/g;              # Remove extra Commas around Right Brace
  527.                 $line =~ s/($d\s)\s*/$1/g;               # Remove extra Spaces Right of Comma
  528.                 $line =~ s/\s*($d)/$1/g;                 # Remove extra Spaces Left of Comma
  529.                 $line =~ s/($d)([^ ])/$1 $2/g;           # IF no space after comma, add one
  530.                 $line =~ s/\s*(\s)\s*/$1/g;              # Remove Extra Spaces
  531.                 #}}}
  532.                 #-----| DUPLICATE TAGS |-----{{{
  533.                 $line =~ /$dspt->{tags}{re}/; # reset match variables now that...
  534.                 my @past_matches = '';
  535.                 my $duplicate_found = 0;
  536.                 my @dupe;
  537.                 while ($line =~ /[^\[\],\n]+/g)
  538.                 {
  539.                   my $match = $&;
  540.                   $match =~ s/^\s//;
  541.  
  542.                   for my $ele (uniq(@past_matches))
  543.                   {
  544.                     if ($ele eq $match)
  545.                     {
  546.                       $duplicate_found=1;
  547.                       push @dupe, $match;
  548.                     }
  549.                     else
  550.                     {
  551.                       $duplicate_found=0;
  552.                     }
  553.                   }
  554.                   push @past_matches, $match;
  555.                 }
  556.                 no warnings 'uninitialized';
  557.                 for (@dupe)
  558.                 {
  559.                  $line =~ s/(?<!\w)\s$_\?*$d|(\[)$_\?*(\])|$d\s$_\?*(\])|(\[)$_$d\s/$1$2$3$4/;
  560.                 }
  561.                 use warnings;
  562.                 #}}}
  563.                #-----| DUPLICATE OPS |-----{{{
  564.                $line =~ /$dspt->{tags}{re}/; # reset match variables now that...
  565.                @past_matches = '';
  566.                $duplicate_found = 0;
  567.                @dupe =();
  568.                $line =~ /\]\[.*\]\K[^\]\[]+/;
  569.                my $OPS = $&;
  570.  
  571.                while ($OPS =~ /./g)
  572.                {
  573.                  my $match = $&;
  574.                  for my $ele (uniq(@past_matches))
  575.                  {
  576.                    if ($ele eq $match)
  577.                    {
  578.                      $duplicate_found=1;
  579.                      push @dupe, $match;
  580.                    }
  581.                    else
  582.                    {
  583.                      $duplicate_found=0;
  584.                    }
  585.                  }
  586.                  push @past_matches, $match;
  587.                }
  588.                for (@dupe)
  589.                {
  590.                 $OPS =~ s/\Q$_\E//;
  591.  
  592.                 $line =~ s/\][^\]\[]+/\]$OPS/;
  593.                }#}}}
  594.                 #-----| SUBSTITUTING OPERATORS |-----{{{
  595.                 $line =~ /$dspt->{tags}{re}/; # reset match variables now that...
  596.                                               # ...tagline in complete
  597.                 my %special =  %{$dspt->{tags}{special}};
  598.                 my %tag_subs = %{$special{tag_subs}};
  599.                 my %OPS = %{$special{ops}};
  600.                 for my $key (keys %OPS)
  601.                 {
  602.                   my $ARRAY = $OPS{$key};
  603.                   my $NEW = @$ARRAY[1];
  604.                   my $op = @$ARRAY[0];
  605.                   my $old_list = @$ARRAY[2];
  606.                   if ($line =~ /\].*\Q$op\E/)
  607.                   {
  608.                     $line =~ s/\Q$op\E//g; # REMOVE $
  609.                     #-----| CREATE OLD |-----{{{
  610.                     for my $OLD (@$old_list)
  611.                     {
  612.                       my $EXPR = '';
  613.                       my $COUNT = 0;
  614.                       my $LEN =  scalar @{$tag_subs{full_sub}};
  615.  
  616.                       #-----| CREATE REGEXP |-----#
  617.                       for my $string (@{$tag_subs{full_sub}})
  618.                       {
  619.                         $COUNT++;
  620.                         $EXPR .= $string;
  621.                         if ($COUNT > $LEN)
  622.                         {
  623.                           next;
  624.                         }
  625.                         $EXPR .=$OLD;
  626.                       }
  627.                       my $regexp = qr/$EXPR/;
  628.                       $line =~ s/(?<!\w)\s$OLD\?*$d|(\[)$OLD\?*(\])|$d\s$OLD\?*(\])|(\[)$OLD$d\s/$1$2$3$4/ig;
  629.                     }
  630.                     #}}}
  631.  
  632.                     #-----| INSERT NEW |-----#
  633.                     $line =~ /$dspt->{tags}{re}/;
  634.                     # IF:
  635.                     if (!$$btag)
  636.                     {
  637.                       $line =~ s/$regexp{tag_sub}/$&$NEW/;
  638.                     }
  639.                     # ELSE
  640.                     else
  641.                     {
  642.                       $line =~ s/$regexp{tag_sub}/$&$NEW$d /;
  643.                     }
  644.                   }
  645.                 }
  646.               }
  647.               #}}}
  648.               #-----| MISSING TAGLINES |-----{{{
  649.               # URL
  650.               # ELSIF: current line matches url regexp
  651.               elsif ($line =~ /$dspt->{url}{re}/)
  652.               {
  653.                 $line =~ s/$dspt->{url}{re}/\[\]\[\]\n$&/;
  654.               }
  655.               # UNKOWN
  656.               # ELSE: currlent line doesn't follow any regexp put forth
  657.               else
  658.               {
  659.                 $flag=0; # set flag to zero to let program know that it is done...
  660.                          # ... fixing line that was under title for there is no regexp...
  661.                          # ... embedded code for unkown
  662.               }
  663.               #}}}
  664.  
  665.             }
  666.  
  667.             #-----| TITLE FINDING AND FLAGGING |-----{{{
  668.             # TITLE
  669.             # ELSIF: current line matches title regexp
  670.             elsif ($line =~ /$dspt->{title}{re}/)
  671.             {
  672.             }
  673.             push @FIXED, $line; # push fixed line to the fixed array
  674.             #}}}
  675.  
  676.           }# END of WHILE
  677.           #}}}
  678.           #-----| WRITE FIXES BACK |-----{{{
  679.           seek $fh, 0, 0;
  680.  
  681.           # FOR: every $line of the fixed array
  682.           for my $line  (@FIXED)
  683.           {
  684.             $line =~ s/
  685. //g; # remove carriage returns
  686.             print $fh $line;
  687.           }
  688.           truncate $fh, tell($fh);
  689.  
  690.         close $fh;
  691.  
  692.         return @FIXED;
  693.         #}}}
  694.       };
  695.  
  696.       #}}}
  697.     #-----|| lib_fmt() ||-------{{{
  698.       sub lib_fmt {
  699.         my $lib_array_ref = shift;
  700.         my @lib_array = @$lib_array_ref;
  701.         my @fmt_lib;
  702.  
  703.         # Master | Julia   | Markdown
  704.         # By     | by\s    | ##
  705.         # >title | "title" | [title](url)
  706.         # #      | #       | >
  707.         # ,      | \s      | \s
  708.         #        | ;;      | ;``;
  709.  
  710.         for my $line (@lib_array) {
  711.  
  712.           if ($line =~ /^>/) {
  713.           # If: Title
  714.  
  715.             $line =~ s/>(.*)/"$1"/;
  716.             $line =~ s/\s+(")/$1/;
  717.  
  718.           }
  719.  
  720.           elsif ($line =~ /^~/) {
  721.           # ELSIf: Dscr
  722.             $line =~ s/~(.*)/#$1/;
  723.           }
  724.  
  725.           # IF: Author
  726.           elsif ($line =~ /^By/) {
  727.             $line =~ s/By(.*)/by$1/;
  728.  
  729.           }
  730.  
  731.           push @fmt_lib, $line;
  732.  
  733.         }
  734.  
  735.         open (my $fh, '>', $Kosher_Catalog);
  736.           print $fh @fmt_lib;
  737.         close $fh;
  738.       }
  739.  
  740.       #}}}
  741. }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!