diff --git a/lib/snippets.pl b/lib/snippets.pl new file mode 100755 --- /dev/null +++ b/lib/snippets.pl @@ -0,0 +1,8839 @@ +: +#!/usr/bin/perl -w +# ||<-snip->|| start +# @hs@snippets - snippets administration tool@he@ +# +# usage: snippets [OPTIONS] [COMMAND]@rb@ +# snh => snippets --help +# snl => snippets --list [name-rx] +# sni => snippets --as-includes +# --list [name-rx] +# sng => --grep [grep-opts] +# +# snc => snippets --cat [name-rx] | - [temp-snippet] +# snr => snippets --replace --process +# --cat [name-rx] +# snn => snippets --new [filename [name]] +# +# sns => snippets --store [name] [text|file|url] +# sna => snippets --append [name] [text|file|url] +# +# snw => snippets --work [work(1) args] +# @contents@ +# @s@COMMON OPTIONS FOR ALL COMMANDS@eb@ +# --debug show debug messages +# -q, --quiet suppress status messages. +# -d, --dir directory set SNIPS_DIR to DIRETORY and prepend +# it to SNIPS_PATH. +# --accept-cat ACCEPT-RX accept categories matching RX. +# -i, --ignore-cat IGNORE-RX ignore categories matching RX. +# -m, --mode MODE setup parameters according to MODE. +# -t, --title [TITLE] set @|title@ to `title`. +# -u, --uuid [UUID] set @|uuid@ to `uuid`. +# --main-only only use main mode category. + +# @s@COMMAND LIST@eb@ +# -l, --list [name-rx]@n@ +# list snippets matching NAME-RX@n@ +# OPTIONS@rb@ +# --as-includes list as snippets includes +# --fn-sep [SEP] file name separator (default '#'). +# +# @s@COMMAND GREP@eb@ +# -g, --grep [grep-opts]@n@ +# grep snippets with GREP-OPTS@n@ +# OPTIONS@rb@ +# --as-includes list as snippets includes + +# @s@COMMAND CAT@eb@ +# -c, --cat [name-rx] | - [temp-snippet]@n@ +# retrieve snippet matching NAME-RX or process temporary snippet +# from command-line or standard input.@n@ +# OPTIONS@rb@ +# --all retrieve all snippets, not just the first match. +# -r, --replace do standard replacements @|date@ ... +# --no-replace do no standard replacements @|date@ ... (default) +# -p, --process process commands +# --no-process do not process commands (default) +# +# @s@COMMAND NEW@eb@ +# -n, --new [filename [name]]@n@ +# Retrieve snippet based on filename. +# Implies --replace and --process.@n@ +# The filename extension determines the mode and the name. +# the default name is _.@n@ +# OPTIONS@rb@ +# -f, --force overwrite existing output file. +# -r, --replace do standard replacements @|date@ ... (default) +# --no-replace do no standard replacements @|date@ ... +# -p, --process process commands (default) +# --no-process do not process commands +# +# @s@COMMON OPTIONS FOR CAT/NEW@eb@ +# --no-skip do not skip any sections, if not processing. +# --no-indent do not add indent to lines. (Useful for --mark). +# --no-final without final replacement (for further processing as snippet) +# --mark[=NUM] mark snippet and included snippets. +# (see section MARK FLAGS) +# -k, --key [KEY] add/clear a replacement key. (deprecated) (implies --replace) +# -v, --value [VALUE] set replacement value for last added key. +# --verbose show full snippets. + +# @s@COMMAND STORE@eb@ +# -s, --store [name] [text|file|url]@n@ +# store text/file/url as snippet.@n@ +# OPTIONS@rb@ +# -f, --force overwrite existing snippet for --store. +# +# @s@COMMAND APPEND@eb@ +# -a, --append [name] [text|file|url]@n@ +# append or store text/file/url as snippet. +# +# @s@COMMON OPTIONS FOR STORE/APPEND@eb@ +# --literal do not quote snippet tags +# --use-both use both header and footer from snippet text +# --use-header use header from snippet text +# --use-footer use footer from snippet text + +# @s@COMMAND WORK@eb@ +# -w, --work [work(1) arguments]@n@ +# change working directory to $SNIPS_DIR and run work(1) with +# arguments. + +# @s@COMMAND INSTALL@eb@ +# --install [bin_dir] # default: /usr/local/bin +# +# @s@COMMAND DIST@eb@ +# --dist [dist_dir] # default: /srv/ftp/pub + +# @s@MARK FLAGS@eb@ +# 0 000 => no marking, unless processing +# 1 001 => mark tagged, if processing +# 2 010 => mark untagged, if processing +# 3 011 => mark both, if processing +# 4 100 => forced marking +# 5 101 => always mark tagged +# 6 110 => always mark untagged +# 7 111 => always mark both + +# @s@SNIPPET FILE NAMES@e@ +# The snippet category is determined as the substring before the +# first underscore. +# +# If no mode is specified for a snippet, the prefix category is used +# as such. +# +# If a supplied snippet name for storage does not have a category, +# the current mode is automatically prepended. +# +# In order to allow for an optional sub-category / name scheme, the +# first dot is used separate categories and name. This allows for +# underscores to appear in a name part after the dot, without +# implying a category:: +# +# `_` [ `.` ] +# +# The sub-category is just a suggestion and has no special meaning +# for snippets(1). +# +# The dot-separator is only used to determine the end of substring, +# where snippets(1) looks for an underscore. It is entirely optional +# and has no other special meaning. + +# @s@|@fempty@|<-snap->|| HANDLERS@eb@ +# - capture on | off | clear | get | drop +# drop == clear + off +# +# - debug NUM +# set debug level to NUM +# +# - show [ [[[!]final] replacement] ... ] +# show current value of replacement +# +# - alias alias_name command_handler +# define alias_name to behave as command_handler.@rb@ + +# - start comment +# start snippet +# +# - stop comment +# stop snippet +# +# - title title +# Not processed +# +# - uuid uuid +# Not processed@rb@ + +# - mark [text] +# without `text`, a timestamp is used for the mark +# +# - beg +# see option --mark +# +# - end +# see option --mark@rb@ + +# - indent [+-]NUM +# set indent to NUM. If `+` or `-` is given, increase or decrease indent respectively. +# Option --no-indent suppresses indents.@rb@ + +# - rem [text] +# text is ignored, the tag is removed +# +# - trim left|right|all +# accumulated text is trimmed. `all` is the default. +# +# - drop +# accumulated text is dropped. +# +# - quote text +# `text` is inserted verbatim without replacement or processing +# +# - todo comment +# add TODO entry@rb@ + +# - undef key +# undefine @|key@ +# +# - define key [['!']'default'] [['!']'final'] +# [['!']'unquote'] [['!']'replace'] [['!']'process'] +# start/stop defining replacement for @|key@. +# +# - If `default` is specified, only set replacement, if it not yet +# defined. +# - If `final` is specified, set a replacement for final +# replacement pass. +# - If `unquote` is specified, remove one level of quoting from +# replacements. before replacing. +# - If `replace` is specified, substitute current replacements +# before definition. +# - If `process` is specified, the collected replacement text is +# processed (default is the global processing status). +# +# - default key value +# If replacing is enabled, set @|key@ replacement to `value`, if +# it is not yet defined. One level of quoting is removed from +# `value`. +# +# - subst key value +# If replacing is enabled, set @|key@ replacement to `value`. One +# level of quoting is removed from `value`. +# +# - final key value +# If replacing is enabled, set @|key@ replacement to `value` for +# final replacement after comment cleanup. One level of quoting is +# removed from `value`.@rb@ + +# - verbatim +# begin/end verbatim block +# +# - snip +# begin/end block +# +# - snap +# begin/end block +# +# - read +# +# - include file-rx [accept cat-accept-rx] [ignore cat-ignore-rx] \ +# [[!]process] [[!]skip] \ +# [[!]replace] [[!]export] [[!]import] \ +# [key=value ...] [-key] +# +# include file matching FILE-RX. +# +# See section 'INCLUDE FILE RX REPLACEMENTS' below for FILE-RX +# quoting. +# +# - if PROCESS is given, turn processing on/off as +# specified. default: global processing flag. +# - if SKIP is given, set skipping, if not processing, to +# always/never as specified. default: global no_skip flag. +# - if REPLACE is given, turn replacing on/off as +# specified. default: global replace flag. +# - if IMPORT is given, keep/restore replacements defined in +# include file as specified. default: on. +# - ACCEPT. default: global --accept-cat option. !ACCEPT == IGNORE +# - INGORE. default: global --ignore-cat option. !IGNORE == ACCEPT@rb@ + +# - exec [[!]dump] [[!]process] [[!]skip] [[!]autostart] \ +# [[!]replace] [[!]export] [[!]import] \ +# [sprocess] [sreplace] [sunquote] \ +# [key=value ...] [-key] +# sh(1)-cmd +# ... +# exec +# +# get text from output of sh(1)-cmd. The result is processed as +# snippets text. +# +# - if DUMP is given, the shell command output is not processed in +# any way. This avoids end-of-line trimming, which would messs +# up binary data. +# +# - if SUNQUOTE is given, the shell script is unquoted after +# processing and replacing, but before execution. +# +# - shellq sh(1)-cmd +# get text from output of sh(1)-cmd. The result is not further +# processed. +# +# - shell sh(1)-cmd +# get text from output of sh(1)-cmd. The result is processed as +# snippet.@rb@ + +# - skip [`keep`] +# start/stop skipping. If keep is specified, only drop section +# when processing@rb@ + +# - if [[!]final] [!]defined key +# include section up to next `elif/else/fi`, only if condition is true. +# +# - if [[!]final] [!]eq key value +# include section up to next `elif/else/fi`, only if condition is true. +# +# - elif [[!]final] { [!]defined key | [!]eq key value } +# include section up to next `elif/else/fi`, only if no if/elif +# was included before and if condition is true. +# +# - else +# include section up to next `fi`, if no if/elif was included before. +# +# - fi +# terminate if/elif/else/fi block. + +# @s@SPECIAL SKIP HANDLERS@e@ + +# If a snippet is retrieved for snippets internal use:: +# +# for_snips => [quote] +# not_for_snips => [skip] + +# If a snippet is retrieved for external use:: +# +# for_snips => [skip] +# not_for_snips => [quote] + +# @s@DEPRECATED HANDLERS@eb@ +# - evalq text +# deprecated for portability. +# perl(1) eval of `text`. The result is not further processed. +# +# - eval text +# deprecated for portability. +# perl(1) eval of `text`. The result is processed as snippets +# text. + +# @s@SNIPPET TAG QUOTING@e@ +# Snippet tags are only recognized at the beginning of a line, +# optionally proceeded by a comment start skip. Therefore, snippet +# tags within a line do not need to be quoted. Other snippet tags +# can be quoted through the final replacement mechanism. E.g.:: +# +# ;; |@|fempty@|<-snap->|| +# +# results in:: +# +# ;; ||<-snap->|| +# +# and still allows symbol tag navigation with the reduced delimiter +# set `("|<-" . "->|")`. + +# @s@REPLACEMENT QUOTING@eb@ +# The first `|` after an `@` is removed in the final pass: +# +# @||quoted@ => @|quoted@ +# @|||quoted@ => @||quoted@ +# @||||quoted@ => @|||quoted@ +# +# This also allows for quoting of the generic comment syntax:: +# +# @||:comm@ => @|:comm@ + +# @s@STANDARD REPLACEMENTS@eb@ +# @|mode@ => [text] + +# @|empty@ => [] +# @|space@ => [ ] +# @|nl@ => + +# @|filename@ => if output filename is applicable +# @|filebase@ => if output filename is applicable + +# @|dts@ => [2011-11-29 22:57:08] +# @|sts@ => [1322603828] + +# @|date@ => [2011-11-29] +# @|time@ => [22:57:08] + +# @|year@ => [2011] +# @|month@ => [11] +# @|day@ => [29] +# @|hours@ => [22] +# @|minutes@ => [57] +# @|seconds@ => [08] + +# @|:_comm@ => sep + comment-end +# @|:comm@ => comment-start +# @|:comm_@ => comment-start + sep +# @|:comm_line@ => [@|:comm@@|_comm@] +# @|:comme@ => comment-end + +# @|:bcomm@ => block-comment-start +# @|:bcomme@ => block-comment-end +# @|:bcomm_@ => block-comment-start + sep +# @|:_bcomm@ => sep + block-comment-end + +# @|:lcomm@ => line comment within block-comment +# @|:lcomm_@ => line comment within block-comment + sep + +# @s@FINAL REPLACEMENTS@eb@ +# @|fempty@ => [] +# @|fspace@ => [ ] +# @|fnl@ => + +# @s@SPECIAL REPLACEMENTS@eb@ +# @|snip_mode@ => the current snippet mode, which is not necessarily the same as the emacs mode. +# @|snip_self@ => the current snippet file +# @|snip_selfi@ => the current snippet file, quoted for `include` command. +# @|snip_selfq@ => the current snippet file, quoted for shell +# @|snip_self_dir@ => the current snippet file +# @|snip_self_diri@ => the current snippet file, quoted for `include` command. +# @|snip_self_dirq@ => the current snippet file, quoted for shell +# @|snip_self_base@ => the current snippet file +# @|snip_self_basei@ => the current snippet file, quoted for `include` command. +# @|snip_self_baseq@ => the current snippet file, quoted for shell + +# @s@COMMAND LINE SUBSTITUTION HANDLING@e@ +# 1. `snips_process_line__` replaces entire command line::@n@ +# |@fempty@|<-snap->|| @|command@ opt=@||val@ opt2=@|||val2@ +# => +# |@fempty@|<-snap->|| replaced opt=@||val@ opt2=@|||val2@ +# +# 2. `subst` command removes one level of quoting::@n@ +# |@fempty@|<-snap->|| replaced opt=@||val@ opt2=@|||val2@ +# => +# |@fempty@|<-snap->|| replaced opt=@|val@ opt2=@||val2@ +# +# 3. `subst` command splits option arguments into key/value pairs::@n@ +# |@fempty@|<-snap->|| replaced opt=@|val@ opt2=@||val2@ +# => +# [[ opt, @|val@ ], [ opt2, @||val2@ ]] +# +# 4. `subst` command replaces values::@n@ +# [[ opt, @|val@ ] [ opt2, @||val2@ ]] +# => +# [[ opt, replaced ], [ opt2, @||val2@ ]] +# +# 5. `subst` command removes another level of quotes::@n@ +# [[ opt, replaced ], [ opt2, @||val2@ ]] +# => +# [[ opt, replaced ], [ opt2, @|val2@ ]] + +# @s@INCLUDE FILE RX REPLACEMENTS@e@ +# The first level of quotes is removed on FILE-RX and the +# appropriate replacements are filled in. Then, another level of +# quotes is removed. This works exactly like the `subst` command. +# +# If you wish to match a filename with a valid replacement in it, +# you must double-quote it (e.g. `@|||space@`), or use other means +# like @\|match@ or `@[m]atch@`. +# +# The following replacements are defined as defaults (i.e., if they +# are not yet defined) when replacing the first quote level of an +# `include` file regexp:: +# +# @|snip_fn_space@ => ` ` +# @|snip_fn_tab@ => `\t` +# @|snip_fn_cr@ => `\r` +# @|snip_fn_nl@ => `\n` + +# @s@CONFIGURATION@e@ +# SNIPS_PATH is taken from the environment variable `SNIPS_PATH`. If +# the variable is not set, `${HOME}/snippets` is used. +# +# SNIPS_DIR is then taken from the environment variable +# `SNIPS_DIR`. If the variable is not set, the first element of +# SNIPS_PATH is used. +# +# All directories named `.snippets` going up from the current +# directory to the root level are prepended to SNIPS_PATH in reverse +# order. I.e., the `.snippets` directory in the current working +# directory takes highest precedence. +# +# SNIPS_PATH is searched for `snip_setup`. The first occurence +# found is processed. Any resulting text is discarded. +# +# SNIPS_PATH is then searched in reverse order for all files named +# `.snips.rc`, which are all processed. Any resulting text is +# discarded. +# +# It is really intended to process `snip_setup` and `.snips.rc` +# before option processing. However, this still remains ``|:todo:|``. +# +# The configuration processing is mainly useful to define +# replacements. But can also be used with the `exec` mechanism to +# create directories, files and the like. + +# @s@ENVIRONMENT@eb@ +# SNIPS_PATH is searched for snippets +# SNIPS_PATH="${SNIPS_PATH-${HOME}/snippets}" +# +# SNIPS_DIR is used to store snippets +# SNIPS_DIR="${SNIPS_DIR-first element of SNIPS_PATH}" +# +# SNIPS_MODE is the default mode to be used. +# +# SNIPS_CAT is the default category (rx) to be used. +# +# SNIPS_COMMENT_START +# +# SNIPS_COMMENT_START_SKIP +# +# SNIPS_COMMENT_END +# +# SNIPS_COMMENT_END_SKIP +# +# SNIPS_COMMENT_START_SEP +# +# SNIPS_COMMENT_END_SEP +# +# ||<-snap->|| if !defined min_mode +# Copyright (C) 2010, 2011, 2012 Wolfgang Scherer, Sudetenstr. 48, +# D-97340 Marktbreit, +# ||<-snap->|| fi +# ||<-snap->|| skip +eval 'exec perl -w -S $0 ${1+"$@"}' +if 0; +# +# This file is part of Snippets. +# +# Snippets 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 2 of the License, or (at +# your option) any later version. +# +# Snippets 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 Snippets; see the file COPYING. If not, +# write to Wolfgang Scherer, Sudetenstr. 48, D-97340 +# Marktbreit, or the Free Software Foundation, Inc., 59 Temple +# Place, Suite 330, Boston, MA 02111-1307, USA. +# ||<-snap->|| skip +# ||<-snip->|| stop + +# Handle -?, -h, --help +sub usage { + local ( *HANDLE ) = shift; + my $rst_format = shift || 0; + my $min_format = shift || 0; + my $opts = shift || ''; + my $programq = sqe($0); + $programq = snip_quote_file($0); + + my $define = 'undef'; + if ($rst_format) { + $define = 'subst'; + } + + my $mindef = 'undef'; + if ($min_format) { + $mindef = 'subst'; + } + + my $script = " +|"."|<-snip->|| start +||<-snap->|| define n +\@nl@# +||<-snap->|| define +||<-snap->|| ${define} rst_mode +||<-snap->|| ${mindef} min_mode +||<-snip->|| if !defined rst_mode +||<-snap->|| define rb + +\@empty@ +||<-snap->|| define +||<-snap->|| define s +||<-snap->|| define +||<-snap->|| define e +\@rb@ +||<-snap->|| define +||<-snap->|| define eb +\@rb@ +||<-snap->|| define +||<-snap->|| define hs +||<-snap->|| define +||<-snap->|| define he +||<-snap->|| define +||<-snap->|| subst contents +||<-snap->|| fi +||<-snip->|| if defined rst_mode +||<-snap->|| define rb + +# +# :: +# +\@empty\@ +||<-snap->|| define +||<-snap->|| define s +-------------------------------------------------- +# \@empty@ +||<-snap->|| define +||<-snap->|| define e + +# -------------------------------------------------- +||<-snap->|| define +||<-snap->|| define eb +\@e@\@rb@ +||<-snap->|| define +||<-snap->|| define contents + +# .. contents:: +# +||<-snap->|| define +||<-snap->|| define hs +================================================== +# \@empty@ +||<-snap->|| define +||<-snap->|| define he + +# ================================================== +||<-snap->|| define +||<-snip->|| drop +||<-snap->|| fi +||<-snap->|| if defined min_mode +||<-snap->|| subst contents +||<-snap->|| fi +||<-snap->|| include $programq +|"."|<-snip->|| stop +"; + + my $cmd = "printf '%s\\n' ".sqe($script)." | $0 --process --replace --mode pl ".$opts." --cat - |"; + open ( SELF, $cmd ); + while ( ) { + if ( m/^#!|^:/so ) { + next; + } + if ( ! m/^#|^[ \t]*$/so ) { + last; + } + s,^# ?,,so; + printf HANDLE ( "%s", $_ ); + } +} + +use vars qw( $prog_name $bin_dir $inst_dir ); +use vars qw($msg_output); + +BEGIN { + $msg_output = *STDERR; + $bin_dir = '.'; + $0 =~ m,^(.*)/(.*)$,so; + $bin_dir = $1 if $1; + $prog_name = 'snippets'; + $prog_name = $2 if $2; + unshift ( @INC, $bin_dir ); + $inst_dir = $bin_dir; + my $l = readlink ( $0 ); + if ( $l ) { + if ( $l !~ m,/,so) { + # $prog_name = $l; + } elsif ( $l =~ m,^(.*)/(.*)$,so && $1 ) { + $inst_dir = $1; + $prog_name = $2; + $l =~ m,^(/),so; + $inst_dir = $bin_dir.'/'.$inst_dir if !$1; + unshift ( @INC, $inst_dir ); + } + } +} + +# make UUID::Tiny compatible with `use strict` +use vars qw( + *UUID::Tiny::equal_UUIDs + *UUID::Tiny::clk_seq_of_UUID + *UUID::Tiny::clk_seq_of_UUID + *UUID::Tiny::create_UUID_as_string + *UUID::Tiny::create_UUID + *UUID::Tiny::string_to_UUID + *UUID::Tiny::version_of_UUID + *UUID::Tiny::time_of_UUID + *UUID::Tiny::UUID_to_string + *UUID::Tiny::is_UUID_string + ); + +# THE FOLLOWING MODULE IS COPIED FROM ITS ORIGINAL SOURCE AS IS AND +# THEREFORE IS NOT COVERED BY THE COPYRIGHT NOTICE AT THE BEGINNING OF +# THE FILE. +# vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +package UUID::Tiny; + +use 5.008; +use warnings; +use strict; +use Carp; +use Digest::MD5; +use MIME::Base64; +use Time::HiRes; +use POSIX; + +our $SHA1_CALCULATOR = undef; + +{ + # Check for availability of SHA-1 ... + local $@; # don't leak an error condition + eval { require Digest::SHA; $SHA1_CALCULATOR = Digest::SHA->new(1) } || + eval { require Digest::SHA1; $SHA1_CALCULATOR = Digest::SHA1->new() } || + eval { + require Digest::SHA::PurePerl; + $SHA1_CALCULATOR = Digest::SHA::PurePerl->new(1) + }; +}; + +our $MD5_CALCULATOR = Digest::MD5->new(); + +# ToDo: +# - Check and report for undefined UUIDs with all UUID manipulating functions! +# - Better error propagation for better debugging. + +=head1 NAME + +UUID::Tiny - Pure Perl UUID Support With Functional Interface + +=head1 VERSION + +Version 1.03 + +=cut + +our $VERSION = '1.03'; + +=head1 SYNOPSIS + +Create version 1, 3, 4 and 5 UUIDs: + + use UUID::Tiny; + + my $v1_mc_UUID = create_UUID(); + my $v3_md5_UUID = create_UUID(UUID_V3, $str); + my $v3_md5_UUID = create_UUID(UUID_V3, UUID_NS_DNS, 'caugustin.de'); + my $v4_rand_UUID = create_UUID(UUID_V4); + my $v5_sha1_UUID = create_UUID(UUID_V5, $str); + my $v5_with_NS_UUID = create_UUID(UUID_V5, UUID_NS_DNS, 'caugustin.de'); + + my $v1_mc_UUID_string = create_UUID_as_string(UUID_V1); + my $v3_md5_UUID_string = UUID_to_string($v3_md5_UUID); + + if ( version_of_UUID($v1_mc_UUID) == 1 ) { ... }; + if ( version_of_UUID($v5_sha1_UUID) == 5 ) { ... }; + if ( is_UUID_string($v1_mc_UUID_string) ) { ... }; + if ( equal_UUIDs($uuid1, $uuid2) ) { ... }; + + my $uuid_time = time_of_UUID($v1_mc_UUID); + my $uuid_clk_seq = clk_seq_of_UUID($v1_mc_UUID); + +=cut + +=head1 DESCRIPTION + +UUID::Tiny is a lightweight, low dependency Pure Perl module for UUID +creation and testing. This module provides the creation of version 1 time +based UUIDs (using random multicast MAC addresses), version 3 MD5 based UUIDs, +version 4 random UUIDs, and version 5 SHA-1 based UUIDs. + +ATTENTION! UUID::Tiny uses Perl's C to create the basic random +numbers, so the created v4 UUIDs are B cryptographically strong! + +No fancy OO interface, no plethora of different UUID representation formats +and transformations - just string and binary. Conversion, test and time +functions equally accept UUIDs and UUID strings, so don't bother to convert +UUIDs for them! + +All constants and public functions are exported by default, because if you +didn't need/want them, you wouldn't use this module ... + +UUID::Tiny deliberately uses a minimal functional interface for UUID creation +(and conversion/testing), because in this case OO looks like overkill to me +and makes the creation and use of UUIDs unnecessarily complicated. + +If you need raw performance for UUID creation, or the real MAC address in +version 1 UUIDs, or an OO interface, and if you can afford module compilation +and installation on the target system, then better look at other CPAN UUID +modules like L. + +This module is "fork safe", especially for random UUIDs (it works around +Perl's rand() problem when forking processes). + +This module should be "thread safe," because its global variables +are locked in the functions that access them. (Not tested - if you can provide +some tests, please tell me!) + +=cut + +=head1 DEPENDENCIES + +This module should run from Perl 5.8 up and uses mostly standard (5.8 core) +modules for its job. No compilation or installation required. These are the +modules UUID::Tiny depends on: + + Carp + Digest::MD5 Perl 5.8 core + Digest::SHA Perl 5.10 core (or Digest::SHA1, or Digest::SHA::PurePerl) + MIME::Base64 Perl 5.8 core + Time::HiRes Perl 5.8 core + POSIX Perl 5.8 core + +If you are using this module on a Perl prior to 5.10 and you don't have +Digest::SHA1 installed, you can use Digest::SHA::PurePerl instead. + +=cut + +=head1 ATTENTION! NEW STANDARD INTERFACE (IN PREPARATION FOR V2.00) + +After some debate I'm convinced that it is more Perlish (and far easier to +write) to use all-lowercase function names - without exceptions. And that it +is more polite to export symbols only on demand. + +While the 1.0x versions will continue to export the old, "legacy" interface on +default, the future standard interface is available using the C<:std> tag on +import from version 1.02 on: + + use UUID::Tiny ':std'; + my $md5_uuid = create_uuid(UUID_MD5, $str); + +In preparation for the upcoming version 2.00 of UUID::Tiny you should use the +C<:legacy> tag if you want to stay with the version 1.0x interface: + + use UUID::Tiny ':legacy'; + my $md5_uuid = create_UUID(UUID_V3, $str); + +=cut + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT; +our @EXPORT_OK; +our %EXPORT_TAGS = ( + std => [qw( + UUID_NIL + UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500 + UUID_V1 UUID_TIME + UUID_V3 UUID_MD5 + UUID_V4 UUID_RANDOM + UUID_V5 UUID_SHA1 + UUID_SHA1_AVAIL + create_uuid create_uuid_as_string + is_uuid_string + uuid_to_string string_to_uuid + version_of_uuid time_of_uuid clk_seq_of_uuid + equal_uuids + )], + legacy => [qw( + UUID_NIL + UUID_NS_DNS UUID_NS_URL UUID_NS_OID UUID_NS_X500 + UUID_V1 + UUID_V3 + UUID_V4 + UUID_V5 + UUID_SHA1_AVAIL + create_UUID create_UUID_as_string + is_UUID_string + UUID_to_string string_to_UUID + version_of_UUID time_of_UUID clk_seq_of_UUID + equal_UUIDs + )], +); + +Exporter::export_tags('legacy'); +Exporter::export_ok_tags('std'); + +=head1 CONSTANTS + +=cut + +=over 4 + +=item B + +This module provides the NIL UUID (shown with its string representation): + + UUID_NIL: '00000000-0000-0000-0000-000000000000' + +=cut + +use constant UUID_NIL => "\x00" x 16; + +=item B + +This module provides the common pre-defined namespace UUIDs (shown with their +string representation): + + UUID_NS_DNS: '6ba7b810-9dad-11d1-80b4-00c04fd430c8' + UUID_NS_URL: '6ba7b811-9dad-11d1-80b4-00c04fd430c8' + UUID_NS_OID: '6ba7b812-9dad-11d1-80b4-00c04fd430c8' + UUID_NS_X500: '6ba7b814-9dad-11d1-80b4-00c04fd430c8' + +=cut + +use constant UUID_NS_DNS => + "\x6b\xa7\xb8\x10\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; +use constant UUID_NS_URL => + "\x6b\xa7\xb8\x11\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; +use constant UUID_NS_OID => + "\x6b\xa7\xb8\x12\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; +use constant UUID_NS_X500 => + "\x6b\xa7\xb8\x14\x9d\xad\x11\xd1\x80\xb4\x00\xc0\x4f\xd4\x30\xc8"; + +=item B + +This module provides the UUID version numbers as constants: + + UUID_V1 + UUID_V3 + UUID_V4 + UUID_V5 + +With C you get additional, "speaking" constants: + + UUID_TIME + UUID_MD5 + UUID_RANDOM + UUID_SHA1 + +=cut + +use constant UUID_V1 => 1; use constant UUID_TIME => 1; +use constant UUID_V3 => 3; use constant UUID_MD5 => 3; +use constant UUID_V4 => 4; use constant UUID_RANDOM => 4; +use constant UUID_V5 => 5; use constant UUID_SHA1 => 5; + +=item B + + my $uuid = create_UUID( UUID_SHA1_AVAIL? UUID_V5 : UUID_V3, $str ); + +This function returns 1 if a module to create SHA-1 digests could be loaded, 0 +otherwise. + +UUID::Tiny (since version 1.02) tries to load Digest::SHA, Digest::SHA1 or +Digest::SHA::PurePerl, but does not die if none of them is found. Instead +C and C die when trying to create an +SHA-1 based UUID without an appropriate module available. + +=cut + +sub UUID_SHA1_AVAIL { + return defined $SHA1_CALCULATOR ? 1 : 0; +} + +=back + +=cut + +=head1 FUNCTIONS + +All public functions are exported by default (they should not collide with +other functions). + +C creates standard binary UUIDs in network byte order +(MSB first), C creates the standard string +represantion of UUIDs. + +All query and test functions (except C) accept both +representations. + +=over 4 + +=cut + +=item B, B (:std) + + my $v1_mc_UUID = create_UUID(); + my $v1_mc_UUID = create_UUID(UUID_V1); + my $v3_md5_UUID = create_UUID(UUID_V3, $ns_uuid, $name_or_filehandle); + my $v3_md5_UUID = create_UUID(UUID_V3, $name_or_filehandle); + my $v4_rand_UUID = create_UUID(UUID_V4); + my $v5_sha1_UUID = create_UUID(UUID_V5, $ns_uuid, $name_or_filehandle); + my $v5_sha1_UUID = create_UUID(UUID_V5, $name_or_filehandle); + +Creates a binary UUID in network byte order (MSB first). For v3 and v5 UUIDs a +C (normally a string), C ("classic" file handle) or C object +(i.e. C) can be used; files have to be opened for reading. + +I found no hint if and how UUIDs should be created from file content. It seems +to be undefined, but it is useful - so I would suggest to use UUID_NIL as the +namespace UUID, because no "real name" is used; UUID_NIL is used by default if +a namespace UUID is missing (only 2 arguments are used). + +=cut + +sub create_uuid { + use bytes; + my ($v, $arg2, $arg3) = (shift || UUID_V1, shift, shift); + my $uuid = UUID_NIL; + my $ns_uuid = string_to_uuid(defined $arg3 ? $arg2 : UUID_NIL); + my $name = defined $arg3 ? $arg3 : $arg2; + + if ($v == UUID_V1) { + $uuid = _create_v1_uuid(); + } + elsif ($v == UUID_V3 ) { + $uuid = _create_v3_uuid($ns_uuid, $name); + } + elsif ($v == UUID_V4) { + $uuid = _create_v4_uuid(); + } + elsif ($v == UUID_V5) { + $uuid = _create_v5_uuid($ns_uuid, $name); + } + else { + croak __PACKAGE__ . "::create_uuid(): Invalid UUID version '$v'!"; + } + + # Set variant 2 in UUID ... + substr $uuid, 8, 1, chr(ord(substr $uuid, 8, 1) & 0x3f | 0x80); + + return $uuid; +} + +*create_UUID = \&create_uuid; + +sub _create_v1_uuid { + my $uuid = ''; + + # Create time and clock sequence ... + my $timestamp = Time::HiRes::time(); + my $clk_seq = _get_clk_seq($timestamp); + + # hi = time mod (1000000 / 0x100000000) + my $hi = floor( $timestamp / 65536.0 / 512 * 78125 ); + $timestamp -= $hi * 512.0 * 65536 / 78125; + my $low = floor( $timestamp * 10000000.0 + 0.5 ); + + # MAGIC offset: 01B2-1DD2-13814000 + if ( $low < 0xec7ec000 ) { + $low += 0x13814000; + } + else { + $low -= 0xec7ec000; + $hi++; + } + + if ( $hi < 0x0e4de22e ) { + $hi += 0x01b21dd2; + } + else { + $hi -= 0x0e4de22e; # wrap around + } + + # Set time in UUID ... + substr $uuid, 0, 4, pack( 'N', $low ); # set time low + substr $uuid, 4, 2, pack( 'n', $hi & 0xffff ); # set time mid + substr $uuid, 6, 2, pack( 'n', ( $hi >> 16 ) & 0x0fff ); # set time high + + # Set clock sequence in UUID ... + substr $uuid, 8, 2, pack( 'n', $clk_seq ); + + # Set random node in UUID ... + substr $uuid, 10, 6, _random_node_id(); + + return _set_uuid_version($uuid, 0x10); +} + +sub _create_v3_uuid { + my $ns_uuid = shift; + my $name = shift; + my $uuid = ''; + + lock $MD5_CALCULATOR; + + # Create digest in UUID ... + $MD5_CALCULATOR->reset(); + $MD5_CALCULATOR->add($ns_uuid); + + if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) { + $MD5_CALCULATOR->addfile($name); + } + elsif ( ref $name ) { + croak __PACKAGE__ + . '::create_uuid(): Name for v3 UUID' + . ' has to be SCALAR, GLOB or IO object, not ' + . ref($name) .'!' + ; + } + elsif ( defined $name ) { + $MD5_CALCULATOR->add($name); + } + else { + croak __PACKAGE__ + . '::create_uuid(): Name for v3 UUID is not defined!'; + } + + # Use only first 16 Bytes ... + $uuid = substr( $MD5_CALCULATOR->digest(), 0, 16 ); + + return _set_uuid_version( $uuid, 0x30 ); +} + +sub _create_v4_uuid { + # Create random value in UUID ... + my $uuid = ''; + for ( 1 .. 4 ) { + $uuid .= pack 'I', _rand_32bit(); + } + + return _set_uuid_version($uuid, 0x40); +} + +sub _create_v5_uuid { + my $ns_uuid = shift; + my $name = shift; + my $uuid = ''; + + if (!$SHA1_CALCULATOR) { + croak __PACKAGE__ + . '::create_uuid(): No SHA-1 implementation available! ' + . 'Please install Digest::SHA1, Digest::SHA or ' + . 'Digest::SHA::PurePerl to use SHA-1 based UUIDs.' + ; + } + + lock $SHA1_CALCULATOR; + + $SHA1_CALCULATOR->reset(); + $SHA1_CALCULATOR->add($ns_uuid); + + if ( ref($name) =~ m/^(?:GLOB|IO::)/ ) { + $SHA1_CALCULATOR->addfile($name); + } elsif ( ref $name ) { + croak __PACKAGE__ + . '::create_uuid(): Name for v5 UUID' + . ' has to be SCALAR, GLOB or IO object, not ' + . ref($name) .'!' + ; + } elsif ( defined $name ) { + $SHA1_CALCULATOR->add($name); + } else { + croak __PACKAGE__ + . '::create_uuid(): Name for v5 UUID is not defined!'; + } + + # Use only first 16 Bytes ... + $uuid = substr( $SHA1_CALCULATOR->digest(), 0, 16 ); + + return _set_uuid_version($uuid, 0x50); +} + +sub _set_uuid_version { + my $uuid = shift; + my $version = shift; + substr $uuid, 6, 1, chr( ord( substr( $uuid, 6, 1 ) ) & 0x0f | $version ); + + return $uuid; +} + +=item B, B (:std) + +Similar to C, but creates a UUID string. + +=cut + +sub create_uuid_as_string { + return uuid_to_string(create_uuid(@_)); +} + +*create_UUID_as_string = \&create_uuid_as_string; + +=item B, B (:std) + + my $bool = is_UUID_string($str); + +=cut + +our $IS_UUID_STRING = qr/^[0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12}$/is; +our $IS_UUID_HEX = qr/^[0-9a-f]{32}$/is; +our $IS_UUID_Base64 = qr/^[+\/0-9A-Za-z]{22}(?:==)?$/s; + +sub is_uuid_string { + my $uuid = shift; + return $uuid =~ m/$IS_UUID_STRING/; +} + +*is_UUID_string = \&is_uuid_string; + +=item B, B (:std) + + my $uuid_str = UUID_to_string($uuid); + +This function returns C<$uuid> unchanged if it is a UUID string already. + +=cut + +sub uuid_to_string { + my $uuid = shift; + use bytes; + return $uuid + if $uuid =~ m/$IS_UUID_STRING/; + croak __PACKAGE__ . "::uuid_to_string(): Invalid UUID!" + unless length $uuid == 16; + return join '-', + map { unpack 'H*', $_ } + map { substr $uuid, 0, $_, '' } + ( 4, 2, 2, 2, 6 ); +} + +*UUID_to_string = \&uuid_to_string; + +=item B, B (:std) + + my $uuid = string_to_UUID($uuid_str); + +This function returns C<$uuid_str> unchanged if it is a UUID already. + +In addition to the standard UUID string representation and its URN forms +(starting with C or C), this function accepts 32 digit hex +strings, variants with different positions of C<-> and Base64 encoded UUIDs. + +Throws an exception if string can't be interpreted as a UUID. + +If you want to make shure to have a "pure" standard UUID representation, check +with C! + +=cut + +sub string_to_uuid { + my $uuid = shift; + + use bytes; + return $uuid if length $uuid == 16; + return decode_base64($uuid) if ($uuid =~ m/$IS_UUID_Base64/); + my $str = $uuid; + $uuid =~ s/^(?:urn:)?(?:uuid:)?//io; + $uuid =~ tr/-//d; + return pack 'H*', $uuid if $uuid =~ m/$IS_UUID_HEX/; + croak __PACKAGE__ . "::string_to_uuid(): '$str' is no UUID string!"; +} + +*string_to_UUID = \&string_to_uuid; + +=item B, B (:std) + + my $version = version_of_UUID($uuid); + +This function accepts binary and string UUIDs. + +=cut + +sub version_of_uuid { + my $uuid = shift; + use bytes; + $uuid = string_to_uuid($uuid); + return (ord(substr($uuid, 6, 1)) & 0xf0) >> 4; +} + +*version_of_UUID = \&version_of_uuid; + +=item B, B (:std) + + my $uuid_time = time_of_UUID($uuid); + +This function accepts UUIDs and UUID strings. Returns the time as a floating +point value, so use C to get a C compatible value. + +Returns C if the UUID is not version 1. + +=cut + +sub time_of_uuid { + my $uuid = shift; + use bytes; + $uuid = string_to_uuid($uuid); + return unless version_of_uuid($uuid) == 1; + + my $low = unpack 'N', substr($uuid, 0, 4); + my $mid = unpack 'n', substr($uuid, 4, 2); + my $high = unpack('n', substr($uuid, 6, 2)) & 0x0fff; + + my $hi = $mid | $high << 16; + + # MAGIC offset: 01B2-1DD2-13814000 + if ($low >= 0x13814000) { + $low -= 0x13814000; + } + else { + $low += 0xec7ec000; + $hi --; + } + + if ($hi >= 0x01b21dd2) { + $hi -= 0x01b21dd2; + } + else { + $hi += 0x0e4de22e; # wrap around + } + + $low /= 10000000.0; + $hi /= 78125.0 / 512 / 65536; # / 1000000 * 0x10000000 + + return $hi + $low; +} + +*time_of_UUID = \&time_of_uuid; + +=item B, B (:std) + + my $uuid_clk_seq = clk_seq_of_UUID($uuid); + +This function accepts UUIDs and UUID strings. Returns the clock sequence for a +version 1 UUID. Returns C if UUID is not version 1. + +=cut + +sub clk_seq_of_uuid { + use bytes; + my $uuid = shift; + $uuid = string_to_uuid($uuid); + return unless version_of_uuid($uuid) == 1; + + my $r = unpack 'n', substr($uuid, 8, 2); + my $v = $r >> 13; + my $w = ($v >= 6) ? 3 # 11x + : ($v >= 4) ? 2 # 10- + : 1 # 0-- + ; + $w = 16 - $w; + + return $r & ((1 << $w) - 1); +} + +*clk_seq_of_UUID = \&clk_seq_of_uuid; + +=item B, B (:std) + + my $bool = equal_UUIDs($uuid1, $uuid2); + +Returns true if the provided UUIDs are equal. Accepts UUIDs and UUID strings +(can be mixed). + +=cut + +sub equal_uuids { + my ($u1, $u2) = @_; + return unless defined $u1 && defined $u2; + return string_to_uuid($u1) eq string_to_uuid($u2); +} + +*equal_UUIDs = \&equal_uuids; + +# +# Private functions ... +# +my $Last_Pid; +my $Clk_Seq; + +# There is a problem with $Clk_Seq and rand() on forking a process using +# UUID::Tiny, because the forked process would use the same basic $Clk_Seq and +# the same seed (!) for rand(). $Clk_Seq is UUID::Tiny's problem, but with +# rand() it is Perl's bad behavior. So _init_globals() has to be called every +# time before using $Clk_Seq or rand() ... + +sub _init_globals { + lock $Last_Pid; + lock $Clk_Seq; + + if (!defined $Last_Pid || $Last_Pid != $$) { + $Last_Pid = $$; + # $Clk_Seq = _generate_clk_seq(); + # There's a slight chance to get the same value as $Clk_Seq ... + for (my $i = 0; $i <= 5; $i++) { + my $new_clk_seq = _generate_clk_seq(); + if (!defined($Clk_Seq) || $new_clk_seq != $Clk_Seq) { + $Clk_Seq = $new_clk_seq; + last; + } + if ($i == 5) { + croak __PACKAGE__ + . "::_init_globals(): Can't get unique clk_seq!"; + } + } + srand(); + } + + return; +} + +my $Last_Timestamp; + +sub _get_clk_seq { + my $ts = shift; + _init_globals(); + + lock $Last_Timestamp; + lock $Clk_Seq; + + #if (!defined $Last_Timestamp || $ts <= $Last_Timestamp) { + if (defined $Last_Timestamp && $ts <= $Last_Timestamp) { + #$Clk_Seq = ($Clk_Seq + 1) % 65536; + # The old variant used modulo, but this looks unnecessary, + # because we should only use the signigicant part of the + # number, and that also lets the counter circle around: + $Clk_Seq = ($Clk_Seq + 1) & 0x3fff; + } + $Last_Timestamp = $ts; + + #return $Clk_Seq & 0x03ff; # no longer needed - and it was wrong too! + return $Clk_Seq; +} + +sub _generate_clk_seq { + my $self = shift; + # _init_globals(); + + my @data; + push @data, '' . $$; + push @data, ':' . Time::HiRes::time(); + + # 16 bit digest + # We should return only the significant part of the number! + return (unpack 'n', _digest_as_octets(2, @data)) & 0x3fff; +} + +sub _random_node_id { + my $self = shift; + + my $r1 = _rand_32bit(); + my $r2 = _rand_32bit(); + + my $hi = ($r1 >> 8) ^ ($r2 & 0xff); + my $lo = ($r2 >> 8) ^ ($r1 & 0xff); + + $hi |= 0x80; + + my $id = substr pack('V', $hi), 0, 3; + $id .= substr pack('V', $lo), 0, 3; + + return $id; +} + +sub _rand_32bit { + _init_globals(); + my $v1 = int(rand(65536)) % 65536; + my $v2 = int(rand(65536)) % 65536; + return ($v1 << 16) | $v2; +} + +sub _fold_into_octets { + use bytes; + my ($num_octets, $s) = @_; + + my $x = "\x0" x $num_octets; + + while (length $s > 0) { + my $n = ''; + while (length $x > 0) { + my $c = ord(substr $x, -1, 1, '') ^ ord(substr $s, -1, 1, ''); + $n = chr($c) . $n; + last if length $s <= 0; + } + $n = $x . $n; + + $x = $n; + } + + return $x; +} + +sub _digest_as_octets { + my $num_octets = shift; + + $MD5_CALCULATOR->reset(); + $MD5_CALCULATOR->add($_) for @_; + + return _fold_into_octets($num_octets, $MD5_CALCULATOR->digest); +} + +=back + +=cut + +=head1 DISCUSSION + +=over + +=item B + +The random multi-cast MAC address gives privacy, and getting the real MAC +address with Perl is really dirty (and slow); + +=item B + +Using SHA-1 reduces the probabillity of collisions and provides a better +"randomness" of the resulting UUID compared to MD5. Version 5 is recommended +in RFC 4122 if backward compatibility is not an issue. + +Using MD5 (version 3) has a better performance. This could be important with +creating UUIDs from file content rather than names. + +=back + +=head1 UUID DEFINITION + +See RFC 4122 (L) for technical details on +UUIDs. + +=head1 AUTHOR + +Christian Augustin, C<< >> + +=head1 CONTRIBUTORS + +Some of this code is based on UUID::Generator by ITO Nobuaki +Ebanb@cpan.orgE. But that module is announced to be marked as +"deprecated" in the future and it is much too complicated for my liking. + +So I decided to reduce it to the necessary parts and to re-implement those +parts with a functional interface ... + +Jesse Vincent, C<< >>, improved version 1.02 with +his tips and a heavy refactoring. + +=head1 BUGS + +Please report any bugs or feature requests to C, +or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc UUID::Tiny + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +=head1 ACKNOWLEDGEMENTS + +Kudos to ITO Nobuaki Ebanb@cpan.orgE for his UUID::Generator::PurePerl +module! My work is based on his code, and without it I would've been lost with +all those incomprehensible RFC texts and C codes ... + +Thanks to Jesse Vincent (C<< >>) for his feedback, tips and refactoring! + +=head1 COPYRIGHT & LICENSE + +Copyright 2009, 2010 Christian Augustin, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +ITO Nobuaki has very graciously given me permission to take over copyright for +the portions of code that are copied from or resemble his work (see +rt.cpan.org #53642 L). + +=cut + +1; # End of UUID::Tiny +# ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +# THE PREVIOUS MODULE IS COPIED FROM ITS ORIGINAL SOURCE AS IS AND +# THEREFORE IS NOT COVERED BY THE COPYRIGHT NOTICE AT THE BEGINNING OF +# THE FILE. + +package main; # |:here:| +use POSIX qw( strftime ); +use Data::Dumper; +#$Data::Dumper::Terse = 1; +$Data::Dumper::Sortkeys = 1; +$Data::Dumper::Indent = 0; +use FileHandle; +use strict; + +STDERR->autoflush(1); +STDOUT->autoflush(1); + +use vars qw ( + $DEBUG + $VERBOSE + $SNIPS_PATH + $SNIPS_DIR + $SNIPS_CAT + $SNIPS_CAT_IS_DEFAULT + $SNIPS_COMMENT_START + $SNIPS_COMMENT_START_SKIP + $SNIPS_COMMENT_END + $SNIPS_COMMENT_END_SKIP + $SNIPS_COMMENT_START_SEP + $SNIPS_COMMENT_END_SEP + $SNIPS_DEF_MODE + $SNIPS_MODE + $SNIPS_MODE_IS_DEFAULT + $SNIPS_MODES + $SNIPS_MARK + $SNIPS_BY_CAT + $SNIPS_BY_NAME + $opt_ignore_cat_rx + $opt_accept_cat_rx + $opt_no_skip + $opt_no_indent + $opt_no_final + ); +my $dbg_fwid = 21; + +# -------------------------------------------------- +# |||:sec:||| CONFIGURATION +# -------------------------------------------------- + +my $stime = time(); +my $time_stamp = strftime( "%Y-%m-%d %H:%M:%S", localtime ( $stime )); + +my $double_bar = '||'; +my $double_bar_rx = '\|\|'; +my $double_bar_quoted = '|@fempty@|'; + +$DEBUG = 0; +$VERBOSE = 1; + +$SNIPS_MARK = 0; +my $SNIPS_MARK_BIT_TAG = ( 1 << 0 ); +my $SNIPS_MARK_BIT_NTG = ( 1 << 1 ); +my $SNIPS_MARK_BIT_PRC = ( 1 << 2 ); + +$SNIPS_DIR = ''; +if ( exists ( $ENV{SNIPS_DIR} )) { + $SNIPS_DIR = $ENV{SNIPS_DIR}; +} + +$SNIPS_PATH = $ENV{HOME}.'/snippets'; +if ( exists ( $ENV{SNIPS_PATH} )) { + $SNIPS_PATH = $ENV{SNIPS_PATH}; +} elsif ( $SNIPS_DIR ) { + $SNIPS_PATH = $SNIPS_DIR; +} + +$SNIPS_CAT_IS_DEFAULT = 1; +$SNIPS_CAT = ''; +if ( exists ( $ENV{SNIPS_CAT} )) { + $SNIPS_CAT = $ENV{SNIPS_CAT}; + $SNIPS_CAT_IS_DEFAULT = 0; +} + +$SNIPS_COMMENT_START = '#'; +if ( exists ( $ENV{SNIPS_COMMENT_START} )) { + $SNIPS_COMMENT_START = $ENV{SNIPS_COMMENT_START}; +} +$SNIPS_COMMENT_START_SKIP = '#+ *'; +if ( exists ( $ENV{SNIPS_COMMENT_START_SKIP} )) { + $SNIPS_COMMENT_START_SKIP = $ENV{SNIPS_COMMENT_START_SKIP}; +} +$SNIPS_COMMENT_END = ''; +if ( exists ( $ENV{SNIPS_COMMENT_END} )) { + $SNIPS_COMMENT_END = $ENV{SNIPS_COMMENT_END}; +} +$SNIPS_COMMENT_END_SKIP = ''; +if ( exists ( $ENV{SNIPS_COMMENT_END_SKIP} )) { + $SNIPS_COMMENT_END_SKIP = $ENV{SNIPS_COMMENT_END_SKIP}; +} +$SNIPS_COMMENT_START_SEP = '# '; +if ( exists ( $ENV{SNIPS_COMMENT_START_SEP} )) { + $SNIPS_COMMENT_START_SEP = $ENV{SNIPS_COMMENT_START_SEP}; +} +$SNIPS_COMMENT_END_SEP = ''; +if ( exists ( $ENV{SNIPS_COMMENT_END_SEP} )) { + $SNIPS_COMMENT_END_SEP = $ENV{SNIPS_COMMENT_END_SEP}; +} + +$SNIPS_BY_CAT = {}; +$SNIPS_BY_NAME = []; + +# -------------------------------------------------- +# |||:sec:||| string replacements +# -------------------------------------------------- + +use vars qw ( $SNIPS_REPLACEMENTS $SNIPS_REPLACEMENTS_FINAL $SNIPS_REPLACEMENTS_USER ); +$SNIPS_REPLACEMENTS_USER = {}; +$SNIPS_REPLACEMENTS = {}; +$SNIPS_REPLACEMENTS_FINAL = {}; + +# |:todo:| use snip_setup +my $empty = ''; +snip_set_at_replacement ( 'empty', $empty ); + +# |:todo:| use snip_setup +my $fempty = ''; +snip_set_at_replacement_final ( 'fempty', $empty ); + +# |:todo:| use snip_setup +my $nl = "\n"; +snip_set_at_replacement ( 'nl', $nl ); + +snip_set_at_replacement ( 'tag_pfx', ':' ); +snip_set_at_replacement ( 'tag_sfx', ':' ); + +# -------------------------------------------------- +# |||:sec:||| modes +# -------------------------------------------------- + +my $snm_indx_mode = 0; +my $snm_indx_cat = 1; +my $snm_indx_comm = 2; +my $snm_indx_hf = 3; +my $snm_indx_new = 4; + +$SNIPS_DEF_MODE = 'text'; + +$SNIPS_MODE = ''; +$SNIPS_MODE_IS_DEFAULT = 0; +if ( exists ( $ENV{SNIPS_MODE} )) { + $SNIPS_MODE = $ENV{SNIPS_MODE}; +} + +$SNIPS_MODES = {}; + +# |:info:| generic mode with new comment syntax +snip_add_mode ([ 'generic', + [ "gen" ], + [ '@:comm@', '\@:[bl]?comm_?\@', '@:comme@', '\@:(_b?comm|b?comme|#)\@', '@:comm_@', '@:_comm@' ], + # [ ], # no special header / footer + # [ ], # no special snippet for --new + ]); +snip_add_mode ( 'gen' => 'generic' ); +{ + my $mode = snip_add_mode ( 'snip' => 'generic' ); + $mode->[ $snm_indx_cat ] = [ 'snip', @{$mode->[ $snm_indx_cat ]} ]; +} +snip_set_at_replacement ( ':comm_line', '@:comm@@:_comm@', 1 ); +snip_set_at_replacement ( ':lcomm', '' ); +snip_set_at_replacement ( ':lcomm_', '' ); + +# generic mode with old comment syntax +snip_add_mode ([ 'xgeneric', + [ "xgen" ], + [ '@comm@', '\@[bl]?comm_?\@', '@comme@', '\@(_b?comm|b?comme)\@', '@comm_@', '@_comm@' ], + # [ ], # no special header / footer + # [ ], # no special snippet for --new + ]); +snip_add_mode ( 'xgen' => 'xgeneric' ); +snip_set_at_replacement ( 'comm_line', '@:comm@@:_comm@', 1 ); +snip_set_at_replacement ( 'lcomm', '' ); +snip_set_at_replacement ( 'lcomm_', '' ); + +my $sn_perl_header = <<__EOS__; +#!/usr/bin/env perl -w + +# ||<-snap->|| default title template for perl(1) programs +# ||<-snap->|| title \@title\@ +$empty +__EOS__ +snip_add_mode ([ 'perl', + [ "pl", "hd", "gen" ], + [ '#', '#+' ], + [ $sn_perl_header ], + ]); +snip_add_mode ( 'cperl' => 'perl' ); +snip_add_mode ( 'pl' => 'perl' ); +snip_add_mode ( 'pm' => 'perl', 0, 'pl_new-pm' ); + +my $sn_python_header = <<__EOS__; +#!/usr/bin/env python +# -*- coding: utf-8 -*- + +# ||<-snap->|| default title Python Snippet +# ||<-snap->|| title \@title\@ +$empty +__EOS__ +snip_add_mode ([ 'python', + [ "py", "hd", "gen" ], + [ '#', '#+' ], + [ $sn_python_header ], + ]); +snip_add_mode ( py => 'python' ); + +my $sn_sh_header = <<__EOS__; +#!/bin/sh + +# ||<-snap->|| default title Shell Script Snippet +# ||<-snap->|| title \@title\@ +$empty +__EOS__ +snip_add_mode ([ 'sh', + [ "sh", "hd", "gen" ], + [ '#', '#+' ], + [ $sn_sh_header ], + ]); +snip_add_mode ( shell => 'sh' ); +snip_add_mode ( bash => 'sh' ); + +snip_add_mode ([ 'makefile', + [ "mak", "gen" ], + [ '#', '#+' ], + ]); +snip_add_mode ( mak => 'makefile' ); +snip_add_mode ( 'makefile-gmake' => 'makefile' ); + +snip_add_mode ([ 'emacs-lisp', + [ "el", "gen" ], + [ ';;', ';+', '' ], + ]); +snip_add_mode ( el => 'emacs-lisp' ); + +snip_add_mode ([ 'sql', + [ "sql", "gen" ], + [ '--', '--' ], + ]); + +snip_add_mode ([ 'c', + [ "c", "h", "gen" ], + [ '/*', '/\*+', '*/' ], + ]); +snip_add_mode ( 'h' => + [ 'c', + [ "h", "hxx", "gen" ], + $SNIPS_MODES->{c}->[ $snm_indx_comm ], + ]); +snip_add_mode ([ 'css', + [ "css", "gen" ], + $SNIPS_MODES->{'c'}->[ $snm_indx_comm ], + ]); + +snip_add_mode ([ 'c++', + [ "cxx", "c", "hxx", "h", "gen" ], + [ '//', '//+' ], + ]); + +snip_add_mode ([ 'javascript', + [ "js", "gen" ], + [ '//', '//+' ], + ]); +snip_add_mode ( 'js' => 'javascript' ); + +snip_add_mode ([ 'html', + [ "html", "js", "css", "gen" ], + [ '' ], + ]); +snip_add_mode ([ 'php', + [ "php", "gen" ], + $SNIPS_MODES->{'c++'}->[ $snm_indx_comm ], + ]); + +# generic text mode +snip_add_mode ([ 'text', + [ "txt", "url", "file", "pipe", "gen" ], + [ '', '', '' ], + ]); +snip_add_mode ( 'txt' => 'text' ); +snip_add_mode ( 'url' => 'text' ); +snip_add_mode ( 'file' => 'text' ); +snip_add_mode ( 'pipe' => 'text' ); +snip_add_mode ( 'fundamental' => 'text', 1 ); # also set emacs mode +snip_add_mode ( 'dired' => 'text' ); +snip_add_mode ( 'info' => 'text' )->[ $snm_indx_cat ] = [ "info" ]; + +# reStructuredText +{ + my $mode = snip_add_mode ( 'rst' => 'text', 1, 'rst_new' ); + $mode->[ $snm_indx_cat ] = [ 'rst', @{$mode->[ $snm_indx_cat ]} ]; + $mode->[ $snm_indx_comm ] = [ '..', '\.\. |\.\. \\\\' ]; +} + +# reStructuredText for tutorial +{ + my $mode = snip_add_mode ( 'rstt' => 'text', 1, 'rstt_new' ); + $mode->[ $snm_indx_cat ] = [ 'rstt', @{$mode->[ $snm_indx_cat ]} ]; + $mode->[ $snm_indx_comm ] = [ '..', '\.\. |\.\. \\\\' ]; +} + +# add major category +{ + my $mode = snip_add_mode ( 'whereis' => 'text', 0, 'whereis_new' ); + $mode->[ $snm_indx_cat ] = [ 'whereis', @{$mode->[ $snm_indx_cat ]} ]; +} + +snip_consolidate_modes (); + +# -------------------------------------------------- +# |||:sec:||| comments +# -------------------------------------------------- + +my $comment_start_skip_rx; +my $comment_end_skip_rx; + +sub snips_setup_comments { +# setup comment parameters + my $comment_start_skips = {}; + my $comment_end_skips = {}; + foreach my $mode (keys(%{$SNIPS_MODES})) { + my $mode_settings = $SNIPS_MODES->{$mode}; + my $comment_start_skip = $mode_settings->[ $snm_indx_comm ]->[ 1 ]; + $comment_start_skips->{$comment_start_skip} = 1; + my $comment_end_skip = $mode_settings->[ $snm_indx_comm ]->[ 3 ]; + if ( $comment_end_skip ) { + $comment_end_skips->{$comment_end_skip} = 1; + } + } + delete ( $comment_start_skips->{''} ); + $comment_start_skip_rx = join ( '|', sort(keys(%{$comment_start_skips}))); + delete ( $comment_end_skips->{''} ); + $comment_end_skip_rx = join ( '|', sort(keys(%{$comment_end_skips}))); + + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, + 'comment_start_skip_rx', $comment_start_skip_rx ) if $DEBUG > 5; + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, + 'comment_end_skip_rx', $comment_end_skip_rx ) if $DEBUG > 5; +} + +snips_setup_comments(); + +# -------------------------------------------------- +# |||:sec:||| OPTION LOOP +# -------------------------------------------------- + +my @opt_dirs = (); +my $opt_dir_seen = 0; +$opt_ignore_cat_rx = '^(none)$'; +my $opt_ignore_cat_seen = 0; +$opt_accept_cat_rx = ''; +my $opt_accept_cat_seen = 0; +my $opt_mode = ''; +my $opt_mode_main_only = 0; +my $opt_mode_seen = 0; + +my $opt_title = ''; +my $opt_uuid = UUID::Tiny::create_UUID_as_string + (UUID::Tiny::UUID_V3, UUID::Tiny::UUID_NS_OID, + UUID::Tiny::create_UUID_as_string()); +snip_set_at_replacement('uuid', $opt_uuid); +snip_set_at_replacement('snip_uuid_last', $opt_uuid); + +my $cmd_seen = 0; + +my $opt_list = 0; +my $opt_grep = 0; +my $opt_as_includes = 0; +my $opt_fn_sep = '#'; + +my $opt_cat = 0; +my $opt_temp_snippet = ''; +my $opt_all = 0; + +my $opt_new = 0; +my $opt_replace = 0; +my $opt_replace_seen = 0; +my $opt_no_replace_seen = 0; +my $opt_process = 0; +my $opt_process_seen = 0; +my $opt_no_process_seen = 0; +$opt_no_skip = 0; +my $opt_no_skip_seen = 0; +$opt_no_indent = 0; +my $opt_no_indent_seen = 0; +$opt_no_final = 0; +my $opt_no_final_seen = 0; + +my $opt_store = 0; +my $opt_append = 0; +my $opt_literal = 0; +my $opt_use_hdr = 0; +my $opt_use_ftr = 0; + +my $opt_work = 0; + +my $opt_force = 0; + +my $opt_name_rx = ''; +my @opt_grep_opts = (); +my $opt_grep_opts = ''; +my $opt_name = ''; +my $opt_filename = ''; + +my @orig_cmd_line = ( $0, @ARGV ); + +my $last_repl_key; + +my $usage_opts = ''; + +OPT: +while ( $#ARGV >= 0 ) { + # --debug + if ( $ARGV[ 0 ] =~ /^-(-de([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + $VERBOSE = 1; + if ( $2 ) { + $DEBUG = $3; + } else { + ++$DEBUG; + } + next OPT; + } + + if ( $prog_name eq 'snw' ) { + last OPT; + } + if ( $prog_name eq 'sng' ) { + last OPT; + } + + # --help + if ( $ARGV[ 0 ] =~ /^-(\?|h|-h)/ ) { + usage ( *STDOUT, 0, 0, $usage_opts); + exit 0; + } + # --rst-help + if ( $ARGV[ 0 ] =~ /^-(-rst-h)/ ) { + usage ( *STDOUT, 1, 0, $usage_opts ); + exit 0; + } + # --rst-min-help + if ( $ARGV[ 0 ] =~ /^-(-rst-m)/ ) { + usage ( *STDOUT, 1, 1, $usage_opts ); + exit 0; + } + # --install + if ( $ARGV[ 0 ] =~ /^-(-install)$/ ) { + shift ( @ARGV ); + my $inst_bin_dir = shift ( @ARGV ); + if ( !$inst_bin_dir ) { + $inst_bin_dir = '/usr/local/bin'; + } + system ( "cp -p '".sq ( $0 )."' '".sq ( $inst_bin_dir.'/snippets' )."'" ); + # :shortcut: + foreach my $shortcut ( 'snh', 'snl', 'sng', 'sni', 'snc', 'snr', 'snn', 'sna', 'sns', 'snw' ) { + system ( "rm -f '".sq ( $inst_bin_dir.'/'.$shortcut )."'" ); + system ( "ln -s snippets '".sq ( $inst_bin_dir.'/'.$shortcut )."'" ); + } + exit ( 0 ); + } + # --dist + if ( $ARGV[ 0 ] =~ /^-(-dist)/ ) { + shift ( @ARGV ); + my $dist_dir = shift ( @ARGV ); + if ( !$dist_dir ) { + $dist_dir = '/srv/ftp/pub'; + } + system ( "cp -p '".sq ( $0 )."' '".sq ( $dist_dir.'/snippets.pl' )."'" ); + exit ( 0 ); + } + + # --quiet + if ( $ARGV[ 0 ] =~ /^-(q|-q)/ ) { + shift ( @ARGV ); + $VERBOSE=0; + next OPT; + } + # --verbose + if ( $ARGV[ 0 ] =~ /^-(-ve)/ ) { + shift ( @ARGV ); + ++$VERBOSE; + next OPT; + } + # --dir + if ( $ARGV[ 0 ] =~ /^-(d|-di([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $SNIPS_DIR = $3; + } else { + $SNIPS_DIR = shift ( @ARGV ); + } + $SNIPS_PATH = $SNIPS_DIR.':'.$SNIPS_PATH; + push ( @opt_dirs, $SNIPS_DIR ); + $opt_dir_seen = 1; + next OPT; + } + # --accept-cat + if ( $ARGV[ 0 ] =~ /^-(-ac([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_accept_cat_rx = $3; + } else { + $opt_accept_cat_rx = shift ( @ARGV ); + } + $opt_accept_cat_seen = 1; + next OPT; + } + # --ignore-cat + if ( $ARGV[ 0 ] =~ /^-(i|-ig([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_ignore_cat_rx = $3; + } else { + $opt_ignore_cat_rx = shift ( @ARGV ); + } + $opt_ignore_cat_seen = 1; + next OPT; + } + # --mode + if ( $ARGV[ 0 ] =~ /^-(m|-mo([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_mode = $3; + } else { + $opt_mode = shift ( @ARGV ); + } + $opt_mode_seen = 1; + # |:check:| why? + # if ( $opt_mode ) { + # $opt_accept_cat_seen = 0; + # } + next OPT; + } + # --title + if ( $ARGV[ 0 ] =~ /^-(t|-t([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_title = $3; + } else { + $opt_title = shift ( @ARGV ); + } + snip_set_at_replacement('title', $opt_title); + snip_set_at_replacement('snip_title_last', $opt_title); + next OPT; + } + # --uuid + if ( $ARGV[ 0 ] =~ /^-(u|-u([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_uuid = $3; + } else { + $opt_uuid = shift ( @ARGV ); + } + snip_set_at_replacement('uuid', $opt_uuid); + snip_set_at_replacement('snip_uuid_last', $opt_uuid); + next OPT; + } + # --main-only + if ( $ARGV[ 0 ] =~ /^-(-mai)/ ) { + shift ( @ARGV ); + $opt_mode_main_only = 1; + next OPT; + } + # --force + if ( $ARGV[ 0 ] =~ /^-(f|-fo)/ ) { + shift ( @ARGV ); + $opt_force = 1; + next OPT; + } + + # --list + if ( $ARGV[ 0 ] =~ /^-(l|-lis([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_name_rx = $3; + } else { + $opt_name_rx = shift ( @ARGV ); + } + $opt_list = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--list' || '' ) if $DEBUG > 4; + next OPT; + } + # --grep + if ( $ARGV[ 0 ] =~ /^-(g|-g)/ ) { + shift ( @ARGV ); + @opt_grep_opts = @ARGV; + $opt_grep = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--grep' || '' ) if $DEBUG > 4; + next OPT; + } + # for --list/--grep + { + # --as-includes + if ( $ARGV[ 0 ] =~ /^-(-as)/ ) { + shift ( @ARGV ); + $opt_as_includes = 1; + next OPT; + } + # --fn-sep + if ( $ARGV[ 0 ] =~ /^-(-fn([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_fn_sep = $3; + } else { + $opt_fn_sep = shift ( @ARGV ); + } + next OPT; + } + } + + # --cat + if ( $ARGV[ 0 ] =~ /^-(c|-c([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_name_rx = $3; + } else { + $opt_name_rx = shift ( @ARGV ); + } + $opt_temp_snippet = shift ( @ARGV ); + $opt_cat = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--cat' || '' ) if $DEBUG > 4; + next OPT; + } + # for --cat + { + # --all + if ( $ARGV[ 0 ] =~ /^-(-al)/ ) { + shift ( @ARGV ); + $opt_all = 1; + next OPT; + } + } + + # --new + if ( $ARGV[ 0 ] =~ /^-(n|-ne([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_filename = $3; + } else { + $opt_filename = shift ( @ARGV ); + } + $opt_name = shift ( @ARGV ); + $opt_new = 1; + if ( !$opt_no_replace_seen ) { + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + } + if ( !$opt_no_process_seen ) { + $opt_process = 1; + $opt_process_seen = 1; + $opt_no_process_seen = 0; + } + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--new' || '' ) if $DEBUG > 4; + next OPT; + } + # for --cat/--new + { + # --mark + if ( $ARGV[ 0 ] =~ /^-(-mar([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $SNIPS_MARK = $3; + } else { + ++$SNIPS_MARK; + } + next OPT; + } + # --replace + if ( $ARGV[ 0 ] =~ /^-(r|-re)/ ) { + shift ( @ARGV ); + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + next OPT; + } + # --no-replace + if ( $ARGV[ 0 ] =~ /^-(-no-r)/ ) { + shift ( @ARGV ); + $opt_replace = 0; + $opt_replace_seen = 0; + $opt_no_replace_seen = 1; + next OPT; + } + # --no-final + if ( $ARGV[ 0 ] =~ /^-(-no-f)/ ) { + shift ( @ARGV ); + $opt_no_final = 1; + $opt_no_final_seen = 1; + $usage_opts .= ' --no-final'; + next OPT; + } + # --process + if ( $ARGV[ 0 ] =~ /^-(p|-p)/ ) { + shift ( @ARGV ); + $opt_process = 1; + $opt_process_seen = 1; + $opt_no_process_seen = 0; + next OPT; + } + # --no-process + if ( $ARGV[ 0 ] =~ /^-(-no-p)/ ) { + shift ( @ARGV ); + $opt_process = 0; + $opt_process_seen = 0; + $opt_no_process_seen = 1; + next OPT; + } + # --no-skip + if ( $ARGV[ 0 ] =~ /^-(-no-s)/ ) { + shift ( @ARGV ); + $opt_no_skip = 1; + $opt_no_skip_seen = 1; + next OPT; + } + # --no-indent + if ( $ARGV[ 0 ] =~ /^-(-no-i)/ ) { + shift ( @ARGV ); + $opt_no_indent = 1; + $opt_no_indent_seen = 1; + next OPT; + } + # --key + if ( $ARGV[ 0 ] =~ /^-(k|-k([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $last_repl_key = $3; + } else { + $last_repl_key = shift ( @ARGV ); + } + if ( !$last_repl_key ) { + snip_msg ( "error: Invalid empty key\n" ); + exit ( 1 ); + } + my @nkeys = snip_normalize_at_key( $last_repl_key ); + if ( $last_repl_key eq $nkeys[ 0 ]) { + snip_msg("warning: deprecated full key specification `--key %s`. use `--key %s`\n", + $nkeys[0], $nkeys[1]); + $last_repl_key = $nkeys[ 1 ]; + } + snip_set_user_at_replacement ( $last_repl_key, '' ); + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + next OPT; + } + # --value + if ( $ARGV[ 0 ] =~ /^-(v|-va([^=]*=(.*))?)/ ) { + my $value; + shift ( @ARGV ); + if ( $2 ) { + $value = $3; + } else { + $value = shift ( @ARGV ); + } + if ( !$last_repl_key ) { + snip_msg ( "error: No key available for --val=`%s`\n", $value ); + exit ( 1 ); + } + snip_set_user_at_replacement ( $last_repl_key, $value ); + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + next OPT; + } + } + + # --store + if ( $ARGV[ 0 ] =~ /^-(s|-s([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_name = $3; + } else { + $opt_name = shift ( @ARGV ); + } + $opt_store = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--store' || '' ) if $DEBUG > 4; + next OPT; + } + # --append + if ( $ARGV[ 0 ] =~ /^-(a|-ap([^=]*=(.*))?)/ ) { + shift ( @ARGV ); + if ( $2 ) { + $opt_name = $3; + } else { + $opt_name = shift ( @ARGV ); + } + $opt_append = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--append' || '' ) if $DEBUG > 4; + next OPT; + } + # for --store/--append + { + # --literal + if ( $ARGV[ 0 ] =~ /^-(-lit)/ ) { + shift ( @ARGV ); + $opt_literal = 1; + next OPT; + } + # --use-header + if ( $ARGV[ 0 ] =~ /^-(-use-h)/ ) { + shift ( @ARGV ); + $opt_use_hdr = 1; + next OPT; + } + # --use-footer + if ( $ARGV[ 0 ] =~ /^-(-use-f)/ ) { + shift ( @ARGV ); + $opt_use_ftr = 1; + next OPT; + } + # --use-both + if ( $ARGV[ 0 ] =~ /^-(-use-b)/ ) { + shift ( @ARGV ); + $opt_use_hdr = 1; + $opt_use_ftr = 1; + next OPT; + } + } + + # --work + if ( $ARGV[ 0 ] =~ /^-(w|-w)/ ) { + shift ( @ARGV ); + $opt_work = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", '--work' || '' ) if $DEBUG > 4; + last OPT; + } + + # -- end of options + if ( $ARGV[ 0 ] eq '--' ) { + shift ( @ARGV ); + last OPT; + } + # - standard input + if ( $ARGV[ 0 ] eq '-' ) { + last OPT; + } + # -- unknown option + if ( $ARGV[ 0 ] =~ /^-(|-)/ ) { + snip_msg ( "error: unknown option `%s`\n", $ARGV[ 0 ]); + exit ( 1 ); + } + last OPT; +} + +snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "ARGV ORIG", + join ( ', ', map { "'".sq ( dbg_trunc_str ( $_ ))."'"; } @orig_cmd_line ) || '' ) + if $DEBUG; +snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "ARGV $cmd_seen", + join ( ', ', map { "'".sq ( dbg_trunc_str ( $_ ))."'"; } @ARGV ) || '' ) + if $DEBUG > 4; +snip_handle_shortcut ( $prog_name, $cmd_seen ); +snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "ARGV $cmd_seen", + join ( ', ', map { "'".sq ( dbg_trunc_str ( $_ ))."'"; } @ARGV ) || '' ) + if $DEBUG > 4; + +# -------------------------------------------------- +# |||:sec:||| SETUP +# -------------------------------------------------- + +# :struct: snips_setup Setup SNIPS parameters +# :struct: snips_default_command Determine default command +# i no command was specified +# t use --list as command +# - +# :struct: +if ( !$cmd_seen ) { + $opt_list = 1; + $opt_name_rx = shift ( @ARGV ); +} + +snip_consolidate_modes (); +snip_setup_comments (); +if ( $DEBUG > 5 ) { + foreach my $mode_name ( sort ( keys ( %{$SNIPS_MODES} ))) { + my $mode = $SNIPS_MODES->{$mode_name}; + snip_msg ( "# ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, 'mode' || '', + Data::Dumper->Dump([ $mode ], [ $mode_name ])); + } +} + +# :struct: snips_determine_mode Determine SNIPS_MODE +# i option --mode was specified +# t override SNIPS_MODE +# e use environment variable SNIPS_MODE +# - +# i option --list was not specified +# t set snip_default_mode() +# - +# :struct: +if ( $opt_mode_seen ) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_mode", $opt_mode || '' ) + if $DEBUG > 4; + $SNIPS_MODE = $opt_mode; +} else { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "default_mode", $SNIPS_MODE || '' ) + if $DEBUG > 4; + $opt_mode = $SNIPS_MODE; +} +if ( !$opt_list && !$opt_mode ) { + $opt_mode = snip_default_mode(); + $SNIPS_MODE_IS_DEFAULT = 1; +} +if ( $opt_mode ) { + snip_set_mode ( $opt_mode, $opt_mode_main_only ); +} + +# if no ignore category rx is set, do not ignore anything. +if ( !$opt_ignore_cat_rx ) { + $opt_ignore_cat_rx = '^$'; +} + +# if no accept category rx is set, accept everything. +if ( !$opt_accept_cat_rx ) { + if ( $SNIPS_CAT ) { + $opt_accept_cat_rx = '^('.$SNIPS_CAT.')$'; + } else { + $opt_accept_cat_rx = '.*'; + } +} + +# if no name rx is set, accept all names. +if ( !$opt_name_rx ) { + $opt_name_rx = '.*'; +} + +# setup SNIPS_PATH +my @snips_path_dirs; +sub setup_path { + my $snips_dirs_seen = {}; + foreach ( split ( /:/, $SNIPS_PATH ), $SNIPS_DIR ) { + if ( !$_ ) { + next; + } + if ( $snips_dirs_seen->{$_} ) { + next; + } + push ( @snips_path_dirs, $_ ); + $snips_dirs_seen->{$_} = 1; + } + + # use first global snippets repository as default + if ( !$SNIPS_DIR ) { + $SNIPS_DIR = $snips_path_dirs[ 0 ]; + } + + # look for local .snippets directories + use Cwd; # import names from Cwd:: + my $here = getcwd(); + my @parts = split(/\//, $here); + my @path; + while (@parts) { + my $dir = join('/', @parts).'/.snippets'; + if ( -d $dir) { + push(@path, $dir); + } + pop(@parts); + } + @snips_path_dirs = (@path, @snips_path_dirs); + + # effective SNIPS_PATH + $SNIPS_PATH = join ( ':', @snips_path_dirs ); +} +setup_path(); + +# |||:sec:||| special setup for --new +if ( $opt_new ) { + if ( !$opt_filename ) { + $opt_filename = '-'; + } + my $rep_filename = $opt_filename; + my $ext_filename = $opt_filename; + my $ext; + if ( $opt_filename eq '-' ) { + $rep_filename = snip_get_at_replacement ( 'filename' ); + if ( $rep_filename ) { + $ext_filename = $rep_filename; + } else { + $rep_filename = ''; + } + } + if ( !$opt_mode_seen ) { + # use file extension, if no SNIPS_MODE was explicitely set + if ( $ext_filename =~ m,[.]([^.]+)$,so ) { + $ext = $1; + if ( exists ( $SNIPS_MODES->{$ext} )) { + $SNIPS_MODE = $ext; + } + } + # use snippet prefix, if no SNIPS_MODE was explicitely set + if ( !$SNIPS_MODE && $ext_filename =~ m/^([^_]+)_/ ) { + my $pfx = $1; + if ( exists ( $SNIPS_MODES->{$pfx} )) { + $SNIPS_MODE = $pfx; + } + } + } + if ( !$SNIPS_MODE ) { + $SNIPS_MODE = snip_default_mode ( $ext ); + } + snip_set_mode ( $SNIPS_MODE, $opt_mode_main_only ); + if ( !snip_get_at_replacement ( 'filename' )) { + snip_set_at_replacement ( 'filename', $rep_filename ); + } + if ( !$opt_name ) { + $opt_name = $SNIPS_MODES->{$SNIPS_MODE}->[ $snm_indx_new ]; + } +} +# :struct: + +# -------------------------------------------------- +# |||:sec:||| FUNCTIONS +# -------------------------------------------------- + +sub sq { + local ( $_ ) = shift; + s,','\\'',sg; + return $_; +} + +sub sqe { + return "'".sq(@_)."'"; +} + +sub repr { + use Data::Dumper; + local ($Data::Dumper::Purity) = 1; + local ($Data::Dumper::Terse) = 1; + local ($Data::Dumper::Sortkeys) = 1; + local ($Data::Dumper::Indent) = 0; + my $var = shift; + local $SIG{__WARN__} = sub {}; + return Dumper($var); +} + +sub dbg_flatten_str { + local ( $_ ) = shift; + s,\\,\\\\,sog; + s,\t,\\t,sog; + s,\r,\\r,sog; + s,\n,\\n,sog; + return $_; +} + +sub dbg_trunc_str { + local ( $_ ) = shift; + my $max_len = shift || 60; + if ( length ( $_ ) > $max_len ) { + $_ = substr ( $_, 0, $max_len ); + } + return dbg_flatten_str($_); +} + +my $dbg_max_depth = 3; + +sub dbg_format_if_array { + my $maybe_array = shift; + my $max_level = shift || $dbg_max_depth; + my $level = shift || 0; +# return $maybe_array; # |:debug:| + if ( !defined ( $maybe_array )) { + return 'undef'; + } + if ($level>$dbg_max_depth) { + my $ref = ref($maybe_array); + if ($ref eq 'ARRAY') { + my $len = scalar(@{$maybe_array}); + if ( !$len ) { + return '[]'; + } + return sprintf("%s(%s)", $ref, $len); + } elsif ($ref eq 'HASH') { + my $len = scalar(%{$maybe_array}); + if ( !$len ) { + return '{}'; + } + return sprintf("%s(%s)", $ref, $len); + } + return $maybe_array; + } + if (ref($maybe_array) eq 'ARRAY') { + return ("[".join(', ', map { dbg_format_if_array($_, $max_level, $level + 1); } @{$maybe_array} )."]"); + } elsif (ref($maybe_array) eq 'HASH') { + return "{".join + (', ', + map { sprintf("%s => %s", $_, dbg_format_if_array($maybe_array->{$_}, $max_level, $level + 1)); } + sort(keys(%{$maybe_array})) + )."}"; + } + if ( $maybe_array =~ m/^[0-9]+$/so) { + return dbg_flatten_str( $maybe_array); + } + return "'".sq( dbg_flatten_str( $maybe_array))."'"; +} + +# -------------------------------------------------- +# Convert an integer into a binary string representation. +# +# STRING = binf ( INTEGER[, BIT-LENGTH[, BYTE-SEP[, NIBBLE-SEP ]]]) +sub binf { + my $int = shift; + my $out_wid = shift || 32; + my $byte_sep = shift || ' '; + my $nib_sep = shift || ''; + my @bin = (); + + my $conv_tot_wid = int (( $out_wid + 7 ) / 8 ) * 8; + my $conv_cur_wid = 0; + while ( $conv_cur_wid < $conv_tot_wid ) { + my $byte = unpack ( 'B8', chr ( $int & 0xFF )); + unshift ( @bin, substr ( $byte, 0, 4 ).$nib_sep.substr ( $byte, 4 )); + $int >>= 8; + $conv_cur_wid += 8; + } + my $trunc = $conv_tot_wid - $out_wid; + if ( $trunc > 3 ) { + $trunc += length ( $nib_sep ); + } + $bin[ 0 ] = substr ( $bin[ 0 ], $trunc ); + return join ( $byte_sep, @bin ); +} + +# snips_read_file ( FILE[, QUIET] ) +sub snips_read_file { + my $file = shift; + my $quiet = shift; + local ( *FILE ); + my $snip_txt = ''; + my $sv_rs= $/; + $@ = ''; + if ( $file eq '-' ) { + undef $/; + $snip_txt = <>; + } else { + my $prefix = '<'; + if ( $file =~ m/[|][ \t\r\n]*$/so) { + $prefix = ''; + } + if ( !open ( FILE, $prefix.$file )) { + $@ = sprintf("could not open file `%s`", $file); + snip_msg ( "warning: %s\n", $@ ) unless $quiet; + return $snip_txt; + } + undef $/; + $snip_txt = ; + close ( FILE ); + } + $/ = $sv_rs; + return $snip_txt; +} + +sub snip_comment { + my $str = shift; + if ( !$str ) { + return $str; + } + my $pfx = $SNIPS_COMMENT_START_SEP; + my $sfx = $SNIPS_COMMENT_END_SEP; + if ( !$pfx && !$sfx ) { + return $str; + } + my $head = ''; + my $body = $str; + my $tail = ''; + if ( $str =~ m,^\n+,so ) { + $head = $&; + $body = $'; + } + if ( $body =~ m,\n+$,so ) { + $body = $`; + $tail = $&; + } + if ( !$body ) { + return $str; + } + $body =~ s,\n+,$sfx\n$pfx,sg; + return $head.$pfx.$body.$sfx.$tail; +} + +sub snip_commentf { + my $format = shift; + return snip_comment ( sprintf ( $format, @_ )); +} + +my $snip_capture_stack = []; +my $snip_capture_context = [ 0, '']; + +sub snip_capture_start { + my $text = $snip_capture_context->[1]; + push(@{$snip_capture_stack}, $snip_capture_context ); + $snip_capture_context = [ 1, '']; + return $text +} + +sub snip_capture_stop { + my $text = $snip_capture_context->[1]; + $snip_capture_context = pop(@{$snip_capture_stack}); + return $text +} + +sub snip_msg { + my $msg = snip_commentf ( @_ ); + $snip_capture_context->[1] .= $msg; + if (!$snip_capture_context->[0]) { + print $msg_output $msg; + } +} + +sub snip_mtag { + return snip_tag(@_); + my $add = shift || ''; + if ( $add ) { + $add = ' '.$add; + } + return ( "||--snip--||".$add ); +} + +sub snip_mtagf { + my $format = shift; + return snip_mtag ( sprintf ( $format, @_ )); +} + +sub snip_ptag { + my $add = shift || ''; + if ( $add ) { + $add = ' '.$add; + } + return ( $double_bar."<-snap->".$double_bar.$add ); +} + +sub snip_ptagf { + my $format = shift; + return snip_ptag ( sprintf ( $format, @_ )); +} + +sub snip_tag { + my $add = shift || ''; + if ( $add ) { + $add = ' '.$add; + } + return ( $double_bar."<-snip->".$double_bar.$add ); +} + +sub snip_tagf { + my $format = shift; + return snip_tag ( sprintf ( $format, @_ )); +} +sub snip_tag_start { + my $add = shift; + if ( $add ) { + $add = ' '.$add; + } + return snip_comment + ( snip_tagf + ( "%s %s%s\n", + 'start', + strftime( "%Y-%m-%d %H:%M:%S", localtime ( time())), + $add )); +} + +sub snip_tag_stop { + return snip_comment ( snip_tagf ( "%s\n", 'stop' )); +} + +sub snip_tag_include { + my $file = shift || ''; + return snip_comment ( snip_ptagf ( "%s %s\n", 'include', $file )); +} + +sub snip_escape { + local ( $_ ) = shift; + s,^(($comment_start_skip_rx) *|)($double_bar_rx[|<])(\\*)([-:]snip[-:][>|]($double_bar_rx)[ \t\r]*(start|stop)([ \t\r]|$)),$1$3\\$4$5,mog; + return $_; +} + +sub snip_unescape { + local ( $_ ) = shift; + s,^(($comment_start_skip_rx) *|)($double_bar_rx[|<])\\(\\*)([-:]snip[-:][>|]($double_bar_rx)[ \t\r]*(start|stop)([ \t\r]|$)),$1$3$4$5,mog; + return $_; +} + +# |||:sec:||| string replacements +my $snip_replace_cache_rx = ''; +my $snip_replace_cache_last_rx = ''; +sub snip_is_replacement_defined { + my $key = shift; + return exists ( $SNIPS_REPLACEMENTS->{$key} ); +} + +sub snip_get_replacement { + my $key = shift; + my $default = shift; + my $val; + if ( snip_is_replacement_defined($key)) { + $val = $SNIPS_REPLACEMENTS->{$key}; + } else { + $val = $default; + } + return $val; +} + +sub snip_set_replacement { + my $key = shift; + my $val = shift; + my $no_overwrite = shift; + if ( !$no_overwrite || !snip_is_replacement_defined($key)) { + if ( defined($val) && $key eq $val ) { + # no recursion! + delete ( $SNIPS_REPLACEMENTS->{$key} ); + } else { + $SNIPS_REPLACEMENTS->{$key} = $val; + } + } + $snip_replace_cache_rx = ''; + return; +} + +sub snip_del_replacement { + my $key = shift; + delete ( $SNIPS_REPLACEMENTS->{$key} ); + $snip_replace_cache_rx = ''; +} + +sub snip_set_user_replacement { + my $key = shift; + my $val = shift; + my $no_overwrite = shift; + if ( !$no_overwrite || !snip_is_replacement_defined($key)) { + if ( $key eq $val ) { + # no recursion! + delete ( $SNIPS_REPLACEMENTS_USER->{$key} ); + } else { + $SNIPS_REPLACEMENTS_USER->{$key} = $val; + } + } + snip_set_replacement($key, $val, $no_overwrite); + return; +} + +sub snip_normalize_at_key { + my $nkey = shift; + $nkey =~ s,^\@,,so; + $nkey =~ s,\@$,,so; + return ( '@'.$nkey.'@', $nkey ); +} + +sub snip_is_at_replacement_defined { + my $key = shift; + return snip_is_replacement_defined ( '@'.$key.'@', @_ ); +} + +sub snip_get_at_replacement { + my $key = shift; + return snip_get_replacement ( '@'.$key.'@', @_ ); +} + +sub snip_set_at_replacement { + my $key = shift; + return snip_set_replacement ( '@'.$key.'@', @_ ); +} + +sub snip_del_at_replacement { + my $key = shift; + snip_del_replacement('@'.$key.'@'); +} + +sub snip_set_user_at_replacement { + my $key = shift; + return snip_set_user_replacement ( '@'.$key.'@', @_ ); +} + +sub snip_replacements_dump { + my $replacements = shift || $SNIPS_REPLACEMENTS; + my $replacements_rx = shift; + if ( !defined ( $replacements_rx )) { + $replacements_rx = snip_replace_rx(); + } + if ($replacements_rx) { + snip_msg ( " :RPX: %-*s: [%s]\n", $dbg_fwid || 15, 'snip_replace_rx', + snip_fmt_rx ( $replacements_rx )); + } + foreach my $key (sort { + my $r = lc($a) cmp lc($b); + if ($r == 0) { + $r = $a cmp $b; + } + ; + $r; + } (keys ( %{$replacements} ))) { + my $value = $replacements->{$key}; + snip_msg ( " :RPD: %-*s: [%s]\n", $dbg_fwid || 15, $key, + dbg_flatten_str(defined($value) ? $value : '<<>>')); + } +} + +sub snip_replace_rx_invalidate { + $snip_replace_cache_rx = ''; + return; +} + +sub snip_replace_rx { + if ( !$snip_replace_cache_rx ) { + $snip_replace_cache_rx = + ( '(' + .join ( '|', + map { + s,([^0-9A-Za-z]),\\$1,sog; + $_; + } sort(keys ( %{$SNIPS_REPLACEMENTS} ))) + .')' ); + if ($snip_replace_cache_rx ne $snip_replace_cache_last_rx) { + $snip_replace_cache_last_rx = $snip_replace_cache_rx; + snip_replacements_dump($SNIPS_REPLACEMENTS, $snip_replace_cache_rx) + if $DEBUG > 4; + } + } + return $snip_replace_cache_rx; +} + +sub snip_fmt_rx { + local ( $_ ) = shift; + my $indent = shift || ( $dbg_fwid || 15 ) + 3 + 8; + my $istr = sprintf ( "%-*s", $indent,'' ); + my $fmt = ''; + while ( length ( $_ ) > 60 ) { + my $pre = substr ( $_, 0, 60 ); + $_ = substr ( $_, 60 ); + if ( $pre =~ m/[|][^|]+$/so ) { + $_ = $&.$_; + $pre = substr ( $pre, 0, 60 - length ( $& )); + } + $fmt .= $pre."\n".$istr; + } + return $fmt.$_ +} + +my $snip_symbol_rx = '[:a-zA-Z_][-0-9a-zA-Z_]*'; + +sub snip_replace_quoted_no_warn { + local ( $_ ) = shift; + if ( m/(\@)\|(\|*$snip_symbol_rx\@)/so ) { + my $pre = $`; + my $unquoted = $1.$2; + my $post = $'; + return $pre.$unquoted.snip_replace_quoted_no_warn($post); + } + return $_; +} + +sub snip_replace_quoted { + local $SIG{__WARN__} = sub {}; + return snip_replace_quoted_no_warn(@_); +} + +sub snip_replace__ { + local ( $_ ) = shift; + my $snip_replace_rx = snip_replace_rx(); + my $res = ''; + # do not add `o` to match options! + while ( m/$snip_replace_rx/s ) { + # |:todo:| watch out for recursion + my $key = $1; + my $rpl = snip_get_replacement($key); + if ( !defined ( $rpl )) { + snip_msg ( "warning: undefined replacement [%s]\n", $1 || '' ) + if $DEBUG; + snip_replacements_dump($SNIPS_REPLACEMENTS, $snip_replace_rx); + $res .= $`.$key; + $_ = $'; + next; + } + $_ = $`.$rpl.$'; + snip_msg ( " :RPS: %-*s => [%s]\n", + ( $dbg_fwid || 15) - 2, + $1, dbg_flatten_str($SNIPS_REPLACEMENTS->{$1})) if $DEBUG > 6; + } + return $res.$_; +} + +sub snip_replace_no_warn { + local ( $_ ) = shift; + if ( m/\@\|+($snip_symbol_rx)\@/so ) { + my $pre = $`; + my $quoted = $&; + my $post = $'; + return snip_replace_no_warn($pre).$quoted.snip_replace_no_warn($post); + } + return snip_replace__($_); +} + +sub snip_replace { + local $SIG{__WARN__} = sub {}; + return snip_replace_no_warn(@_); +} + +sub snip_is_replacement_final_defined { + my $key = shift; + return exists ( $SNIPS_REPLACEMENTS_FINAL->{$key} ); +} + +sub snip_is_at_replacement_final_defined { + my $key = shift; + return snip_is_replacement_final_defined ( '@'.$key.'@', @_ ); +} + +sub snip_get_replacement_final { + my $key = shift; + my $default = shift; + my $val; + if ( exists ( $SNIPS_REPLACEMENTS_FINAL->{$key} )) { + $val = $SNIPS_REPLACEMENTS_FINAL->{$key}; + } else { + $val = $default; + } + return $val; +} + +sub snip_set_replacement_final { + my $key = shift; + my $val = shift; + my $no_overwrite = shift; + if ( !$no_overwrite || !exists($SNIPS_REPLACEMENTS_FINAL->{$key})) { + if ( $key eq $val ) { + delete ( $SNIPS_REPLACEMENTS_FINAL->{$key} ); + } else { + $SNIPS_REPLACEMENTS_FINAL->{$key} = $val; + } + } + return; +} + +sub snip_get_at_replacement_final { + my $key = shift; + return snip_get_replacement_final ( '@'.$key.'@', @_ ); +} + +sub snip_set_at_replacement_final { + my $key = shift; + return snip_set_replacement_final ( '@'.$key.'@', @_ ); +} + +sub snip_replacements_save { + my $new_replacements = shift; + my $sv_replacements = $SNIPS_REPLACEMENTS; + if ( $new_replacements ) { + snip_replace_rx_invalidate(); + } else { + $new_replacements = $SNIPS_REPLACEMENTS; + } + $SNIPS_REPLACEMENTS = { %{$new_replacements} }; + return $sv_replacements; +} + +sub snip_replacements_restore { + my $sv_replacements = shift; + my $old_replacements = $SNIPS_REPLACEMENTS; + $SNIPS_REPLACEMENTS = $sv_replacements; + snip_replace_rx_invalidate(); + return $old_replacements; +} + +sub snip_replace_final { + local ( $_ ) = shift; + if ( !$opt_no_final) { + my $sv_replacements = snip_replacements_save + ($SNIPS_REPLACEMENTS_FINAL); + $_ = snip_replace_quoted(snip_replace($_)); + snip_replacements_restore($sv_replacements); + } + return $_; +} + +sub snip_rpl_context_open { + my $export = shift; + my $import = shift; + my $replacements = shift || {{}, {}, {}}; + my $replacements_nx = shift || {{}, {}}; + + if ( !defined ( $export )) { + $export = 1; + } + if ( !defined ( $import )) { + $import = 1; + } + my $replacements_del = $replacements->[0]; + my $replacements_rst = $replacements->[1]; + my $replacements_add = $replacements->[2]; + + my $replacements_nx_del = $replacements_nx->[0]; + my $replacements_nx_rst = $replacements_nx->[1]; + + # replacements_add set before include + # replacements_del delete after include + # replacements_rst restore after include + # replacements_nx_del delete after include + # replacements_nx_rst delete before include, restore after include + + # BEFORE INCLUDING + # export => current replacement dictionary is populated + # !export => current replacement dictionary is empty + # + # - set replacements_add + # - delete replacements_nx_rst + # + # AFTER INCLUDING + # !import => just restore sv_replacements + # import => + # - with include replacements still active + # - delete replacements_del + # - restore replacements_rst + # - delete replacements_nx_del + # - restore replacements_nx_rst + # - set replacements_import from snip_replacements_restore(). + # - set replacements from replacements_import + + my $replacements_add_use = {}; + + foreach my $key (sort(keys(%{$replacements_add}))) { + my $value = $replacements_add->{$key}; + if ( !$value ) { + $value = ''; + } else { + $value = snip_replace($value); + $value = snip_replace_quoted($value); + } + $replacements_add_use->{$key} = $value; + } + $replacements_add = $replacements_add_use; + $replacements = [ @{$replacements}]; + $replacements->[2] = $replacements_add; + + my $sv_replacements; + if ( $export ) { + $sv_replacements = snip_replacements_save(); + } else { + $sv_replacements = snip_replacements_save({}); + } + + my $rpl_context = [$export, $import, $replacements, $replacements_nx, $sv_replacements]; + + foreach my $key (sort(keys(%{$replacements_add}))) { + my $value = $replacements_add->{$key}; + snip_set_at_replacement($key, $value); + snip_msg ( " ".":RPI: %-*s: [%s] => [%s]\n", $dbg_fwid || 15, + "temp set", $key || '', dbg_flatten_str($value)) + if $DEBUG > 4; + } + foreach my $key (sort(keys(%{$replacements_nx_rst}))) { + snip_del_at_replacement($key); + snip_msg ( " ".":RPI: %-*s: [%s]\n", $dbg_fwid || 15, + "nrst del", $key || '' ) + if $DEBUG > 4; + } + #snip_replace_rx_invalidate(); # |:check:| should not be necessary + + return $rpl_context; +} + +sub snip_rpl_context_open_from_options { + my $options = shift; + return snip_rpl_context_open + ( + exists($options->{'export'}) ? + $options->{'export'}->[1]->[0] : 1, + exists($options->{'import'}) ? + $options->{'import'}->[1]->[0] : 1, + exists($options->{'#subst#'}) ? + $options->{'#subst#'}->[1] : {{}, {}, {}}, + exists($options->{'#undef#'}) ? + $options->{'#undef#'}->[1] : {{}, {}}, + ); +} + +sub snip_rpl_context_close { + my $rpl_context = shift;; + + my $export = $rpl_context->[0]; + my $import = $rpl_context->[1]; + my $replacements = $rpl_context->[2]; + my $replacements_nx = $rpl_context->[3]; + my $sv_replacements = $rpl_context->[4]; + + my $replacements_del = $replacements->[0]; + my $replacements_rst = $replacements->[1]; + my $replacements_add = $replacements->[2]; + + my $replacements_nx_del = $replacements_nx->[0]; + my $replacements_nx_rst = $replacements_nx->[1]; + + if ( !$import ) { + snip_replacements_restore($sv_replacements); + snip_msg ( " ".":RPI: %-*s: [%s]\n", $dbg_fwid || 15, + "no import", '' || '' ) + if $DEBUG > 4; + } else { + # delete temporary replacements + foreach my $key ( sort(keys(%{$replacements_del}))) { + snip_del_at_replacement($key); + snip_msg ( " ".":RPI: %-*s: [%s]\n", $dbg_fwid || 15, + "temp del", $key || '' ) + if $DEBUG > 4; + } + # restore temporary replacements + foreach my $key ( sort(keys(%{$replacements_rst}))) { + my $value = $replacements_rst->{$key}; + snip_set_at_replacement($key, $value); + snip_msg ( " ".":RPI: %-*s: [%s] => [%s]\n", $dbg_fwid || 15, + "temp rst", $key || '', dbg_flatten_str($value)) + if $DEBUG > 4; + } + # delete noexport replacements + foreach my $key ( sort(keys(%{$replacements_nx_del}))) { + snip_del_at_replacement($key); + snip_msg ( " ".":RPI: %-*s: [%s]\n", $dbg_fwid || 15, + "nexp del", $key || '' ) + if $DEBUG > 4; + } + # restore noexport replacements + foreach my $key ( sort(keys(%{$replacements_nx_rst}))) { + my $value = $replacements_nx_rst->{$key}; + snip_set_at_replacement($key, $value); + snip_msg ( " ".":RPI: %-*s: [%s] => [%s]\n", $dbg_fwid || 15, + "nexp rst", $key || '', dbg_flatten_str($value)) + if $DEBUG > 4; + } + # import new settings into old replacements + my $replacements_import = + snip_replacements_restore($sv_replacements); + foreach my $key ( sort(keys(%{$replacements_import}))) { + my @nkeys = snip_normalize_at_key($key); + my $akey = $nkeys[0]; + my $nkey = $nkeys[1]; + my $value = $replacements_import->{$akey}; + my $prev_known = snip_is_at_replacement_defined($nkey); + my $prev_value = snip_get_at_replacement($nkey); + snip_set_at_replacement($nkey, $value); + if ( !$prev_known || ( $prev_value || '' ) ne ( $value || '' )) { + snip_msg ( " ".":RPI: %-*s: [%s] => [%s]\n", $dbg_fwid || 15, + sprintf(">>')) + if $DEBUG > 4; + } + } + } + #snip_replace_rx_invalidate(); # |:check:| should not be necessary + + return; +} + +# |||:sec:||| configuration and setup +sub snip_handle_shortcut { + my $sc = shift; + my $opt_only = shift; + # :shortcut: + if ( $prog_name eq 'snh' ) { + if ( !$opt_only ) { + usage( *STDOUT ); + exit ( 0 ); + } + } elsif ( $sc eq 'snl' ) { + $opt_list = 1; + $cmd_seen = 1; + $opt_name_rx = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snl --list' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'sng' ) { + $opt_grep = 1; + $cmd_seen = 1; + @opt_grep_opts = @ARGV if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snl --list' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'sni' ) { + $opt_list = 1; + $cmd_seen = 1; + $opt_as_includes = 1; + $opt_name_rx = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'sni --as-includes --list' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'snc' ) { + $opt_cat = 1; + $cmd_seen = 1; + $opt_name_rx = shift ( @ARGV ) if !$opt_only; + $opt_temp_snippet = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snc --cat' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'snr' ) { + $opt_cat = 1; + if ( !$opt_no_replace_seen ) { + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + } + if ( !$opt_no_process_seen ) { + $opt_process = 1; + $opt_process_seen = 1; + $opt_no_process_seen = 0; + } + $cmd_seen = 1; + $opt_name_rx = shift ( @ARGV ) if !$opt_only; + $opt_temp_snippet = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snr --replace --process --cat' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'snn' ) { + $opt_new = 1; + if ( !$opt_no_replace_seen ) { + $opt_replace = 1; + $opt_replace_seen = 1; + $opt_no_replace_seen = 0; + } + if ( !$opt_no_process_seen ) { + $opt_process = 1; + $opt_process_seen = 1; + $opt_no_process_seen = 0; + } + $cmd_seen = 1; + $opt_filename = shift ( @ARGV ) if !$opt_only; + $opt_name = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snn --replace --process --new' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'sna' ) { + $opt_append = 1; + $cmd_seen = 1; + $opt_name = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'sna --append' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'sns' ) { + $opt_store = 1; + $cmd_seen = 1; + $opt_name = shift ( @ARGV ) if !$opt_only; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'sns --stor' || '' ) if $DEBUG > 4; + } elsif ( $sc eq 'snw' ) { + $opt_work = 1; + $cmd_seen = 1; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "cmd_seen", 'snw --work' || '' ) if $DEBUG > 4; + } + return; +} + +sub snip_consolidate_modes { + foreach my $mode ( keys ( %{$SNIPS_MODES} )) { + my $mode_defs = $SNIPS_MODES->{$mode}; + my $mode_cat_defs = $mode_defs->[ $snm_indx_cat ]; + if ( !ref ( $mode_cat_defs )) { + $mode_cat_defs = [ $mode_cat_defs ]; + $mode_defs->[ $snm_indx_cat ] = $mode_cat_defs; + } + + my $comment_defs = $mode_defs->[ $snm_indx_comm ]; + if ( !ref ( $comment_defs )) { + $comment_defs = [ $comment_defs ]; + $mode_defs->[ $snm_indx_comm ] = $comment_defs; + } + + my $comment_start = $comment_defs->[ 0 ]; + my $comment_start_skip = $comment_defs->[ 1 ]; + my $comment_end = $comment_defs->[ 2 ]; + if ( !$comment_start_skip ) { + $comment_start_skip = $comment_start; + $comment_start_skip =~ s,([^0-9A-Za-z]),\\$1,sog; + $comment_start_skip .= ( length ( $comment_start ) == 1 ? '+' : ''); + $comment_defs->[ 1 ] = $comment_start_skip; + } + if ( !$comment_end ) { + $comment_defs->[ 2 ] = ''; + } else { + my $comment_end_skip = $comment_defs->[ 3 ]; + if ( !$comment_end_skip ) { + $comment_end_skip = $comment_end; + $comment_end_skip =~ s,([^0-9A-Za-z]),\\$1,sog; + $comment_defs->[ 3 ] = $comment_end_skip; + } + } + + my $new_snippet = $mode_defs->[ $snm_indx_new ]; + if ( !$new_snippet ) { + $mode_defs->[ $snm_indx_new ] = $mode_cat_defs->[ 0 ].'_new'; + } + } +} + +sub snip_default_mode { + my $mode = shift || $SNIPS_MODE || $SNIPS_CAT || $SNIPS_DEF_MODE; + if ( !exists ( $SNIPS_MODES->{$mode} )) { + snip_add_mode ( $mode => [ $SNIPS_DEF_MODE, + [ $mode, + $SNIPS_CAT + || $SNIPS_MODES->{$SNIPS_DEF_MODE}->[ $snm_indx_cat ]->[ 0 ], + ], + $SNIPS_MODES->{$SNIPS_DEF_MODE}->[ $snm_indx_comm ], + $SNIPS_MODES->{$SNIPS_DEF_MODE}->[ $snm_indx_hf ], + ]); + $SNIPS_MODES->{$mode}->[ $snm_indx_new ] = + $SNIPS_MODES->{$mode}->[ $snm_indx_cat ]->[ 0 ].'_new'; + } + return $mode; +} + +sub snip_add_mode { + my $mode = shift; + my $def = shift; + my $set_emacs_mode = shift; + my $new_snippet = shift; + if ( ref ( $mode )) { + $def = $mode; + $mode = $def->[ $snm_indx_mode ]; + } elsif ( !ref ( $def )) { + snip_default_mode ( $def ); + $def = [ @{$SNIPS_MODES->{$def}} ]; + } + if ( $set_emacs_mode ) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "set emacs mode", $mode || '' ) + if $DEBUG > 5; + $def->[ $snm_indx_mode ] = $mode; + } + if ( $new_snippet ) { + $def->[ $snm_indx_new ] = $new_snippet; + } + $SNIPS_MODES->{$mode} = $def; + return $def; +} + +sub snip_setup_comments { + if ( $SNIPS_COMMENT_START && !$SNIPS_COMMENT_START_SKIP ) { + die "SNIPS_COMMENT_START_SKIP missing"; + } + if ( $SNIPS_COMMENT_END && !$SNIPS_COMMENT_END_SKIP ) { + die "SNIPS_COMMENT_END_SKIP missing"; + } + if ( !$SNIPS_COMMENT_START_SEP ) { + $SNIPS_COMMENT_START_SEP = $SNIPS_COMMENT_START ? $SNIPS_COMMENT_START.' ' : ''; + } + if ( !$SNIPS_COMMENT_END_SEP ) { + $SNIPS_COMMENT_END_SEP = $SNIPS_COMMENT_END ? ' '.$SNIPS_COMMENT_END : ''; + } + snip_set_at_replacement ( 'comm', $SNIPS_COMMENT_START ); + snip_set_at_replacement ( 'comme', $SNIPS_COMMENT_END ); + snip_set_at_replacement ( 'comm_', $SNIPS_COMMENT_START_SEP ); + snip_set_at_replacement ( '_comm', $SNIPS_COMMENT_END_SEP ); + + # |:info:| new comment syntax + snip_set_at_replacement ( ':comm', $SNIPS_COMMENT_START ); + snip_set_at_replacement ( ':comme', $SNIPS_COMMENT_END ); + snip_set_at_replacement ( ':comm_', $SNIPS_COMMENT_START_SEP ); + snip_set_at_replacement ( ':_comm', $SNIPS_COMMENT_END_SEP ); + # block line comment + if ( $SNIPS_COMMENT_END ) { + snip_set_at_replacement ( 'bcomm', '@:comm@' ); + snip_set_at_replacement ( 'bcomme', '@:comme@' ); + snip_set_at_replacement ( 'bcomm_', '@:comm@'."\n".'@:lcomm_@' ); + snip_set_at_replacement ( '_bcomm', "\n".'@:comme@' ); + snip_set_at_replacement ( 'lcomm', '' ); + snip_set_at_replacement ( 'lcomm_', '' ); + + # |:info:| new comment syntax + snip_set_at_replacement ( ':bcomm', '@:comm@' ); + snip_set_at_replacement ( ':bcomme', '@:comme@' ); + snip_set_at_replacement ( ':bcomm_', '@:comm@'."\n".'@:lcomm_@' ); + snip_set_at_replacement ( ':_bcomm', "\n".'@:comme@' ); + snip_set_at_replacement ( ':lcomm', '' ); + snip_set_at_replacement ( ':lcomm_', '' ); + } else { + snip_set_at_replacement ( 'bcomm', '@:lcomm@' ); + snip_set_at_replacement ( 'bcomme', '@:comme@' ); + snip_set_at_replacement ( 'bcomm_', '@:lcomm_@'); + snip_set_at_replacement ( '_bcomm', '@:_comm@' ); + snip_set_at_replacement ( 'lcomm', '@:comm@' ); + snip_set_at_replacement ( 'lcomm_', '@:comm_@' ); + + # |:info:| new comment syntax + snip_set_at_replacement ( ':bcomm', '@:lcomm@' ); + snip_set_at_replacement ( ':bcomme', '@:comme@' ); + snip_set_at_replacement ( ':bcomm_', '@:lcomm_@'); + snip_set_at_replacement ( ':_bcomm', '@:_comm@' ); + snip_set_at_replacement ( ':lcomm', '@:comm@' ); + snip_set_at_replacement ( ':lcomm_', '@:comm_@' ); + } +} + +my $DEBUG_CMC = 50; +my $DEBUG_CMC1 = 50; +my $DEBUG_CMC2 = 50; + +my $protection = 0; + +sub snip_split_lines { + local($_) = shift || ''; + my $lines = [split(/\n/, $_."@")]; + my $last = pop(@{$lines}); + push(@{$lines}, substr($last, 0, -1)); + return $lines; +} + +package Snippet; # |:here:| + +use vars qw(@ISA); + +@ISA = ('Line'); + +# new(TEXT, LINENO) +sub new { + # First parameter is a class name or blessed hash ref + my $class = shift; + + if ( ref( $class ) ne '' ) { + $class = ref( $class ); + # MyBaseClass::new($self, @_ ); + # + } + + my $self = + { + 'type' => undef, + }; + + # use my own methods, not the parent's + bless $self; + + self->init( @_ ); + + bless $self, $class; + return $self; +} + +sub __iter__ { + my $self = shift; + $self->{'indx'} = 0; + return $self; +} + +sub next { + my $self = shift; + my $indx = $self->{'indx'}; + my $snippets = $self->{'snippets'}; + if ($indx >= scalar(@{$snippets} )) { + return undef; + } + $self->{'indx'} += 1; + return $snippets->[$indx]; +} + +# text, lineno +sub init { + my $self = shift; + my $text = shift; + my $lineno = shift; + $self->setText($text); + $self->setLineNo($lineno); + $self->{'lines'} = []; + $self->{'snippets'} = []; + $self->{'indx'} = 0; +} + +# lineno +sub setLineNo { + my $self = shift; + my $lineno = shift || 0; + $self->{'lineno'} = $lineno; +} + +# text +sub setText { + my $self = shift; + my $text = shift || ''; + $self->{'text'} = $text; + return $self; +} + +# () +sub split { + my $self = shift; + my $text = $self->{'text'}; + my $lines = $self->{'lines'} = snip_split_lines($text); + return $lines; +} + +# SNIPPET = append () +sub append { + my $self = shift; + my $snippet = shift; + if ( !defined ( $snippet )) { + $snippet = new Snippet(); + } + push(@{$self->{'snippets'}}, $snippet); + return $snippet; +} + +sub dumpSnippets { + my $self = shift; + my $it = $self->__iter__(); + my $snippet; + while (defined($snippet = $it->next())) { + $snippet->dump(); + } + return; +} + +sub dump { + my $self = shift; + my $indx = 0; + foreach my $line (@{$self->{'lines'}}) { + snip_msg( " ".":CHK: %-*s: [%s]\n", $dbg_fwid || 15, sprintf("line %3d", $indx), $line || ''); + } + $self->dumpSnippets(); +} + +package SnippetChunkers; # |:here:| + +use vars qw(@ISA); + +@ISA = ('Snippet'); + +package SnippetContext; # |:here:| + +use vars qw(@ISA); + +@ISA = ('Snippet'); + +# new SnippetContext( TEXT, MODE, CHUNKERS, MODES ) +sub new { + # First parameter is a class name or blessed hash ref + my $class = shift; + if ( ref( $class ) ne '' ) { + $class = ref( $class ); + } + + my $text = shift; + my $self; + $self = new Snippet(undef, $text); + bless $self; + + my $mode = shift || 'generic'; + my $chunkers = shift || []; + my $modes = shift || {'generic' => []}; + + $self->{'mode'} = $mode; + $self->{'chunkers'} = $chunkers, + $self->{'modes'} = $modes; + $self->{'cindx'} = 0; + + my $cdict = {}; + foreach my $chunker (@{$chunkers}) { + $cdict->{$chunker->[0]} = $chunker; + } + + $self->{'cdict'} = $cdict; + + # |:todo:| init + bless $self, $class; + return $self; +} + +# snip_it(TEXT|BLOCK) +sub snip_it { + my $self = shift; + # chunkers, snippetder_indx ... + + my $text = $_[0]; + + if ( !defined ( $self )) { + $self = new SnippetContext(undef, @_); + } else { + $self->{'block'}->{'text'} = $text; + } + $self->{'text'} = $self->{'block'}->{'text'}; + my $indx; + while (1) { + my $cindx = $self->{'cindx'}++; + my $chunkers = $self->{'chunkers'}; + if ($cindx >= scalar(@{$chunkers})) { + last; + } + while ( 1 ) { + my $chunker = $chunkers->[$cindx]; # may be volatile! + my $result = &{$chunker->[1]} + ( + $chunker, + $self, # fixed + $cindx, # fixed + $self->{'chunkers'}); # may be, but should not be volatile + $self->{'result'} = $result; + if ( $result < 0 ) { + return $self; + } + if ( $result > 0 ) { + last; + } + } + } + return $self; +} + +package main; # |:here:| + +# |:here:| +my $snip_chunkers = + [ + [ 'name', \&snip_chunker_block_comments, 'data' ], + ]; + +# |:here:| +sub snip_chunker_block_comments { + my $self = shift; + my $context = shift; + my $cindx = shift; + my $chunkers = shift; + + my $block = $context->{'block'}; + local ( $_ ) = $context->{'text'}; + + my $css_in = $self->[2] || $SNIPS_COMMENT_START_SKIP; + my $ces_in = $self->[3] || $SNIPS_COMMENT_END_SKIP; + my $comment_syntax = $self->[4] || $context->{'mode'}->[$snm_indx_comm]; + + my $converted = ''; + + # Setup Comment syntax. + + my $gen_ss = '\@:[b]?comm_?\@'; + my $gen_es = '\@:(_b?comm|b?comme)\@'; + my $gen_ls = '\@:lcomm\@'; + + # we may be dealing with partial comments here, so determine + # the first block comment start or end. + + my $in_comment = 0; + my $have_comm = 0; + + my $snippets = []; + $block->{'snippets'} = $snippets; + + # |:here:| + # something */ with more text + # */ + # something /* with more text + # something /* with more text */ and still more ... + + if (m/($gen_ss)|$gen_es/so) { + my $snippet; + $snippet = new Snippet(); + + $have_comm = 1; + $block->{'have_comm'} = $have_comm; + + # comment end found before comment start + $in_comment = !defined( $1 ); + $block->{'in_comment'} = $in_comment; + + $snippet->{'is_comment'} = $in_comment; + + my $part = $`; + my $css = $&; + local( $_ ) = $'; + + $snippet->{'text'} = $part; + + my $indents = ''; + my $indent = 0; + + # determine indent + if ($part =~ s,(\n)([^\n]*)$,,sog) { + $indents = $2; + $part = $`.$1; + $indent = length($indents); + } + + $snippet->{'indent'} = $indent; + my $lines = snip_split_lines($part); + $snippet->{'lines'} = $lines; + + $indents =~ s/([ \t\r]+)$//sog; + if ($indents) { + push(@{$lines},$indents); + } + + } + + return 1; + + my $in_block = 0; + + # - convert everything to line blocks + # - keeping indendation of the block comment starter + # or the block comment ender for partial comments. + + while ($have_comm) { + if (!$in_block) { + if (m/$gen_ss/so) { + my $part = $`; + my $css = $&; + $_ = $'; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "gen_ss", $gen_ss || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "css", $css || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + # make all line comments block comments + $part =~ s,$gen_ls([^\n]*),'@:comm@'.($1||'').'@:comme@',esog; + $converted .= $part.$css; + $in_block = 1; + } else { + # non-block trailer + last; + } + } + if ($in_block) { + if (m/$gen_es/so) { + my $part = $`; + my $ces = $&; + $_ = $'; + + # remove all stray comment starters in block range + $part =~ s,$gen_ss,,sog; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "gen_es", $gen_es || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "ces", $ces || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + + # remove all line comments in block range + $part =~ s,$gen_ls,,sog; + $converted .= $part.$ces; + $in_block = 0; + } else { + # unterminated comment + snip_msg ( " ".":CMC: unterminated block comment") + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ); + last; + } + } + } + + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + "conv: cleanup done", dbg_flatten_str($_) || '' ) + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ); + + return $converted . $_; +} + +sub snip_cmc_generic_prepare { + local ( $_ ) = shift; + my $css_in = shift || $SNIPS_COMMENT_START_SKIP; + my $ces_in = shift || $SNIPS_COMMENT_END_SKIP; + my $converted = ''; + + # special preparations for generic comments + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + "conv: cleanup setup", dbg_flatten_str($_) || '' ) + if $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1; + if ( $protection > 5 ) { + die 'endless loop!'; + } + $protection += 1; + $converted = ''; + + my $gen_compat = '@:?(_?[bl]?comm(_|e)?)@'; + s,$gen_compat,\@:$1\@,sog; + + my $gen_spc_stl = '\@:lcomm_\@'; + s,$gen_spc_stl,\@:lcomm\@ ,sog; + + my $gen_ss = '\@:[b]?comm_?\@'; + my $gen_es = '\@:(_b?comm|b?comme)\@'; + my $gen_ls = '\@:lcomm\@'; + + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + "conv: cleanup prep done", dbg_flatten_str($_) || '' ) + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ); + + # we may be dealing with partial comments here, so determine + # the first block comment start or end. + + if (m/($gen_ss)|$gen_es/so) { + my $in_block = !defined( $1 ); + while (1) { + if (!$in_block) { + if (m/$gen_ss/so) { + my $part = $`; + my $css = $&; + $_ = $'; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "gen_ss", $gen_ss || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "css", $css || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + # make all line comments block comments + $part =~ s,$gen_ls([^\n]*),'@:comm@'.($1||'').'@:comme@',esog; + $converted .= $part.$css; + $in_block = 1; + } else { + # non-block trailer + last; + } + } + if ($in_block) { + if (m/$gen_es/so) { + my $part = $`; + my $ces = $&; + $_ = $'; + + # remove all stray comment starters in block range + $part =~ s,$gen_ss,,sog; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "gen_es", $gen_es || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "ces", $ces || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + + # remove all line comments in block range + $part =~ s,$gen_ls,,sog; + $converted .= $part.$ces; + $in_block = 0; + } else { + # unterminated comment + snip_msg ( " ".":CMC: unterminated block comment") + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ); + last; + } + } + } + } + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + "conv: cleanup done", dbg_flatten_str($_) || '' ) + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ); + + return $converted . $_; +} + +sub snip_cmc_generic_replace { + local ( $_ ) = shift; + + # convert generic comments to current mode + my $gen_rpl = {}; + my $gen_comms = + [ + ':comm', + ':comme', + ':comm_', + ':_comm', + ':bcomm', + ':bcomme', + ':bcomm_', + ':_bcomm', + ':lcomm', + ':lcomm_', + ]; + foreach my $gen_comm (@{$gen_comms}) { + my $rpl = snip_get_at_replacement($gen_comm, undef); + if ( defined ( $rpl )) { + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + sprintf("rpl %s", $gen_comm), $rpl || '' ) + if $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1; + $gen_rpl->{$gen_comm} = $rpl; + } else { + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + sprintf("rpl %s", $gen_comm), '<<>>' || '' ) + if $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1; + } + } + my $sv_replacements = snip_replacements_save(); + foreach my $gen_comm (keys(%{$gen_rpl})) { + snip_set_at_replacement($gen_comm, $gen_rpl->{$gen_comm}); + } + $_ = snip_replace($_); + snip_replacements_restore($sv_replacements); + + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, + "conv: replacement done", dbg_flatten_str($_) || '' ) + if $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1; + + return $_; +} + +sub snip_cmc_normalize_block { + local ( $_ ) = shift; + my $css_in = shift || $SNIPS_COMMENT_START_SKIP; + my $ces_in = shift || $SNIPS_COMMENT_END_SKIP; + + my $converted = ''; + my $comment_ws = "( |[ \t\r]*\n|)"; + my $css = $css_in.$comment_ws; + my $ces = $comment_ws.$ces_in; + while ( m/$css/s ) { + my $part = $`; + $converted .= $part; + my $cs = $&; + $_ = $'; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC2 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "css", $css || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "cs", $cs || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + + my $com = ''; + my $ce = ''; + while ( 1 ) { + if (m/$ces/s) { + my $part = $`; + $com .= $part; + $ce = $&; + $_ = $'; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC2 ) { + printf STDERR ( "%s\n", '--------------------' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "ces", $ces || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "converted", $converted || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "part", dbg_flatten_str($part) || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "ce", $ce || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "rest", dbg_flatten_str($_) || '' ); + } + } else { + last; + } + if (m/^[ \t\r]*(\n[ \t\r]*)($css)/s) { + my $sep_ws = $1; + #snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "sep_ws", $sep_ws || '' ); + $com .= $1; + $_ = $'; + next; + } + last; + } + $com =~ s,\n(([ \t]* )|)([^ \t\n]),"\n".( defined($2) ? $2.'@:lcomm_@' : '@:lcomm_@' ).$3,seog; + my $bs; + my $be; + if ($com =~ m/\n/ ) { + $bs = ($cs =~ m/( |\n)$/ ) ? '@:bcomm_@' : '@:bcomm@'; + $be = ($ce =~ m/^( |\n)/ ) ? '@:_bcomm@' : '@:bcomme@'; + } else { + $bs = ($cs =~ m/( |\n)$/ ) ? '@:comm_@' : '@:comm@'; + $be = ($ce =~ m/^( |\n)/ ) ? '@:_comm@' : '@:comme@'; + } + + $converted .= $bs.$com.$be; + } + return $converted . $_; +} + +sub snip_cmc_normalize_line { + local ( $_ ) = shift; + my $css_in = shift || $SNIPS_COMMENT_START_SKIP; + my $ces_in = shift || $SNIPS_COMMENT_END_SKIP; + + my $converted = ''; + my $comment_ws = "( |[ \t\r]*\n|)"; + my $lss = $css_in; + my $css = $css_in.$comment_ws; + while (m/$css/s) { + $converted .= $`; + my $cs = $&; + $_ = $'; + my $com = ''; + while (m/^([^\n]*[\n])/s) { + $com .= ($1||''); + $_ = $'; + if (m/^([ \t\r]*)$lss( |)/s) { + $com .= ($1||''); + $_ = $'; + next; + } + last; + } + if ( $com =~ m/\n$/ ) { + $_ = $& . $_; + $com = $`; + } + $com =~ s,\n(([ \t]* )|)([^ \t\n]),"\n".( defined($2) ? $2.'@:lcomm_@' : '@:lcomm_@' ).$3,seog; + my $bs; + my $be; + if ($com =~ m/\n/ ) { + $bs = ($cs =~ m/( |\n)$/ ) ? '@:bcomm_@' : '@:bcomm@'; + $be = ($cs =~ m/( |\n)$/ ) ? '@:_bcomm@' : '@:bcomme@'; + } else { + $bs = ($cs =~ m/( |\n)$/ ) ? '@:comm_@' : '@:comm@'; + $be = ($cs =~ m/( |\n)$/ ) ? '@:_comm@' : '@:comme@'; + } + $converted .= $bs.$com.$be; + } + return $converted . $_; + +} + +sub snip_convert_comments { + local ( $_ ) = shift; + my $css_in = shift || $SNIPS_COMMENT_START_SKIP; + my $ces_in = shift || $SNIPS_COMMENT_END_SKIP; + my $clean = shift || 0; + + my $converted = ''; + my $is_block = $css_in && $ces_in; + my $is_line = $css_in; + + if ( $DEBUG > $DEBUG_CMC || $DEBUG > $DEBUG_CMC1 ) { + snip_msg ( "%s\n", '--------------------------------------------------' ); + snip_msg ( " ".":CMC: %-*s: [%d]\n", $dbg_fwid || 15, "CONV", $clean ? 2 : 1); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "css", $css_in || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "ces", $ces_in || '' ); + } + + if ( !$clean ) { + + $_ = snip_cmc_generic_prepare($_, $css_in, $ces_in ); + + my $mode_spec = $SNIPS_MODES->{'generic'}; + my $comm_spec = $mode_spec->[$snm_indx_comm]; + + # now, normalize for generic comments + $_ = snip_cmc_normalize_block($_, $comm_spec->[1], $comm_spec->[3], 1); + + # Convert to current mode + $_ = snip_cmc_generic_replace($_); + + } + + # |:sec:| Normal comment conversion + if ( $is_block ) { + $_ = snip_cmc_normalize_block($_, $css_in, $ces_in); + } elsif ($is_line) { + $_ = snip_cmc_normalize_line($_, $css_in, $ces_in); + } + return $_; +} + +sub snip_cleanup_comments { + local ( $_ ) = shift; + if ( $SNIPS_COMMENT_START && $SNIPS_COMMENT_END ) { + my $comment_span_rx = "([ \t\r]*($SNIPS_COMMENT_END_SKIP)[ \t\r\r]*)\n([ \t\r]*($SNIPS_COMMENT_START_SKIP))"; + while ( m,$comment_span_rx,s ) { + my $elen = length ( $1 ); + my $slen = length ( $& ) - $elen - 1; + $_ = $`.sprintf ( "\n%-*s", $slen, '' ).$'; + } + } + return $_; +} + +sub check_snip_convert_comments { + + my $blk; + my $lin; + + $blk = ' +/* block comment */ +/* block comment */ +/* block comment */ + /* block comment */ + /* block comment */ + /* block comment */ + +/* +block comment +block comment +block comment +block comment +*/ + +/* block comment + block comment + block comment */ + +/* block comment */ +/* block comment */ + +/* block comment */ + +/* block comment */ +'; + + my $sep = "-----\n"; + + snip_set_mode('c'); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_COMMENT_START_SKIP", $SNIPS_COMMENT_START_SKIP || '' ); + snip_msg ( " ".":CMC: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_COMMENT_END_SKIP", $SNIPS_COMMENT_END_SKIP || '' ); + + my $conv = snip_convert_comments($blk); + print $blk."\n"; + print $sep.$conv."\n"; + my $reconv = snip_replace($conv); + print $sep.$reconv."\n"; + snip_set_mode('c++'); + my $cxx = snip_replace($conv); + print $sep.$cxx."\n"; + snip_set_mode('el'); + my $el = snip_replace($conv); + print $blk.$sep.$conv.$sep.$reconv.$sep.."\n"; + print $sep.$el."\n"; + + $conv = snip_convert_comments($el); + print $sep.$conv."\n"; + $reconv = snip_replace($conv); + print $sep.$reconv."\n"; + snip_set_mode('c++'); + $cxx = snip_replace($conv); + print $sep.$cxx."\n"; + snip_set_mode('c'); + my $c = snip_replace($conv); + print $sep.$c."\n"; + + snip_set_mode('generic'); + my $gen = snip_convert_comments($conv); + print $sep.$gen."\n"; + +} + +#check_snip_convert_comments(); exit(0); # |:debug:| + +sub snip_set_mode { + my $mode = shift; + my $main_only = shift; + + if ( !exists ( $SNIPS_MODES->{$mode} )) { + snip_default_mode ( $mode ); + } + my $mode_settings = $SNIPS_MODES->{$mode}; + my $mode_categories = $mode_settings->[ $snm_indx_cat ]; + $SNIPS_CAT = $mode_categories->[ 0 ]; + if ($SNIPS_CAT_IS_DEFAULT) { + $SNIPS_CAT_IS_DEFAULT = $SNIPS_MODE_IS_DEFAULT; + } + if ( !$opt_accept_cat_seen ) { + if ( !$main_only ) { + $opt_accept_cat_rx = "^(".join( "|", @{$mode_categories} ).")\$"; + } + } + my $comment_defs = $mode_settings->[ $snm_indx_comm ]; + $SNIPS_COMMENT_START = $comment_defs->[ 0 ]; + $SNIPS_COMMENT_START_SKIP = $comment_defs->[ 1 ]; + $SNIPS_COMMENT_END = $comment_defs->[ 2 ]; + $SNIPS_COMMENT_END_SKIP = $comment_defs->[ 3 ]; + $SNIPS_COMMENT_START_SEP = $comment_defs->[ 4 ]; + $SNIPS_COMMENT_END_SEP = $comment_defs->[ 5 ]; + snip_setup_comments(); + + snip_set_at_replacement ( 'mode', $mode_settings->[ $snm_indx_mode ]); + snip_set_at_replacement ( 'snip_mode', $mode); + + snip_msg ( " ".":DBG: %-*s: [%s] main-only: [%s]\n", + $dbg_fwid || 15, "snip_set_mode", + $mode || '', $main_only ? 'y' : 'n' ) if $DEBUG > 1; + return $mode_settings; +} + +sub snip_set_default_mode { + my $mode = snip_default_mode ( shift ); + snip_set_mode ( $mode ); + return $mode; +} + +sub snip_part_for_mode { + my $mode = snip_default_mode ( shift ); + my $part_name = shift; + my $part_template = shift; + my $part_mode_index = shift; + my $part_default = shift; + my $part_builtin = shift; + my $part = ''; + my $mode_settings = $SNIPS_MODES->{$mode}; + my $mode_pfx = $mode_settings->[ $snm_indx_cat ]->[ 0 ]; + my $inc_files = snips_find_file ( 1, 0, '^'.$mode_pfx.'_t'.$part_template.'$' ); + my $inc_file = $inc_files->[ 0 ]; + # disable uuid handler in header + my $uuid_handler = snip_tag_get_handler_copy('uuid', 0); + # printf STDERR ( "# |".":DBG:| %-*s: [%s]\n", $dbg_fwid || 15, "uuid_handler", repr($uuid_handler) || '' ); + # printf STDERR ( "# |".":DBG:| %-*s: [%s]\n", $dbg_fwid || 15, "snip_tag_get_handlers", repr(snip_tag_get_handlers()) || '' ); + $uuid_handler = snip_tag_set_handler('uuid', $uuid_handler); + # snippet ^_t$ + if ( $inc_file ) { + $part = snips_read_snippet( $inc_file, 1, 1, 1, 1 ); + } + if ($part) { + snip_msg ( " ".":HDR: %-*s: [%s] found\n", + $dbg_fwid || 15, $part_name." (mode snippet)", + $inc_file ) if $DEBUG > 1; + } + if (!$part) { + # snippet ^snip_t$ + $inc_files = snips_find_file ( 1, 0, '^snip_t'.$part_template.'$' ); + $inc_file = $inc_files->[ 0 ]; + if ( $inc_file ) { + $part = snips_read_snippet( $inc_file, 1, 1, 1, 1 ); + } + if ( $part ) { + snip_msg ( " ".":HDR: %-*s: [%s] found\n", + $dbg_fwid || 15, $part_name." (snippet)", + $inc_file ) if $DEBUG > 1; + } + } + if ( !$part ) { + my $hf_defs = $mode_settings->[ $snm_indx_hf ]; + $part = $hf_defs->[ $part_mode_index ]; + if ( $part ) { + # mode definition part + snip_msg ( " ".":HDR: %-*s: [%s] found\n", + $dbg_fwid || 15, $part_name." (mode definition)", + $mode_settings->[ $snm_indx_mode ]) if $DEBUG > 1; + } elsif ( $part_default ) { + $part = $part_default; + snip_msg ( " ".":HDR: %-*s: [%s] found\n", + $dbg_fwid || 15, $part_name, + 'default') if $DEBUG > 1; + } else { + # built-in part + $part = $part_builtin; + snip_msg ( " ".":HDR: %-*s: [%s] found\n", + $dbg_fwid || 15, $part_name, + 'built-in') if $DEBUG > 1; + } + $part = snips_process_snippet( $part, '', 1, 1, 1, 1 ); + } + snip_tag_set_handler($uuid_handler); + $part = snip_cleanup_comments($part); + { + local($opt_no_final) = 0; + $part = snip_replace_final($part); + } + return $part; +} + +my $SNIP_HEADER_BUILT_IN = <<'__EOS__'; +@:comm_@-*- @mode@ -*-@:_comm@ + +@:comm_@||<-snap->|| default title @mode@ Snippet@:_comm@ +@:comm_@||<-snap->|| title @title@@:_comm@ +@:comm_@||<-snap->|| uuid @uuid@@:_comm@ + +__EOS__ + +my $SNIP_FOOTER_BUILT_IN = <<'__EOS__'; +@:bcomm_@:ide-menu: Emacs IDE Main Menu - Buffer @BUFFER@ +@:lcomm_@. M-x `eIDE-menu' ()(eIDE-menu "z") + +@:lcomm_@:ide: SNIP: myself +@:lcomm_@. (snip-cat-mode (concat "" (buffer-file-name)) nil)@:_bcomm@@fempty@ +@:bcomm_@ +@:lcomm_@Local Variables: +@:lcomm_@mode: @mode@ +@:lcomm_@mode: snip-minor +@:lcomm_@End:@:_bcomm@@fempty@ +__EOS__ + +snip_set_at_replacement('snip_header', $SNIP_HEADER_BUILT_IN); +snip_set_at_replacement('snip_footer', $SNIP_FOOTER_BUILT_IN); + +sub snip_header_for_mode { + return snip_part_for_mode(shift, 'header', 'head', 0, + snip_get_at_replacement('snip_header'), + $SNIP_HEADER_BUILT_IN); +} + +sub snip_footer_for_mode { + return snip_part_for_mode(shift, 'footer', 'foot', 0, + snip_get_at_replacement('snip_footer'), + $SNIP_FOOTER_BUILT_IN); +} + +# processing + +my $snip_ignore_files_rx = '^([.#].*|.*(~|\.orig\|,v\|\.bak))$'; # |:todo:| make option +$snip_ignore_files_rx = '^$'; + +# VOID snips_collect_snippets ( snips-dir, ... ) +sub snips_collect_snippets { + my @snips_dirs = @_; + local ( *SNIPSDIR ); + local ( $_ ); + # clear old snippets info + $SNIPS_BY_CAT = {}; + $SNIPS_BY_NAME = []; + my $files_seen = {}; + foreach my $snips_dir ( @snips_dirs ) { + if ( opendir ( SNIPSDIR, $snips_dir )) { + my @dirents = readdir ( SNIPSDIR ); + closedir ( SNIPSDIR ); + foreach ( sort ( @dirents )) { + if ( -d $snips_dir.'/'.$_ ) { + next; + } + if ( m,^[.][.]?$,so ) { # skip current/parent directory + next; + } + if ( m,$snip_ignore_files_rx,s ) { # skip ignored files + next; + } + my $file = $_; + if ( !$files_seen->{$file} ) { + my ( $cat, $name ) = split ( /_/, $file, 2 ); + push ( @{$SNIPS_BY_NAME}, [ $name, $file, $snips_dir ]); + if ( !$name ) { + $name = $cat; + $cat = 'none'; + } + $SNIPS_BY_CAT->{$cat}->{$snips_dir}->{$file} = [ $name, $file, $snips_dir ]; + $files_seen->{$file} = 1; + #snip_msg ( " :DBG: adding file `%s` (%s)\n", $file, $snips_dir ) if $DEBUG > 2; + } else { + snip_msg ( " :DBG: file `%s` (%s) already seen. skipping...\n", + $file, $snips_dir ) if $DEBUG > 2; + } + } + } + } + return; +} + +# VOID snips_ensure_snippets_collected ( snips-dir, ... ) +sub snips_ensure_snippets_collected { + if ( $#{$SNIPS_BY_NAME} < 0 ) { + snips_collect_snippets( @_ ); + } + return; +} + +# snips_iterate ( CALLBACK[, CALLBACK_DATA[, NAME_RX[, ACCEPT_CAT_RX[, IGNORE_CAT_RX ]]]]) +sub snips_iterate { + my $callback = shift; + my $callback_data = shift; + my $name_rx = shift; + if ( !defined ( $name_rx )) { + $name_rx = $opt_name_rx; + } + my $accept_cat_rx = shift; + if ( !defined ( $accept_cat_rx )) { + $accept_cat_rx = $opt_accept_cat_rx; + } + my $ignore_cat_rx = shift; + if ( !defined ( $ignore_cat_rx )) { + $ignore_cat_rx = $opt_ignore_cat_rx; + } + my $result = []; + + snip_msg ( " :DBG: %-*s: [%s] accept_cat_rx: [%s] ignore_cat_rx: [%s]\n", + $dbg_fwid || 15, 'find file w/name_rx', + $name_rx, $accept_cat_rx, $ignore_cat_rx ) if $DEBUG > 1; + + my @categories = sort ( keys ( %{$SNIPS_BY_CAT})); + foreach my $category ( @categories ) { + if ( $category =~ m,$ignore_cat_rx,s ) { + next; + } + if ( $category !~ m,$accept_cat_rx,s ) { + next; + } + foreach my $dir ( sort ( keys ( %{$SNIPS_BY_CAT->{$category}}))) { + foreach my $file ( sort ( keys ( %{$SNIPS_BY_CAT->{$category}->{$dir}}))) { + if ( $file !~ m,$name_rx,s ) { + next; + } + my @cb_res = &{$callback}( $callback_data, $dir, $file ); + if ( $#cb_res > 0 ) { + push ( @{$result}, $cb_res[ 1 ]); + } + if ( !$cb_res[ 0 ]) { + return $result; + } + } + } + } + return $result; +} + +sub snips_cb_list { + my $cmd = shift; + my $dir = shift; + my $file = shift; + if (!$opt_mode_seen) { + my $mode; + my $cat_pfx_part = $file; + $cat_pfx_part =~ s,[.].*,,so; + if ( $cat_pfx_part !~ m,_,so ) { + # no category defined + $mode = $SNIPS_MODE; + } else { + $mode = $cat_pfx_part; + $mode =~ s,_.*,,so; + } + snip_set_at_replacement('mode', $mode); + } + $cmd = snip_replace($cmd); + printf STDOUT ( "%s%-32s %s %s\n", + $cmd, + sprintf ( "'^%s\$'", sq ( $file )), + $opt_fn_sep, + $dir.'/'.$file ); + return ( 1 ); +} + +sub snips_cb_list_as_includes { + my $data = shift; + my $dir = shift; + my $file = shift; + my $cmd = $data->[ 0 ]; + my $trail = $data->[ 1 ]; + my $fwid = 32; + if ( !$trail ) { + $fwid = 0; + } + printf STDOUT ( "%s%-*s%s\n", + $cmd, + $fwid, sprintf ( "^%s\$", snip_quote_file( $file )), + $trail ); + return ( 1 ); +} + +sub snips_cb_grep { + my $cmd = shift; + my $dir = shift; + my $file = shift; + + my $gcmd = sprintf ( "grep %s '%s' /dev/null", + $opt_grep_opts, sq ( $dir.'/'.$file )); + system ( $gcmd ); + return ( 1 ); +} + +sub snips_cb_grep_as_includes { + my $data = shift; + my $dir = shift; + my $file = shift; + my $cmd = $data->[ 0 ]; + my $trail = $data->[ 1 ]; + my $fwid = 32; + if ( !$trail ) { + $fwid = 0; + } + # -l, --files-with-matches + my $gcmd = sprintf ( "grep %s '%s' /dev/null", + $opt_grep_opts, sq ( $dir.'/'.$file )); + my $gres = `$gcmd`; + $gres =~ s,[ \t\r\n]+$,,so; + if ( $gres ) { + printf STDOUT ( "%s%-*s%s\n", + $cmd, + $fwid, sprintf ( "^%s\$", $file ), + $trail ); + } + return ( 1 ); +} + +sub snips_cb_find { + my $cont = shift; + my $dir = shift; + my $file = shift; + snip_msg ( " ".":DBG: %-*s: [%s] cont: %d\n", $dbg_fwid || 15, "cb_file", + $dir.'/'.$file || '', $cont ) if $DEBUG > 1; + return ( $cont, $dir.'/'.$file ); +} + +# snips_find_file ( ANY, ALL[, NAME_RX[, ACCEPT_CAT_RX[, IGNORE_CAT_RX ]]]) +sub snips_find_file { + my $any = shift; + my $all = shift; + my $name_rx = shift; + my $result = snips_iterate ( \&snips_cb_find, $all, $name_rx, @_ ); + if ( $any && $#{$result} < 0 ) { + $result = snips_iterate ( \&snips_cb_find, $all, $name_rx, '.*', '^$' ); + } + return $result; +} + +# |||:sec:||| text chunks +# a chunk is defined as [ TXT, type, is_txt ] +# is_txt can be: +# -1 = undecided +# 0 = no text +# 1 = text +my $chunks = []; + +# chunk types are registered +my $chunk_types = {}; + +my $chi_txt = 0; +my $chi_type = 1; +my $chi_is_body = 2; + +sub chunk_register_type { + my $type = shift; + my $is_txt = shift; + $chunk_types->{$type} = [ $is_txt, @_ ]; +} + +# known types +chunk_register_type ( 'hdr', 0 ); +chunk_register_type ( 'body', 1 ); +chunk_register_type ( 'body-top', 1 ); +chunk_register_type ( 'body-bot', 1 ); +chunk_register_type ( 'ftr', 0 ); + +# set type of chunk +sub chunk_set_type { + my $chunk = shift; + my $type = shift; + splice ( @{$chunk}, 1 ); + if ( exists ( $chunk_types->{$type} )) { + push ( @{$chunk}, $type, @{$chunk_types->{$type}}, @_ ); + } else { + push ( @{$chunk}, $type, -1, @_ ); + } + return $chunk; +} + +# create a chunk from type +sub chunk_create { + my $type = shift; + return chunk_set_type ( [ '' ], $type, @_ ); +} + +# -------------------------------------------------- +# STRING = chunk_dump () +sub chunk_dump { + my $chunk = shift; + return sprintf ( "[ %-9s %s, '%s' ]", + $chunk->[ $chi_type ].',', + $chunk->[ $chi_is_body ] ? 'y' : 'n', + dbg_trunc_str ( $chunk->[ $chi_txt ]), + ); +} + +sub chunk_stack_dump { + my $chunks = shift; + my $reverse = shift; + if ( $reverse ) { + $chunks = [ reverse ( @{$chunks} )]; + } + my $indx = 0; + foreach my $chunk ( @{$chunks} ) { + snip_msg ( " :CHK: %d %s\n", $indx, chunk_dump ( $chunk )); + ++$indx; + } + return; +} + +# |||:sec:||| tag translation +my $snips_tag_trans = + { + # 'snap' => 'snp' + }; + +sub snips_tag_trans { + my $tag = shift; + if ( exists ( $snips_tag_trans->{$tag} )) { + $tag = $snips_tag_trans->{$tag}; + } + return $tag; +} + +# |||:sec:||| processing +my $snpc_ind_txt = 0; # snippet text +my $snpc_ind_hdr = 1; # snippet header +my $snpc_ind_ftr = 2; # snippet footer +my $snpc_ind_rpl = 3; # snippet `replace` flag +my $snpc_ind_prc = 4; # snippet `processing' flag +my $snpc_ind_fil = 5; # snippet filename +my $snpc_ind_lno = 6; # snippet line number +my $snpc_ind_sts = 7; # snippet `start seen' flag +my $snpc_ind_stp = 8; # snippet `stop seen flag' +my $snpc_ind_inc = 9; # snippet `including' flag +my $snpc_ind_ind = 10; # snippet indent +my $snpc_ind_mrk = 11; # snippet mark begin, mark end, mark replacement flag +my $snpc_ind_cst = 12; # chunks |:todo:| +my $snpc_ind_col = 13; # snippet `collect` info +my $snpc_ind_tit = 14; # snippet title +my $snpc_ind_sta = 15; # snippet start args +my $snpc_ind_oid = 16; # snippet uuid +my $snpc_ind_max = 17; # first unused index + +my $snpc_fields = + [ + 'txt', + 'hdr', + 'ftr', + 'rpl', + 'prc', + 'fil', + 'lno', + 'sts', + 'stp', + 'inc', + 'skp', + 'mrk', + 'cst', + 'col', + 'tit', + 'sta', + 'oid', + ]; + +sub snips_ctx_chunks { + my $context = shift; + if ( wantarray ) { + snip_msg ( " :DBG: %s wantarray\n", 'snips_ctx_chunks' ) if $DEBUG || 1; + return ( @{$context->[ $snpc_ind_cst ]}); + } else { + return ( $context->[ $snpc_ind_cst ]); + } +} + +sub snips_ctx_chunk { + my $context = shift; + return snips_ctx_chunks ( $context )->[ 0 ]; +} + +sub snips_ctx_add_chunk { + my $context = shift; + my $chunk = shift; + my $chunks = snips_ctx_chunks( $context ); + unshift ( @{$chunks}, $chunk ); +} + +sub snips_process_context { + my $replace = shift; + if ( !defined ( $replace )) { + $replace = $opt_replace; + } + my $process = shift; + if ( !defined ( $process )) { + $process = $opt_process; + } + my $file_name = shift || 'string'; + my $line_no = shift || 0; + my $context = [ '', '', '', $replace, $process, $file_name, $line_no, 0, 0, 0, 0, [], [], [], $opt_title, '', $opt_uuid]; + my $chunk = chunk_create ( 'unk' ); + snips_ctx_add_chunk ( $context, $chunk ); + return $context; +} + +sub snips_context_string { + my $context = shift; + my @string = (); + my $indx = 0; + foreach my $elt ( @{$context} ) { + my $msg = repr($elt); + if ( !defined ( $msg )) { + $msg = '<<>>'; + } + push (@string, sprintf('%s: [%s]', $snpc_fields->[$indx], $msg)); + $indx += 1; + } + return ''.join(', ', @string); +} + +sub snips_context_filename { + my $context = shift; + my $file_name = snip_get_at_replacement('snip_self'); + if (!$file_name) { + $file_name = $context->[ $snpc_ind_fil ] || 'no_file'; + } + return $file_name; +} + +sub snip_msgc { + my $context = shift; + my $file_name = snips_context_filename($context); + my $line_no = $context->[$snpc_ind_lno]; + my $format = shift; + $format = sprintf("%s:%d: %s", $file_name, $line_no, $format); + snip_msg ( $format, @_ ); +} + +# -------------------------------------------------- +# |||:sec:||| snippet command options +# -------------------------------------------------- + +my $snp_tag_opt_defs_ = + [ + ["#subst#", [{}, {}, {}]], + ["#undef#", [{}, {}]], + ["process", 0], # $context->[ $snpc_ind_prc ] + ["skip", !$opt_no_skip ], # !$opt_no_skip + ["indent", !$opt_no_indent ], # !$opt_no_indent +# ["final", !$opt_no_final ], # !$opt_no_final + ["replace", 0], # $context->[ $snpc_ind_rpl ] + ["export", 1], + ["import", 1], + ["accept", $opt_accept_cat_rx, 1], + ["ignore", $opt_ignore_cat_rx, 1], + ]; + +my $snp_tag_opt_defs = {}; + +foreach my $opt_def ( @{$snp_tag_opt_defs_} ) { + my $keyword = $opt_def->[0]; + $snp_tag_opt_defs->{$keyword} = $opt_def; +} + +my $snp_tag_opt_keywords = [sort(keys(%{$snp_tag_opt_defs}))]; + +sub snp_tag_opt_dump_keywords { + print("[\n# '".join("',\n# '", sort(@{$snp_tag_opt_keywords}))."',\n],\n\$context"); +} +#snp_tag_opt_dump_keywords(); exit(0); # |:debug:| + +# |||:sec:||| snippet command options +sub snp_arg_is_keyword_min { + my $arg = shift; + my $keyword = shift; + my $min_len = shift || 0; + + my $argl = length($arg); + my $keyl = length($keyword); + my $match = (($argl <= $keyl) && ($arg eq substr($keyword, 0, $argl))); + if ( $match ) { + # an exact match is always valid! + # Min len can be greater than actual option length, for e.g.: + # --some => min_len = 5 + # --some-thing => min_len = 5 + # snip_msg ( " ".":DBG:| %-*s: al[%2d] kl[%2d] ml[%2d] a[%s] k[%s]\n", $dbg_fwid || 15, + # "arg_is_kw", $argl, $keyl, $min_len, $arg || '', $keyword || '' ) + # if $DEBUG > 7; + if ( $argl != $keyl && $argl < $min_len ) { + return -1; + } + return 1; + } + return 0; +} + +sub snp_arg_is_keyword { + my $arg = shift; + my $keyword = shift; + my $match = snp_arg_is_keyword_min($arg, $keyword, @_); + if ( $match < 0 ) { + snip_msg("warning: ambiguous option [%s]", $keyword); + $match = 0; + } + return $match; +} + +# make a copy of the standard option definitions +sub snp_tag_opt_defs_copy { + my $opt_defs_in = shift || $snp_tag_opt_defs; + my $opt_defs = {}; + foreach my $keyword ( keys(%{$opt_defs_in})) { + my $opt_def = $opt_defs_in->{$keyword}; + my $opt_def_copy = [ @{$opt_def} ]; + my $value = $opt_def_copy->[1]; + if ( ref($value) eq 'ARRAY') { + my $value_copy = []; + foreach my $val_elt(@{$value}) { + my $val_ref = ref($val_elt); + if ($val_ref eq 'HASH') { + push(@{$value_copy}, { %{$val_elt} }); + } elsif ($val_ref eq 'ARRAY') { + push(@{$value_copy}, [ @{$val_elt} ]); + } else { + if ($val_ref) { + snip_msg("warning: snp_tag_opt_defs_copy: don't know how to copy `%s'\n", $val_elt); + } + push(@{$value_copy}, $val_elt); + } + } + $opt_def_copy->[1] = $value_copy; + } + $opt_defs->{$keyword} = $opt_def_copy; + } + return $opt_defs; +} + +# make copy of standard option definitions and fill defaults from context +sub snp_tag_opt_defs_context { + my $context = shift || snips_process_context(); + my $opt_defs = snp_tag_opt_defs_copy(); + if (exists($opt_defs->{'process'})) { + $opt_defs->{'process'}->[ 1 ] = $context->[ $snpc_ind_prc ]; + } + if (exists($opt_defs->{'skip'})) { + $opt_defs->{'skip'}->[ 1 ] = !$opt_no_skip; + } + if (exists($opt_defs->{'indent'})) { + $opt_defs->{'indent'}->[ 1 ] = !$opt_no_indent; + } + # if (exists($opt_defs->{'final'})) { + # $opt_defs->{'final'}->[ 1 ] = !$opt_no_final; + # } + if (exists($opt_defs->{'replace'})) { + $opt_defs->{'replace'}->[ 1 ] = $context->[ $snpc_ind_rpl ]; + } + if (exists($opt_defs->{'accept'})) { + $opt_defs->{'accept'}->[ 1 ] = $opt_accept_cat_rx; + } + if (exists($opt_defs->{'ignore'})) { + $opt_defs->{'ignore'}->[ 1 ] = $opt_ignore_cat_rx; + } + return $opt_defs; +} + +sub snp_tag_opt_defs_filter { + my $filter = shift || []; + my $context = shift || snips_process_context(); + my $opt_defs = snp_tag_opt_defs_context($context); + my $res_defs = {}; + foreach my $keyword ( @{$filter} ) { + my $def = [ $keyword ]; + my $ref = ref($keyword); + if ($ref eq 'ARRAY') { + $def = $keyword; + $keyword = $def->[0]; + } + if ( exists($opt_defs->{$keyword})) { + my $odef = $opt_defs->{$keyword}; + if (scalar(@{$def}) > 1) { + $odef->[1] = $def->[1]; + } + $def = $odef; + } + $res_defs->{$keyword} = $def; + } + return $res_defs; +} + +sub snp_tag_opt_defs_disambiguate { + my $opt_defs = shift; + # |:todo:| + # make keyword abbreviations unambiguous + my $keywords = [sort(keys(%{$opt_defs}))]; + foreach my $opt_def ( values(%{$opt_defs})) { + $opt_def->[3] = 0; + } + foreach my $opt_def ( values(%{$opt_defs} )) { + my $keyword = $opt_def->[0]; + my $kw_min_len = $opt_def->[3] || 1; + my $kw_start = substr($keyword, 0 , $kw_min_len); + foreach my $kw_check( @{$keywords} ) { + if ($kw_check ne $keyword) { + my $od_check = $opt_defs->{$kw_check}; + my $od_check_min_len = $od_check->[ 3 ]; + while ($kw_start eq substr($kw_check, 0 , $kw_min_len)) { + if ( $kw_min_len < $od_check_min_len) { + $kw_min_len = $od_check_min_len; + } else { + $kw_min_len += 1; + $od_check->[ 3 ] = $kw_min_len; + } + $kw_start = substr($keyword, 0, $kw_min_len); + } + $opt_def->[ 3 ] = $kw_min_len; + } + } + } + return; +} + +sub snp_tag_opt_defs_dump { + my $opt_defs = shift; + if ( $opt_defs ) { + foreach my $keyword ( sort(keys(%{$opt_defs}))) { + my $opt_def = $opt_defs->{$keyword}; + my $od_len = @{$opt_def}; + my $default = $opt_def->[1]; + my $expect = $od_len > 2 ? $opt_def->[2] : 0; + my $min_len = $od_len > 3 ? $opt_def->[3] : -1; + snip_msg ( " ".":DBG: %-*s: exp[%d], min[%d] def[%s]\n", + $dbg_fwid || 15, + 'opt: '.( $keyword || ''), + $expect || 0, + $min_len || 0, + $default || '', + ); + } + } + return; +} + +sub snp_tag_opt { + my $keyword = shift; #0 + my $values = shift || []; #1 + my $negate = shift || 0; #2 + my $opt_def = shift; #3 + my $arg = shift; #4 + my $amb = shift || []; #5 + return [$keyword, $values, $negate, $opt_def, $arg, $amb ]; +} + +sub snp_tag_opts_from_arr { + my $opt_arr = shift || []; + my $opts = {}; + my $aindx = 0; + foreach my $opt ( @{$opt_arr} ) { + $opts->{sprintf('%05d', $aindx)} = $opt; + $aindx += 1; + } + return $opts; +} + +sub snp_tag_opts_dump { + my $opts = shift; + if ( $opts ) { + my $max_wid = 0; + foreach my $keyword ( sort(keys(%{$opts}))) { + my $opt = $opts->{$keyword}; + my $option = $opt->[0] || ''; + my $olen = length($option); + if ($max_wid < $olen) { + $max_wid = $olen; + } + } + foreach my $keyword ( sort(keys(%{$opts}))) { + my $opt = $opts->{$keyword}; + + my $option = $opt->[0] || ''; + my $values = $opt->[1] || []; + my $negate = $opt->[2] || 0; + my $opt_def = $opt->[3]; + my $arg = $opt->[4] || ''; + my $amb = $opt->[5] || []; + my $val_rep = join(', ', map { $_ || '0' } @{$values} ); + if ( $keyword eq '#subst#') { + my @counts = + ( + scalar(keys(%{$values->[0]})), + scalar(keys(%{$values->[1]})), + scalar(keys(%{$values->[2]})), + ); + $val_rep = join(', ', map { $_ || '0' } @counts ); + } + if ( $keyword eq '#undef#') { + my @counts = + ( + scalar(keys(%{$values->[0]})), + scalar(keys(%{$values->[1]})), + ); + $val_rep = join(', ', map { $_ || '0' } @counts ); + } + my $amb_rep = join(', ', @{$amb} ); + if ($amb_rep) { + $amb_rep = sprintf(' amb[%s]', $amb_rep); + } + snip_msg ( " ".":DBG: %-*s: neg[%d] def[%d] opt[%s] val%-3s%s\n", + $dbg_fwid || 15, + 'opt arg: '.( $arg || ''), + $negate, + $opt_def ? 1 : 0, + sprintf('%-*s', $max_wid, $option), + sprintf('[%s]', $val_rep), + $amb_rep, + ); + if ( $keyword eq '#subst#') { + my $replacements_del = $values->[0]; + if ( keys(%{$replacements_del})) { + snip_msg("#subst# replacements_del\n"); + snip_replacements_dump($replacements_del, ''); + } + my $replacements_rst = $values->[1]; + if ( keys(%{$replacements_rst})) { + snip_msg("#subst# replacements_rst\n"); + snip_replacements_dump($replacements_rst, ''); + } + my $replacements_add = $values->[2]; + if ( keys(%{$replacements_add})) { + snip_msg("#subst# replacements_add\n"); + snip_replacements_dump($replacements_add, ''); + } + } elsif ( $keyword eq '#undef#') { + my $replacements_nx_del = $values->[0]; + if ( keys(%{$replacements_nx_del})) { + snip_msg("#undef# replacements_nx_del\n"); + snip_replacements_dump($replacements_nx_del, ''); + } + my $replacements_nx_rst = $values->[1]; + if ( keys(%{$replacements_nx_rst})) { + snip_msg("#undef# replacements_nx_rst\n"); + snip_replacements_dump($replacements_nx_rst, ''); + } + } + } + } + return; +} + +sub snp_tag_opt_analyze { + my $opt_defs = shift; + my $arg = shift; + my $ambiguous_options = []; + # opt_def, values, negate, ambiguous_options + my $opt = snp_tag_opt( undef, undef, undef, undef, $arg, $ambiguous_options ); + if ( !$arg ) { + return $opt; + } + my $argc = lc($arg); + foreach my $keyword (%{$opt_defs}) { + my $opt_def = $opt_defs->{$keyword}; + my $opt_min_len = $opt_def->[3]; + my $match = snp_arg_is_keyword_min($argc, $keyword, $opt_min_len); + if ($match <= 0) { + if ($match < 0) { + push(@{$ambiguous_options}, $keyword ); + } + next; + } + $opt->[0] = $keyword; + my $value = $opt_def->[1]; + if (ref($value) eq 'ARRAY') { + $opt->[1] = [@{$value}]; + } else { + push(@{$opt->[1]}, $value); + } + $opt->[3] = $opt_def; + last; + } + my $ambiguous_options_s = join(', ', @{$ambiguous_options} ); + if ($ambiguous_options_s) { + snip_msg("warning: ambiguous option [%s] matches %s.\n", $arg, $ambiguous_options_s); + } + return $opt; +} + +sub check_snp_tag_get_opt { + if (1) { + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + my $opt_defs = snp_tag_opt_defs_context(); + snp_tag_opt_defs_dump($opt_defs); + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + snp_tag_opt_defs_disambiguate($opt_defs); + snp_tag_opt_defs_dump($opt_defs); + } + + if (1) { + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + my $opt_defs = snp_tag_opt_defs_filter(["import", "ignore", "export", ["experimental", 5]]); + snp_tag_opt_defs_disambiguate($opt_defs); + snp_tag_opt_defs_dump($opt_defs); + } + + if (1) { + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + my $opt_defs = snp_tag_opt_defs_filter([@{$snp_tag_opt_keywords}, ["experimental", 5]]); + snp_tag_opt_defs_disambiguate($opt_defs); + my $args = + [ + "process", + "pRocess", + "eX", + "eXpe", + "not-found", + ]; + $DEBUG = 8; + my $opts = []; + foreach my $arg (@{$args}) { + my $opt = snp_tag_opt_analyze($opt_defs, $arg); + push(@{$opts}, $opt); + } + $opts = snp_tag_opts_from_arr($opts); + snp_tag_opts_dump($opts); + } + + if (1) { + my $opt_defs = snp_tag_opt_defs_filter([@{$snp_tag_opt_keywords}, ["experimental", 5]]); + my $targs = "include_.*_any !process !r !e abc=\@|cde\@ nl=\@|space\@ -zzz -empty accept .*"; + my $get_opt_res = snp_tag_get_opt(undef, $targs, $opt_defs, 1); + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + printf STDERR ( "# |".":DBG:| %-*s: [%s]\n", $dbg_fwid || 15, "res_parg", join(', ', @{$res_parg}) || '' ); + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + snp_tag_opt_defs_dump($res_defs); + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + snp_tag_opts_dump($res_opts); + printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + snp_tag_opts_dump(snp_tag_opts_from_arr($res_optu)); + } + return; +} + +sub check_snp_tag_get_opt2 { + my $targs = "include_.*_any !process !r !e abc=\@|cde\@ nl=\@|space\@ -zzz -empty accept .*"; + my $opt_defs_kw = + [ + @{$snp_tag_opt_keywords}, + ["defined", 5], + ["eq", 5], + ]; + my $opt_defs = snp_tag_opt_defs_filter($opt_defs_kw); + my $get_opt_res = snp_tag_get_opt(undef, $targs, $opt_defs, 1); + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + # |:here:|||<-here->|| options +} + +#check_snp_tag_get_opt2(); exit(0); # |:debug:| + +sub snp_tag_get_opt { + my $context = shift || snips_process_context(); + my $args = shift; + my $allowed = shift; + my $parg_count = shift || 0; + + if ( !defined ( $allowed )) { + $allowed = snp_tag_opt_defs_context($context); + } + if ( ref($allowed) eq 'HASH') { + $allowed = [values(%{$allowed})]; + } + + my $opt_defs = {}; + foreach my $opt_def (@{$allowed} ) { + my $keyword = $opt_def; + my $opt_default = undef; + my $opt_expect = 0; + if (ref($opt_def) eq 'ARRAY') { + $keyword = $opt_def->[0]; + $opt_default = $opt_def->[1]; + $opt_expect = $opt_def->[2] || 0; + } + $opt_defs->{$keyword} = [ $keyword, $opt_default, $opt_expect, 1 ]; + } + + snp_tag_opt_defs_disambiguate($opt_defs); + + my $opts = {}; + + # setup defaults + foreach my $keyword (sort(keys(%{$opt_defs}))) { + my $opt_def = $opt_defs->{$keyword}; + my $default = $opt_def->[1]; + if (ref($default) ne 'ARRAY') { + $default = [$default]; + } + $opts->{$keyword} = snp_tag_opt($keyword, $default); + } + + my $subst_allowed = exists($opt_defs->{'#subst#'}); + my $undef_allowed = exists($opt_defs->{'#undef#'}); + + my $replacements_del = {}; + my $replacements_rst = {}; + my $replacements_add = {}; + + my $replacements_nx_del = {}; + my $replacements_nx_rst = {}; + my $values = []; + + if ( $subst_allowed ) { + $values = $opts->{'#subst#'}->[1]; + @{$values} = ( $replacements_del, $replacements_rst, $replacements_add ); + } + if ( $undef_allowed ) { + $values = $opts->{'#undef#'}->[1]; + @{$values} = ( $replacements_nx_del, $replacements_nx_rst ); + } + + if (ref($args) ne 'ARRAY') { + my @args = split(/[ \t\r\n]+/, $args); + $args = \@args; + } + + my $positional_args = []; + while ($parg_count > 0) { + push(@{$positional_args}, shift(@{$args})); + $parg_count -= 1; + } + + my $unknown_opts = []; + my $result = [ $positional_args, $opts, $opt_defs, $unknown_opts ]; + + my $current_opt = snp_tag_opt(); + my $current_expect = 0; + my $negate = 0; + + foreach my $arg (@{$args} ) { + if ( $current_expect > 0) { + push(@{$current_opt->[ 1 ]}, $arg); + $current_expect -= 1; + next; + } + + if ($subst_allowed && $arg =~ m/=/soi ) { # substitution + my ( $key, $value ) = split(/=/, $arg, 2); + my @nkeys = snip_normalize_at_key($key); + my $nkey = $nkeys[1]; + if (snip_is_at_replacement_defined($nkey)) { + $replacements_rst->{$nkey} = + snip_get_at_replacement($nkey); + } else { + $replacements_del->{$nkey} = 1; + } + $replacements_add->{$nkey} = $value; + # ignore previous undef of replacement + delete($replacements_nx_del->{$nkey}); + delete($replacements_nx_rst->{$nkey}); + next; + } elsif ( $undef_allowed && $arg =~ m/^-/so ) { # undefine + my $key = $'; + my @nkeys = snip_normalize_at_key($key); + my $nkey = $nkeys[1]; + if (snip_is_at_replacement_defined($nkey)) { + $replacements_nx_rst->{$nkey} = + snip_get_at_replacement($nkey); + } else { + $replacements_nx_del->{$nkey} = 1; + } + # ignore previous definition of replacement + delete($replacements_add->{$nkey}); + delete($replacements_rst->{$nkey}); + delete($replacements_del->{$nkey}); + next; + } + + while ( $arg =~ m/^!/so ) { + $negate = !$negate; + $arg = $'; + } + if (!$arg) { + next; + } + + $current_opt = snp_tag_opt(); + my $argc = lc($arg); + my $argl = length($arg); + + my $known = 0; + my $opt = snp_tag_opt_analyze($opt_defs, $arg); + my $opt_def = $opt->[3]; + if ($opt_def) { + $current_opt = [@{$opt}]; + my $keyword = $current_opt->[0]; + + if ( $negate ) { + my $xkeyword = $keyword; + if ( $keyword eq 'accept') { + $xkeyword = 'ignore'; + } elsif ( $keyword eq 'ignore') { + $xkeyword = 'accept'; + } + if ($xkeyword ne $keyword) { + $opt_def = $opt_defs->{$xkeyword}; + $opt->[0] = $xkeyword; + $opt->[3] = $opt_def; + $negate = 0; + } + } + + my $values = $current_opt->[1]; + $current_opt->[2] = $negate; + $current_expect = $opt_def->[2]; + if ($current_expect == 0) { + $values->[ 0 ] = $negate ? 0 : 1; + } else { + # remove default for options with arguments + pop(@{$values}); + } + + $opts->{$keyword} = $current_opt; + $known = 1; + } + if ( !$known) { + $opt->[2] = $negate; + push(@{$unknown_opts}, $opt); + if ( !scalar(@{$opt->[5]})) { + snip_msgc ($context, "warning: unknown state argument [%s]\n", $arg || '' ) + if $VERBOSE; + } + } + $negate = 0; + } + + return $result; +} + +# |||:sec:||| generic ||<-snap->|| handlers +sub snp_tag_handler_keep { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + # return ( text, done ) + return ( $text ); +} + +sub snp_tag_handler_ignore { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + # return ( text, done ) + if (!$context->[$snpc_ind_prc]) { + return $text; + } + return ( '' ); +} + +sub snp_tag_handler_unknown { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + if ( $VERBOSE ) { + snip_msgc ($context, " warning: unknown tag `%s` with args `%s`\n", + $tag, $targs ); + } + return ( $text ) +} + +# |||:sec:||| ||<-snip->|| handlers +my $opt_relaxed_start_stop = 0; # |:todo:| make configuration option + +sub snip_tag_handler_null { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + if ( $opt_relaxed_start_stop && $VERBOSE < 2 ) { + my $start_seen = $context->[ $snpc_ind_sts ]; + if ( !$start_seen ) { + $context->[ $snpc_ind_sts ] = 1; + $context->[ $snpc_ind_hdr ] = $context->[ $snpc_ind_txt ]; + $context->[ $snpc_ind_txt ] = ''; + return ( '', 1 ); + } else { + $context->[ $snpc_ind_stp ] = 1; + return ( '', 1 ); + } + } else { + snip_msgc ($context, " warning: unhandled null tag seen\n") if $VERBOSE; + } + return ( $text ); +} + +sub snp_tag_handler_capture { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + # must always be activated to prevent unwanted output at collection time. + my $args = [split(/[ \t\r\n]+/, $targs)]; + + my $action = $args->[0]; + if ( !defined ( $action )) { + if ($context->[$snpc_ind_prc]) { + snip_msg("warning: snp_tag_handler_capture: no action specfied\n"); + } + return $text; + } + + # |:todo:| capture interface ... + my $capture_text = ''; + if ($action eq 'on') { + snip_capture_start(); + } elsif ($action eq 'off') { + $capture_text = snip_capture_stop(); + } elsif ($action eq 'clear') { + $snip_capture_context->[1] = ''; + } elsif ($action eq 'get') { + $capture_text = $snip_capture_context->[1]; + } elsif ($action eq 'drop') { + snip_capture_stop(); + } + + if ( $context->[$snpc_ind_rpl]) { + $SNIPS_REPLACEMENTS_FINAL = snip_parse_subst_args($targs, $SNIPS_REPLACEMENTS_FINAL); + } + + if (!$context->[$snpc_ind_prc]) { + return $text; + } + + return ( $capture_text ); +} + +sub snp_tag_handler_debug { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + my $final = 0; + my $negate = 0; + my $debug; + eval { $debug = $targs; }; + $DEBUG = $debug; + if (!$context->[$snpc_ind_prc]) { + return $text; + } + return ( '' ); +} + +sub snp_tag_handler_show { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + my $final = 0; + my $negate = 0; + my $done = 0; + foreach my $key (split(/[ \t\r\n]+/, $targs)) { + while ( $key =~ m/^!/so ) { + $negate = !$negate; + $key = $'; + } + if (!$key) { + next; + } + if ($key eq 'final') { + $final = $negate ? 0 : 1; + $negate = 0; + next; + } + my $value; + if ($final) { + $value = snip_get_at_replacement_final($key, ''); + } else { + $value = snip_get_at_replacement($key, ''); + } + if ( $DEBUG ) { + snip_msgc ($context, " ".":SHW: %-*s: [%s]\n", $dbg_fwid || 15, + ($final ? 'fin ' : 'std ').$key, + dbg_flatten_str($value) || '' ); + } else { + snip_msg (" ".":SHW: %-*s: [%s]\n", $dbg_fwid || 15, + ($final ? 'fin ' : 'std ').$key, + dbg_flatten_str($value) || '' ); + } + $done = 1; + } + my $repl_list = ''; + if (!$done) { + snip_msgc($context, "---------- all%s replacements----------\n", $final ? ' final' : ''); + if ( $final ) { + snip_replacements_dump($SNIPS_REPLACEMENTS_FINAL, '') + } else { + snip_replacements_dump(undef, '') + } + } + if (!$context->[$snpc_ind_prc]) { + return $text; + } + return ( $repl_list ); +} + +sub snip_tag_handler_start { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + if ( $VERBOSE < 2 && $type eq 'snip' ) { + my $start_seen = $context->[ $snpc_ind_sts ]; + if ( $start_seen ) { + snip_msgc ($context, "warning: duplicate start tag ignored\n") if $VERBOSE; + } else { + $context->[ $snpc_ind_sts ] = 1; + $context->[ $snpc_ind_hdr ] = $context->[ $snpc_ind_txt ]; + $context->[ $snpc_ind_txt ] = ''; + $context->[ $snpc_ind_ind ] = 0; + $context->[ $snpc_ind_sta ] = $targs; + return ( '', 1 ); + } + } + return ( $text ); +} + +my $snip_tag_stop_hook = []; + +sub snip_tag_handler_stop { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + if ( $VERBOSE < 2 && $type eq 'snip' ) { + my $start_seen = $context->[ $snpc_ind_sts ]; + my $stop_seen = $context->[ $snpc_ind_stp ]; + if ( $stop_seen ) { + snip_msgc ($context, "warning: duplicate stop tag (%d already seen)\n", + $stop_seen, $tag, $targs ) if $VERBOSE; + } else { + foreach my $hook_func ( @{$snip_tag_stop_hook} ) { + &{$hook_func}( $context, $text, $targs, $tag, $type ); + } + if ( !$start_seen ) { + snip_msgc ($context, "warning: stop tag seen without start tag\n", + $tag, $targs ) if $VERBOSE; + } + $context->[ $snpc_ind_ind ] = 0; + } + ++$context->[ $snpc_ind_stp ]; + return ( '', 1 ); + } + return ( $text ); +} + +sub snip_tag_handler_title { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + # return ( text, done ) + if (!$context->[$snpc_ind_tit]) { + if (!$context->[$snpc_ind_inc]) { + $context->[$snpc_ind_tit] = $targs; + } + } + if (!snip_get_at_replacement('snip_title')) { + snip_set_at_replacement('snip_title', $targs); + } + if (!snip_get_at_replacement('snip_title_user')) { + snip_set_at_replacement('snip_title_user', $targs); + } + snip_set_at_replacement('snip_title_last', $targs); + return snp_tag_handler_keep ( @_ ); +} + +sub snip_tag_handler_uuid { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + # return ( text, done ) + if (!$context->[$snpc_ind_oid]) { + $context->[$snpc_ind_oid] = $targs; # |:check:| + } + my $snip_uuid = snip_get_at_replacement('snip_uuid'); + if (!snip_get_at_replacement('snip_uuid')) { + snip_set_at_replacement('snip_uuid', $targs); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "setup snip_uuid", $targs || '' ) + if $DEBUG > 6; + } else { + snip_msg ( " ".":DBG: %-*s: [%s] dropping [%s]\n", $dbg_fwid || 15, "exist snip_uuid", $snip_uuid || '', $targs || '' ) + if $DEBUG > 50; + } + snip_set_at_replacement('snip_uuid_last', $targs); + return snp_tag_handler_keep ( @_ ); +} + +# |||:sec:||| ||<-snap->|| handlers +sub snp_tag_handler_mark { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + my $name = snip_replace('@snip_self@'); + $name =~ s,.*/,,so; + my $sep = ''; + if (!$targs) { + $targs = ''; + if ($context->[$snpc_ind_tit]) { + $targs .= $sep.$context->[$snpc_ind_tit]; + $sep = ' - '; + } else { + my $snip_title = snip_get_at_replacement('snip_title'); + if ( $snip_title ) { + $targs .= $sep.$snip_title; + $sep = ' - '; + } + } + if ($context->[$snpc_ind_sta]) { + $targs .= $sep.$context->[$snpc_ind_sta]; + } else { + $targs .= $sep.snip_replace('@dts@'); + } + } + if ( $targs ) { + $sep = ' | '; + } + $context->[ $snpc_ind_mrk ] = + [ + snip_comment ( snip_mtagf ( "beg %s%s%s\n", $name, $sep, $targs)), + snip_comment ( snip_mtagf ( "end %s\n", $name )), + # remember replacement flag at time of mark handling + $context->[ $snpc_ind_rpl ], + ]; + return ( '' ); +} + +sub snp_tag_handler_indent { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + my $sign = 1; + my $relative = 0; + while ( $targs =~ m/^([-+])/so) { + $relative = 1; + if ( $1 eq '+') { + $sign = 1; + } else { + $sign = -1; + } + $targs = $'; + } + $targs =~ s,^[ \t\r]+,,sog; + if ( $targs !~ m/^[0-9]+$/so) { + snip_msg("warning: indent (%s) is not numeric\n", $targs); + } else { + if ( !$opt_no_indent) { + my $indent = eval { $targs }; + if ( $relative ) { + $indent *= $sign; + $context->[$snpc_ind_ind] += $indent; + } else { + $context->[$snpc_ind_ind] = $indent; + } + } + } + return ( '' ) +} + +sub snp_tag_handler_trim { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + if ( !$targs ) { + $targs = "all"; + } + my $left; + my $right; + my $stext = $context->[ $snpc_ind_txt ]; + local ($_); + foreach ( split(/[ \t\r\n]+/, $targs )) { + if (snp_arg_is_keyword(lc($_), "left")) { + $left = 1; + } elsif (snp_arg_is_keyword(lc($_), "right")) { + $right = 1; + } elsif (snp_arg_is_keyword(lc($_), "all")) { + $left = 1; + $right = 1; + } else { + # |:todo:| error message + } + } + if ( $left) { + $stext =~ s,^[ \t\r\n]+,,so; + } + if ( $right ) { + $stext =~ s,[ \t\r\n]+$,,so; + if ($stext) { + $stext .= "\n"; + } + } + $context->[ $snpc_ind_txt ] = $stext; + return ( '' ); +} + +sub snp_tag_handler_drop { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + $context->[ $snpc_ind_txt ] = ''; + return ( '' ); +} + +sub snp_tag_handler_quote { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "text", $tag, dbg_flatten_str($text) || '' ) + if $DEBUG > 6; + + $text = $targs; + if ( !defined ( $text )) { + $text = ''; + } + if ( $text ) { + $text .= "\n" + } + return ( $text ); +} + +sub snp_tag_handler_todo { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $sep = ' '; + if ( !defined ( $targs )) { + $targs = ''; + $sep = ''; + } + my $todo_tag = snip_replace('@tag_pfx@todo@tag_sfx@'); + $targs = snip_comment($todo_tag.$sep.$targs); # make the tag configurable + return snp_tag_handler_quote($context, $text, $targs, $tag, $type ); +} + +# |||:sec:||| collector + +my $snpu_ind_txt = 0; +my $snpu_ind_prc = 1; +my $snpu_ind_rpl = 2; +my $snpu_ind_res = 3; +my $snpu_ind_id = 4; +my $snpu_ind_cb = 5; +my $snpu_ind_cba = 6; +my $snpu_ind_uu0 = 7; +my $snpu_ind_uu1 = 8; +my $snpu_ind_uu2 = 9; +my $snpu_ind_vrb = 10; +my $snpu_ind_ind = 11; +my $snpu_ind_noi = 12; +my $snpu_ind_nsk = 13; +my $snpu_ind_lno = 14; +my $snpu_ind_hnd = 15; + +# Terminates collecting, invokes callback and returns collect_param. +sub snp_tag_collect_end { + my ( $context, $id ) = ( @_ ); + my $collect_param = shift(@{$context->[ $snpc_ind_col ]}); + if ( $collect_param ) { + if ( $id ne '*' && $collect_param->[ $snpu_ind_id ] ne $id ) { + snip_msg( " ".":DBG: %-*s: [%s] != [%s]\n", $dbg_fwid || 15, "reject id", $id || '', $collect_param->[ $snpu_ind_id ]) + if $DEBUG > 5; + unshift(@{$context->[ $snpc_ind_col ]} , $collect_param); + $collect_param = undef; + } else { + snip_msg( " ".":DBG: %-*s: [%s] [%d] [%s]\n", $dbg_fwid || 15, + "close collector", $id || '', $context->[$snpc_ind_lno], + join( '] [', + map { dbg_format_if_array($_);} + @{$collect_param->[$snpu_ind_cba]})) + if $DEBUG > 5; + my $callback = $collect_param->[$snpu_ind_cb]; + if ( $callback ) { + $collect_param->[$snpu_ind_res] = &{$callback}($collect_param, $context); + } + $context->[ $snpc_ind_txt ] = $collect_param->[$snpu_ind_txt]; + $context->[ $snpc_ind_prc ] = $collect_param->[$snpu_ind_prc]; + $context->[ $snpc_ind_rpl ] = $collect_param->[$snpu_ind_rpl]; + if ($collect_param->[$snpu_ind_vrb]) { + $context->[ $snpc_ind_ind ] = $collect_param->[$snpu_ind_ind]; + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + } + if ($context->[ $snpc_ind_prc ]) { + #snips_handlers_drop(); # |:handler:| keep aliases + } else { + #snips_handlers_pop(); # |:handler:| restore aliases + } + } + } else { + snip_msg( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "collect_end", 'empty collector stack') + if $DEBUG > 7; + } + return $collect_param; +} + +sub snp_tag_handler_collect { + my ( $context, $id, $callback, $args, $processing, $replace, $verbatim ) = ( @_ ); + my $collect_param = snp_tag_collect_end ( $context, $id ); + if ( !$collect_param ) { + #snips_handlers_push(); # |:handler:| + $collect_param = + [ + $context->[ $snpc_ind_txt ], # 0 + $context->[ $snpc_ind_prc ], # 1 + $context->[ $snpc_ind_rpl ], # 2 + '', # 3 result + $id, # 4 + $callback, # 5 + [ @{$args} ], # 6 + 0, # 7 + 0, # 8 + 0, # 9 + $verbatim, # 10 + $context->[ $snpc_ind_ind ], # 11 + $opt_no_indent + 0, # 12 + $opt_no_skip + 0, # 13 + $context->[ $snpc_ind_lno ], # 14 + undef, # 15 |:handler:| reserved for handlers + ]; + snip_msg( " ".":DBG: %-*s: [%s] [%d] [%s]\n", $dbg_fwid || 15, + "open collector", $id || '', $context->[$snpc_ind_lno], + join( '] [', + map { dbg_format_if_array($_);} + @{$collect_param->[$snpu_ind_cba]})) + if $DEBUG > 5; + unshift(@{$context->[ $snpc_ind_col ]} , $collect_param); + $context->[ $snpc_ind_txt ] = ''; + $context->[ $snpc_ind_prc ] = $processing; + $context->[ $snpc_ind_rpl ] = $replace; + if ( $verbatim ) { + $context->[ $snpc_ind_ind ] = 0; + $opt_no_skip = 1; + $opt_no_indent = 1; + } + return (''); + } + return ($collect_param->[$snpu_ind_res]); +} + +sub snp_tag_collect_end_hook { + my ( $context ) = ( @_ ); + while (snp_tag_collect_end( $context, '*' )) { + # nothing to do + } +} +push ( @{$snip_tag_stop_hook}, \&snp_tag_collect_end_hook ); + +sub snp_tag_collect_last { + my ( $context ) = ( @_ ); + if ($#{$context->[ $snpc_ind_col ]} < 0) { + return undef; + } + return $context->[ $snpc_ind_col ]->[0]; +} + +sub snp_tag_collect_text_cb { + my ( $collect_param, $context ) = ( @_ ); + return $context->[ $snpc_ind_txt ]; +} + +sub check_snip_parse_subst_args { + my $check_replacements = {}; + + my $sv_replacements = snip_replacements_save(); + snip_replacements_dump($check_replacements, ''); + + snip_replacements_restore($sv_replacements); +} +#check_snip_parse_subst_args(); exit(0); # |:debug:| + +sub snip_parse_subst_args { + my $targs = shift || ''; + my $dst_replacements = shift; + my $src_replacements = shift; + my $old_replacements; + + my $sv_replacements; + if ($src_replacements) { + $sv_replacements = snip_replacements_save($src_replacements); + } + # remove one level of quoting + $targs = snip_replace_quoted($targs); + my $defs = []; + if ( $targs =~ m/^[ \t][^ \t\r\n=]+=/so ) { + foreach my $arg (split (/[ \t\r\n]+/, $targs )) { + my ($key, $value) = split (/=/, $arg ); + push(@{$defs}, [$key, $value]); + } + } else { + my ($key, $value) = split (/[ \t\r\n]+/, $targs, 2 ); + push(@{$defs}, [$key, $value]); + } + foreach my $def (@{$defs} ) { + my $key = $def->[0]; + my $value = $def->[1]; + if ( !$value ) { + $value = ''; + } else { + $value = snip_replace($value); + $value = snip_replace_quoted($value); + } + $def->[1] = $value; + } + + if ($dst_replacements) { + $old_replacements = snip_replacements_save($dst_replacements); + } + + foreach my $def (@{$defs} ) { + my $key = $def->[0]; + my $value = $def->[1]; + snip_set_at_replacement($key, $value); + } + + my $cur_replacements; + if ($sv_replacements) { + $cur_replacements = snip_replacements_restore($sv_replacements); + } elsif ($old_replacements) { + $cur_replacements = snip_replacements_restore($old_replacements); + } + return $cur_replacements; +} + +sub snp_tag_handler_undef { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + my ($key) = $targs; + if (!$context->[$snpc_ind_prc]) { + return $text; + } + if ( $context->[$snpc_ind_rpl]) { + snip_del_at_replacement($key); + } + return ( '' ); +} + +my $snip_block_start_lilne_ofs = 1; + +sub snp_tag_handler_define { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $get_opt_res; + my $snippet = ''; + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":TGI: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id ne $tag ) { + # open collector + # process options + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + ['process', 0], + ['replace', 0], + 'skip', + 'indent', + ['final', 0], + ['default', 0], + ['unquote', 0], + ], + $context); + # remove one level of quoting + $targs = snip_replace_quoted($targs); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 1); + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [$get_opt_res, $targs, $text], + 0, 0, 1); + $text = ''; + } else { + # close collector + $snippet = snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [], 0, 0, 1); + my $replacing = $context->[$snpc_ind_rpl]; + snips_handlers_pop(); # |:handler:| remove aliases + + $processing = $context->[$snpc_ind_prc]; + if (!$processing) { + if ( $replacing ) { + $text = snip_replace( $text ); + } + $text = ($collect_param->[$snpu_ind_cba]->[2].$snippet.$text); + } else { + $get_opt_res = $collect_param->[$snpu_ind_cba]->[0]; + + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $key = $res_parg->[0]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $final = $res_opts->{'final'}->[1]->[0]; + my $default = $res_opts->{'default'}->[1]->[0]; + my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + if ( !$default || + ($final ? + !defined(snip_get_at_replacement_final($key)) + : !defined(snip_get_at_replacement($key)))) { + my $value = $snippet; + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + if ( $process ) { + my $sv_txt = $context->[ $snpc_ind_txt ]; + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_txt ] = ''; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + snips_process_feed_string( $value, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + $value = $context->[ $snpc_ind_txt ]; + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_txt ] = $sv_txt; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + } + $value =~ s,[ \t\r\n]+$,,so; + if ( $replace ) { + + $value = snip_replace($value); + } + if ( $unquote ) { + $value = snip_replace_quoted($value); + } + snip_rpl_context_close($rpl_context); + if ( $final) { + snip_set_at_replacement_final($key, $value); + } else { + snip_set_at_replacement($key, $value); + } + } + $text = ''; + } + } + return($text); +} + +sub snp_tag_handler_default { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + if (!$context->[$snpc_ind_prc]) { + return $text; + } + my ($key, $value) = split ( /[ \t\r\n]+/, $targs, 2 ); + if (!defined(snip_get_at_replacement($key))) { + return snp_tag_handler_subst ( @_ ); + } + return ( '' ); +} + +sub snp_tag_handler_subst { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + if (!$context->[$snpc_ind_prc]) { + return $text; + } + if ( $context->[$snpc_ind_rpl]) { + snip_parse_subst_args($targs); + } + return ( '' ); +} + +sub snp_tag_handler_final { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + if (!$context->[$snpc_ind_prc]) { + return $text; + } + if ( $context->[$snpc_ind_rpl]) { + $SNIPS_REPLACEMENTS_FINAL = snip_parse_subst_args($targs, $SNIPS_REPLACEMENTS_FINAL); + } + return ( '' ); +} + +sub snp_tag_handler_alias { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + if ($context->[$snpc_ind_prc]) { + $text = ''; + } + + # must always set/delete, so parsing works + my $args = [split(/[ \t\r\n]+/, $targs)]; + if (scalar(@{$args}) > 2) { + snip_msg("warning: snp_tag_handler_alias: too many arguments: [%s]\n", $targs); + return $text; + exit(1); # |:debug:| + } + + my $alias = $args->[0]; + if ( !defined ( $alias )) { + my $handlers = snip_tag_get_handlers(); + snip_msg("---------- all aliases----------\n"); + foreach my $alias ( sort(keys(%{$handlers}))) { + my $orig = $handlers->{$alias}->[3]; + if ($orig) { + snip_msg ( " ".":ALS: %-*s: [%s]\n", $dbg_fwid || 15, + $alias, $orig || '' ); + } + } + return $text; + } + my $ahandler = snip_tag_get_handler($alias); + my $orig = $args->[1]; + if ( !defined ( $orig )) { + if ( $ahandler ) { + if ($ahandler->[3]) { + snip_tag_set_handler($alias); + } else { + snip_msg("warning: snp_tag_handler_alias: `%s` is not an alias, cannot delete\n", $alias); + } + } else { + snip_msg("warning: snp_tag_handler_alias: alias `%s` not found\n", $alias); + } + } else { + if ($ahandler && !$ahandler->[3]) { + snip_msg("warning: snp_tag_handler_alias: `%s` is not an alias, cannot set to `%s`\n", $alias, $orig); + return $text; + } + my $handler = snip_tag_get_handler_copy($orig); + if ( !defined ( $handler )) { + my $def_alias = 'rem'; + snip_msg("warning: snp_tag_handler_alias: `%s` not found, setting alias `%s` to `%s` instead\n", + $orig, $alias, $def_alias); + $orig = 'rem'; + $handler = snip_tag_get_handler_copy($def_alias); + } + # alias flag + $handler->[3] = $orig; + snip_tag_set_handler($alias, $handler); + } + return $text; +} + +sub snp_tag_handler_verbatim { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq $tag ) { + $VERBOSE = $collect_param->[$snpu_ind_uu0]; # |:info:| VERBOSE has nothing to do with it? + # done + my $vtext = ''; + my $snippet = snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [], 0, 0, 1); + $processing = $context->[$snpc_ind_prc]; + my $cba = $collect_param->[$snpu_ind_cba]; + my $get_opt_res = $cba->[2]; + + # restore handlers + snips_handlers_pop(); # |:handler:| + + if ( $processing ) { + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + # |:check:| unquote before processing?, catch process/replace, unquote, process/replace? + if ( $unquote ) { + if ($replace) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "replace1", dbg_flatten_str($snippet) || '' ); + $snippet = snip_replace($snippet); + } + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "unquote1", dbg_flatten_str($snippet) || '' ); + $snippet = snip_replace_quoted($snippet); + } + + $vtext = $snippet; + # snips_process_feed_string( $snippet, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + snip_rpl_context_close($rpl_context); + } + + if (!$processing) { + my $replace = $context->[$snpc_ind_rpl]; + if ( $replace ) { + $snippet = snip_replace($snippet); + } + return($cba->[0].$snippet.$text); + } + $text = $vtext; + } else { + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + 'process', + 'replace', + 'skip', + 'indent', + ['unquote', 0], + ], + $context); + + $targs = snip_replace_quoted($targs); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 0); + + my $verbatim_handler = snip_tag_get_handler($tag); + snips_handlers_push(snip_tag_handlers_new()); # |:handler:| + snip_tag_set_handler($tag, $verbatim_handler); + snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [ $text, $targs, $get_opt_res ], 0, 0, 1); + $collect_param = snp_tag_collect_last($context); # |:info:| no influence? + $collect_param->[$snpu_ind_uu0] = $VERBOSE; + $VERBOSE = 0; + $text = ''; + } + return ( $text ); +} + +sub snp_tag_handler_snip { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq $tag ) { + my $snippet = snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [], 0, 0, 1); + $processing = $context->[$snpc_ind_prc]; + my $cba = $collect_param->[$snpu_ind_cba]; + my $get_opt_res = $cba->[2]; + + if ( $processing ) { + snips_handlers_drop(); # |:handler:| keep aliases + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + # |:check:| unquote before processing?, catch process/replace, unquote, process/replace? + if ( $unquote ) { + if ($replace) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "replace1", dbg_flatten_str($snippet) || '' ); + $snippet = snip_replace($snippet); + } + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "unquote1", dbg_flatten_str($snippet) || '' ); + $snippet = snip_replace_quoted($snippet); + } + + snips_process_feed_string( $snippet, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + snip_rpl_context_close($rpl_context); + } else { + snips_handlers_pop(); # |:handler:| remove aliases + } + + if (!$processing) { + my $replace = $context->[$snpc_ind_rpl]; + if ( $replace ) { + $snippet = snip_replace($snippet); + } + return($cba->[0].$snippet.$text); + } + $text = ''; + } else { + $targs = snip_replace_quoted($targs); + + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + 'process', + 'replace', + 'skip', + 'indent', + ['unquote', 0], + ], + $context); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 0); + + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [ $text, $targs, $get_opt_res ], 0, 0, 1); + $text = ''; + } + return ( $text ); +} + +#check_snp_tag_get_opt(); exit(0); # |:debug:| + +sub snp_tag_handler_read { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + # my @targs = split ( /[ \t\r\n]*,[ \t\r\n]*/, $targs ); + # snip_msg ( " :DBG: \$targs: [%s]\n", $targs ); + # snip_msg ( " :DBG: \@targs: [%s]\n", join ( '][', @targs )); + # my $inc_file_rx = $targs[ 0 ]; + # my $inc_accept_cat_rx = $targs[ 1 ]; + # my $inc_ignore_cat_rx = $targs[ 2 ]; + + # remove one level of quoting + $targs = snip_replace_quoted($targs); + + my $opt_defs = snp_tag_opt_defs_filter([@{$snp_tag_opt_keywords}], $context); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 1); + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $inc_file_rx = $res_parg->[0]; + + { + my $sv_replacements = snip_replacements_save(); + if ( !snip_is_at_replacement_defined('snip_fn_space')) { + snip_set_at_replacement('snip_fn_space', ' '); + } + if ( !snip_is_at_replacement_defined('snip_fn_tab')) { + snip_set_at_replacement('snip_fn_tab', "\t"); + } + if ( !snip_is_at_replacement_defined('snip_fn_cr')) { + snip_set_at_replacement('snip_fn_cr', "\r"); + } + if ( !snip_is_at_replacement_defined('snip_fn_nl')) { + snip_set_at_replacement('snip_fn_nl', "\n"); + } + $inc_file_rx = snip_replace__($inc_file_rx); + $inc_file_rx = snip_replace_quoted($inc_file_rx); + snip_replacements_restore($sv_replacements); + } + + # |:here:| options + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $accept_cat_rx = $res_opts->{'accept'}->[1]->[0]; + my $ignore_cat_rx = $res_opts->{'ignore'}->[1]->[0]; + + snip_msg ( " ".":DBG: %-*s: [%s] prc[%d] noskp[%d] noi[%d] rpl[%d] exp[%d] imp[%d] acc[%s] ign[%s]\n", $dbg_fwid || 15, + "include args", + $inc_file_rx || '', + $process, + $no_skip, + $no_indent, + $replace, + $export, + $import, + $accept_cat_rx, + $ignore_cat_rx, + ) if $DEBUG > 1; + + my $inc_file = $inc_file_rx; + if ( !( -r $inc_file || $inc_file =~ m,^/,so )) { + # not an absolute filename or readable file + { + local ( $opt_accept_cat_rx ) = $accept_cat_rx; + local ( $opt_ignore_cat_rx ) = $ignore_cat_rx; + my $inc_files = snips_find_file ( 1, 0, $inc_file ); + $inc_file = $inc_files->[ 0 ]; + } + } + + snip_msgc ($context, " ".":DBG: %-*s: [%s]\n", + $dbg_fwid || 15, "include file", $inc_file || '', + ) if $DEBUG > 1; + + if ( $inc_file && -r $inc_file ) { + + ++$context->[ $snpc_ind_inc ]; + local ( $opt_no_skip ) = $no_skip; + local ( $opt_no_indent ) = $no_indent; + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + $text = snips_read_file ( $inc_file ); + snip_rpl_context_close($rpl_context); + --$context->[ $snpc_ind_inc ]; + + } else { + snip_msgc ($context, "warning: no include file found for `%s`\n", + $targs ) if $VERBOSE; + } + + # return ( text, done ) + return ( $text ); +} + +sub snp_tag_handler_include { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + # my @targs = split ( /[ \t\r\n]*,[ \t\r\n]*/, $targs ); + # snip_msg ( " :DBG: \$targs: [%s]\n", $targs ); + # snip_msg ( " :DBG: \@targs: [%s]\n", join ( '][', @targs )); + # my $inc_file_rx = $targs[ 0 ]; + # my $inc_accept_cat_rx = $targs[ 1 ]; + # my $inc_ignore_cat_rx = $targs[ 2 ]; + + # remove one level of quoting + $targs = snip_replace_quoted($targs); + + my $opt_defs = snp_tag_opt_defs_filter([@{$snp_tag_opt_keywords}], $context); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 1); + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $inc_file_rx = $res_parg->[0]; + + { + my $sv_replacements = snip_replacements_save(); + if ( !snip_is_at_replacement_defined('snip_fn_space')) { + snip_set_at_replacement('snip_fn_space', ' '); + } + if ( !snip_is_at_replacement_defined('snip_fn_tab')) { + snip_set_at_replacement('snip_fn_tab', "\t"); + } + if ( !snip_is_at_replacement_defined('snip_fn_cr')) { + snip_set_at_replacement('snip_fn_cr', "\r"); + } + if ( !snip_is_at_replacement_defined('snip_fn_nl')) { + snip_set_at_replacement('snip_fn_nl', "\n"); + } + $inc_file_rx = snip_replace__($inc_file_rx); + $inc_file_rx = snip_replace_quoted($inc_file_rx); + snip_replacements_restore($sv_replacements); + } + + # |:here:| options + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $accept_cat_rx = $res_opts->{'accept'}->[1]->[0]; + my $ignore_cat_rx = $res_opts->{'ignore'}->[1]->[0]; + + snip_msg ( " ".":DBG: %-*s: [%s] prc[%d] noskp[%d] noi[%d] rpl[%d] exp[%d] imp[%d] acc[%s] ign[%s]\n", $dbg_fwid || 15, + "include args", + $inc_file_rx || '', + $process, + $no_skip, + $no_indent, + $replace, + $export, + $import, + $accept_cat_rx, + $ignore_cat_rx, + ) if $DEBUG > 1; + + my $inc_file = $inc_file_rx; + if ( !( -r $inc_file || $inc_file =~ m,^/,so )) { + # not an absolute filename or readable file + { + local ( $opt_accept_cat_rx ) = $accept_cat_rx; + local ( $opt_ignore_cat_rx ) = $ignore_cat_rx; + my $inc_files = snips_find_file ( 1, 0, $inc_file ); + $inc_file = $inc_files->[ 0 ]; + } + } + + snip_msgc ($context, " ".":DBG: %-*s: [%s]\n", + $dbg_fwid || 15, "include file", $inc_file || '', + ) if $DEBUG > 1; + + if ( $inc_file && -r $inc_file ) { + + ++$context->[ $snpc_ind_inc ]; + local ( $opt_no_skip ) = $no_skip; + local ( $opt_no_indent ) = $no_indent; + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + $text = snips_read_snippet ( $inc_file, $replace, $process, 1 ); + snip_rpl_context_close($rpl_context); + --$context->[ $snpc_ind_inc ]; + + } else { + snip_msgc ($context, "warning: no include file found for `%s`\n", + $targs ) if $VERBOSE; + } + + # return ( text, done ) + return ( $text ); +} + +sub snp_tag_handler_exec { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $get_opt_res; + my $script = ''; + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":TGI: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq $tag ) { + # close collector + $script = snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [], 0, 0); + + $processing = $context->[$snpc_ind_prc]; + if (!$processing) { + snips_handlers_pop(); # |:handler:| remove aliases + $text = $script.$text; # |:todo:| this is wrong, the text should not be replaced + my $replacing = $context->[$snpc_ind_rpl]; + if ( $replacing ) { + $text = snip_replace( $text ); + } + } + + $get_opt_res = $collect_param->[$snpu_ind_cba]->[0]; + + } else { + # open collector + # process options + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + 'process', + 'replace', + ['dump', 0], + 'indent', + 'skip', + ['autostart', 1], + ['sprocess', $context->[$snpc_ind_prc]], + ['sreplace', $context->[$snpc_ind_rpl]], + ['sunquote', 1], + ], + $context); + # remove one level of quoting + $targs = snip_replace_quoted($targs); + + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 0); + my $res_opts = $get_opt_res->[1]; + my $process = $res_opts->{'process'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $sprocess = $res_opts->{'sprocess'}->[1]->[0]; + if (!$res_opts->{'sprocess'}->[4]) { # arg + $sprocess = $process; + $res_opts->{'sprocess'}->[1]->[0] = $sprocess; + } + my $sreplace = $res_opts->{'sreplace'}->[1]->[0]; + if (!$res_opts->{'sreplace'}->[4]) { # arg + $sreplace = $replace; + $res_opts->{'sreplace'}->[1]->[0] = $sreplace; + } + #snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "sprocess", $sprocess || '' ); + #snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "sreplace", $sreplace || '' ); + + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [$get_opt_res, $targs], + $sprocess, $sreplace); + + if ($processing) { + return(''); + } + } + + if (!$processing) { + return $text; + } + snips_handlers_drop(); # |:handler:| keep aliases + + if ( $script ) { + my $res_opts = $get_opt_res->[1]; + my $sunquote = $res_opts->{'sunquote'}->[1]->[0]; + if ($sunquote) { + $script = snip_replace_quoted($script); + # |:info:| this makes no sense ? + } + snip_msg ( " ".":EXC: %-*s: [%s]\n", $dbg_fwid || 15, "script", dbg_flatten_str($script) || '' ) + if $DEBUG; + $text = snips_read_file($script.' |', 1); + if ( $@ ) { + snip_msgc ($context, "warning: exec `%s` failed:\n", + $script ) ; + my $err_txt = $@; + $err_txt =~ s,[ \t\r\n]+$,,so; + snip_msgc ($context, "`%s`\n", + $err_txt ); + $text = ''; + } + } else { + if ($VERBOSE) { + snip_msgc ($context, "warning: empty exec\n") ; + } + $text = ''; + } + + if ( $text ) { + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + my $autostart = $res_opts->{'autostart'}->[1]->[0]; + my $dump = $res_opts->{'dump'}->[1]->[0]; + + # printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + # snp_tag_opt_defs_dump($res_defs); + # printf STDERR ( "%s\n", '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~' ); + # snp_tag_opts_dump($res_opts); + + # |:here:| options + + snip_msg ( " ".":DBG: %-*s: prc[%d] noskp[%d] noi[%d] rpl[%d] exp[%d] imp[%d] auto[%d]\n", $dbg_fwid || 15, + "exec args", + $process, + $no_skip, + $no_indent, + $replace, + $export, + $import, + $autostart, + ) if $DEBUG > 1; + + ++$context->[ $snpc_ind_inc ]; + local ( $opt_no_skip ) = $no_skip; + local ( $opt_no_indent ) = $no_indent; + my $prolog; + if ( $process && $autostart ) { + # automatic snippet start + $prolog = snip_tag_start(''); + } else { + $prolog = ''; + } + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + if (!$dump) { + $text = snips_process_snippet ( $prolog.$text, '[ $snpc_ind_lno ].'>', $replace, $process, 1 ); + } + snip_rpl_context_close($rpl_context); + --$context->[ $snpc_ind_inc ]; + } + + # return ( text, done ) + if ( !defined ( $text )) { + $text = ''; + } + return ( $text ); +} + +sub snp_tag_handler_shellq { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $script = $targs; + my $processing = $context->[$snpc_ind_prc]; + + if (!$processing) { + return $text; + } + + if ( $script ) { + $text = snips_read_file($script.' |', 1); + if ( $@ ) { + snip_msgc ($context, "warning: exec `%s` failed:\n", + $script ) ; + my $err_txt = $@; + $err_txt =~ s,[ \t\r\n]+$,,so; + snip_msgc ($context, "`%s`\n", + $err_txt ); + $text = ''; + } + } else { + if ($VERBOSE) { + snip_msgc ($context, "warning: empty %s\n", + $tag ) ; + } + $text = ''; + } + + # return ( text, done ) + if ( !defined ( $text )) { + $text = ''; + } + return ( $text ); +} + +sub snp_tag_handler_shell { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + $text = snp_tag_handler_shellq ( @_ ); + + if ( $text ne '' ) { + my $replace = $context->[ $snpc_ind_rpl ]; + my $process = $context->[ $snpc_ind_prc ]; + if ( $replace || $process ) { + ++$context->[ $snpc_ind_inc ]; + my $prolog; + if ( $process ) { + # automatic snippet start + $prolog = snip_tag_start(''); + } else { + $prolog = ''; + } + $text = snips_process_snippet ( $prolog.$text, '[ $snpc_ind_lno ].'>', $replace, $process, 1 ); + --$context->[ $snpc_ind_inc ]; + } + } + # return ( text, done ) + return ( $text ); +} + +sub snp_tag_handler_skip_cb { + my ( $collect_param, $context ) = ( @_ ); + my $processing = $collect_param->[$snpu_ind_prc]; + my $args = $collect_param->[$snpu_ind_cba]; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "skip_cb", 'called' || '' ) + if $DEBUG > 7; + if (!$processing && snp_arg_is_keyword(lc($args->[ 1 ]), "keep")) { + # if not processing, keep skipped section + my $replacing = $collect_param->[$snpu_ind_rpl]; + my $text = ($args->[ 0 ] + .$context->[ $snpc_ind_txt ]); + if ( $replacing ) { + $text = snip_replace( $text ); + } + return $text; + } + return ''; +} + +sub snp_tag_handler_skip { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + local( $_ ) = $targs; + my @args = split(); + if ( $opt_no_skip ) { + unshift( @args, 'keep' ); + } + unshift( @args, $text ); + # default: remove section even when not processing + push ( @args, 'remove' ); + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + my $result = snp_tag_handler_collect($context, $tag, \&snp_tag_handler_skip_cb, \@args, 0, 0); + if ( $id eq $tag ) { + # end + my $processing = $context->[$snpc_ind_prc]; + snips_handlers_pop(); # |:handler:| remove aliases + } else { + # start + snips_handlers_push(); # |:handler:| save for aliases + } + if ( $result ) { + my $replacing = $collect_param->[$snpu_ind_rpl]; + if ( $replacing ) { + $text = snip_replace( $text ); + } + $result .= $text; + } + return $result; +} + +sub snp_tag_handler_if { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + $targs = snip_replace_quoted($targs); + + local ( $_ ) = $targs; + my $args = [split()]; + + my $final = 0; + my $negate = 0; + my $cmd = ''; + my $indx = 0; + foreach my $arg (@{$args} ) { + $indx += 1; + while ( $arg =~ m/^!/so ) { + $negate = !$negate; + $arg = $'; + } + if (!$arg) { + next; + } + my $argc = lc($arg); + if (snp_arg_is_keyword($argc, "final")) { + $final = $negate ? 0 : 1; + $negate = 0; + next; + } + $cmd = $arg; + last; + } + + my $condition = 1; + my $cmdc = lc($cmd); + + if (snp_arg_is_keyword($cmdc, "defined")) { + my $key = $args->[$indx]; + snip_msg ( " ".":DBG: %-*s: [%s%s %s] [%s]\n", $dbg_fwid || 15, "condition", $final ? 'final ' : '', $negate ? '!' : '=', $cmd || '', $key ) + if $DEBUG > 5; + if ( $final ) { + $condition = snip_is_at_replacement_final_defined($key); + } else { + $condition = snip_is_at_replacement_defined($key); + } + if ( $negate) { + $condition = !$condition; + } + } elsif (snp_arg_is_keyword($cmdc, "eq")) { + my $key = $args->[$indx]; + my $cvalue = $args->[$indx+1]; + $indx += 1; + if ( defined ( $cvalue )) { + $cvalue = snip_replace($cvalue); + } + my $value; + if ( $final ) { + $value = snip_get_at_replacement_final($key, undef); + } else { + $value = snip_get_at_replacement($key, undef); + } + $condition = (defined($cvalue) == defined($value)); + if ($condition && defined($cvalue)) { + $condition = ($value eq $cvalue); + } + if ( $negate) { + $condition = !$condition; + } + my @nkeys = snip_normalize_at_key($key); + my $akey = $nkeys[0]; + snip_msg ( " ".":CND: %-*s: [%s %s=>%s] [%s%s] [%s] == %s\n", $dbg_fwid || 15, + "condition", $final ? 'fin' : 'std', + $akey || '', defined($value) ? $value : '', + $negate ? '!' : '', $cmd || '', + defined($cvalue) ? $cvalue : '', + $condition ? "true" : "false") + if $DEBUG > 5; + } else { + snip_msg ( "|".":ERR:| %-*s: [%s%s %s]\n", $dbg_fwid || 15, "unknown condition", $final ? 'final ' : '', $negate ? '!' : '=', $cmd || '' ); + # treat as true + } + + $indx += 1; + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + 'process', + 'replace', + 'skip', + 'indent', + #['unquote', 0], + ], + $context); + my $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, $indx); + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [ $condition, $text, $args, 0, $get_opt_res ], 0, 0, 1); + my $collect_param = snp_tag_collect_last($context); + $collect_param->[$snpu_ind_id] = 'fi'; + return(''); +} + +sub snp_tag_handler_elif { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq 'fi' ) { + my $snippet = snp_tag_handler_collect($context, 'fi', \&snp_tag_collect_text_cb, [], 0, 0, 1); + $processing = $context->[$snpc_ind_prc]; + my $cba = $collect_param->[$snpu_ind_cba]; + my $condition = $cba->[0]; + my $done = $cba->[3]; + my $get_opt_res = $cba->[4]; + + if ( $processing && !$done && $condition ) { + snips_handlers_drop(); # |:handler:| keep aliases + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + #my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + snips_process_feed_string( $snippet, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + # if ( $unquote ) { + # $snippet = snip_replace_quoted($snippet); + # } + snip_rpl_context_close($rpl_context); + } else { + snips_handlers_pop(); # |:handler:| remove aliases + } + $done = ($done || $condition); + + if (!$processing) { + my $replace = $context->[$snpc_ind_rpl]; + my $fin_snippet = $cba->[1].$snippet; + if ( $replace ) { + $fin_snippet = snip_replace($fin_snippet); + } + $context->[ $snpc_ind_txt ] .= ($fin_snippet); + } + + if ($done) { + my $args = $cba->[2]; + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, 'if', \&snp_tag_collect_text_cb, [ !$condition, $text, $args, $done, $get_opt_res ], 0, 0, 1); + my $collect_param_c = snp_tag_collect_last($context); + $collect_param_c->[$snpu_ind_id] = 'fi'; + } else { + snp_tag_handler_if ($context, $text, $targs, 'if', $type ); + } + + $text = ''; + } else { + snip_msg ( "|".":ERR:| elif without if\n" ); + if ($processing) { + return(''); + } + } + return ( $text ); +} + +sub snp_tag_handler_else { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq 'fi' ) { + my $snippet = snp_tag_handler_collect($context, 'fi', \&snp_tag_collect_text_cb, [], 0, 0, 1); + $processing = $context->[$snpc_ind_prc]; + my $cba = $collect_param->[$snpu_ind_cba]; + my $condition = $cba->[0]; + my $done = $cba->[3]; + my $get_opt_res = $cba->[4]; + + if ( $processing && !$done && $condition ) { + snips_handlers_drop(); # |:handler:| keep aliases + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + #my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + snips_process_feed_string( $snippet, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + # if ( $unquote ) { + # $snippet = snip_replace_quoted($snippet); + # } + snip_rpl_context_close($rpl_context); + } else { + snips_handlers_pop(); # |:handler:| remove aliases + } + $done = ($done || $condition); + + if (!$processing) { + my $replace = $context->[$snpc_ind_rpl]; + my $fin_snippet = $cba->[1].$snippet; + if ( $replace ) { + $fin_snippet = snip_replace($fin_snippet); + } + $context->[ $snpc_ind_txt ] .= ($fin_snippet); + } + + my $args = $cba->[2]; + if ( !$done ) { + $targs = snip_replace_quoted($targs); + local ( $_ ) = $targs; + $args = [split()]; + + my $opt_defs = snp_tag_opt_defs_filter + ([ + '#subst#', + '#undef#', + # 'accept', + 'export', + # 'ignore', + 'import', + 'process', + 'replace', + 'skip', + 'indent', + #['unquote', 0], + ], + $context); + $get_opt_res = snp_tag_get_opt($context, $targs, $opt_defs, 0); + } + + snips_handlers_push(); # |:handler:| save for aliases + snp_tag_handler_collect($context, 'if', \&snp_tag_collect_text_cb, [ !$condition, $text, $args, $done, $get_opt_res ], 0, 0, 1); + my $collect_param_c = snp_tag_collect_last($context); + $collect_param_c->[$snpu_ind_id] = 'fi'; + + $text = ''; + } else { + snip_msg ( "|".":ERR:| else without if\n" ); + if ($processing) { + return(''); + } + } + return ( $text ); +} + +sub snp_tag_handler_fi { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + my $processing = $context->[$snpc_ind_prc]; + + my $collect_param = snp_tag_collect_last($context); + my $id = $collect_param ? $collect_param->[$snpu_ind_id] : ''; + snip_msg ( " ".":DBG: %-*s: [%s] [%s]\n", $dbg_fwid || 15, "tag/id", $tag, $id || '' ) + if $DEBUG > 5; + if ( $id eq $tag ) { + my $snippet = snp_tag_handler_collect($context, $tag, \&snp_tag_collect_text_cb, [], 0, 0, 1); + $processing = $context->[$snpc_ind_prc]; + my $cba = $collect_param->[$snpu_ind_cba]; + my $condition = $cba->[0]; + my $done = $cba->[3]; + my $get_opt_res = $cba->[4]; + + if ( $processing && !$done && $condition ) { + snips_handlers_drop(); # |:handler:| keep aliases + my $res_parg = $get_opt_res->[0]; + my $res_opts = $get_opt_res->[1]; + my $res_defs = $get_opt_res->[2]; + my $res_optu = $get_opt_res->[3]; + + my $process = $res_opts->{'process'}->[1]->[0]; + my $no_skip = !$res_opts->{'skip'}->[1]->[0]; + my $no_indent = !$res_opts->{'indent'}->[1]->[0]; + my $replace = $res_opts->{'replace'}->[1]->[0]; + my $export = $res_opts->{'export'}->[1]->[0]; + my $import = $res_opts->{'import'}->[1]->[0]; + #my $unquote = $res_opts->{'unquote'}->[1]->[0]; + + my $rpl_context; + $rpl_context = snip_rpl_context_open_from_options($res_opts); + my $sv_prc = $context->[ $snpc_ind_prc ]; + my $sv_rpl = $context->[ $snpc_ind_rpl ]; + $context->[ $snpc_ind_prc ] = $process; + $context->[ $snpc_ind_rpl ] = $replace; + $opt_no_skip = $no_skip; + $opt_no_indent = $no_indent; + + snips_process_feed_string( $snippet, $context, $collect_param->[$snpu_ind_lno] + $snip_block_start_lilne_ofs); + + $opt_no_skip = $collect_param->[$snpu_ind_nsk]; + $opt_no_indent = $collect_param->[$snpu_ind_noi]; + $context->[ $snpc_ind_prc ] = $sv_prc; + $context->[ $snpc_ind_rpl ] = $sv_rpl; + $replace = 0; + # if ( $unquote ) { + # $snippet = snip_replace_quoted($snippet); + # } + snip_rpl_context_close($rpl_context); + } else { + snips_handlers_pop(); # |:handler:| remove aliases + } + $done = ($done || $condition); + + if (!$processing) { + my $replace = $context->[$snpc_ind_rpl]; + my $fin_snippet = $cba->[1].$snippet.$text; + if ( $replace ) { + $fin_snippet = snip_replace($fin_snippet); + } + return($fin_snippet); + } + $text = ''; + } else { + snip_msg ( "|".":ERR:| fi without if\n" ); + if ($processing) { + return(''); + } + } + return ( $text ); +} + +# |:DEPRECATED:| +sub snp_tag_handler_evalq { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + $text = eval $targs; + if ( $@ ) { + if ( $VERBOSE ) { + snip_msgc ($context, "warning: eval `%s` failed:\n", + $targs ) ; + my $err_txt = $@; + $err_txt =~ s,[ \t\r\n]+$,,so; + snip_msgc ($context, "`%s`\n", + $err_txt ); + } + $text = ''; + } + + # return ( text, done ) + if ( !defined ( $text )) { + $text = ''; + } + return ( $text ); +} + +# |:DEPRECATED:| +sub snp_tag_handler_eval { + my ( $context, $text, $targs, $tag, $type ) = ( @_ ); + + $text = snp_tag_handler_evalq ( @_ ); + + if ( $text ne '' ) { + my $replace = $context->[ $snpc_ind_rpl ]; + my $process = $context->[ $snpc_ind_prc ]; + if ( $replace || $process ) { + ++$context->[ $snpc_ind_inc ]; + $text = snips_process_snippet ( $text, '[ $snpc_ind_lno ].'>', $replace, $process, 1 ); + --$context->[ $snpc_ind_inc ]; + } + } + # return ( text, done ) + return ( $text ); +} + +# |||:sec:||| handler demux +# [ handler-ref, ALWAYS-PROCESS ] +# if ALWAYS-PROCESS is true, the handler is always invoked, no matter +# what the global processing flag is. +my $snip_tag_handlers = + { + # tag => [ handler, always ] + '' => [ \&snip_tag_handler_null, $opt_relaxed_start_stop ], + 'capture' => [ \&snp_tag_handler_capture, 1 ], + 'debug' => [ \&snp_tag_handler_debug, 1 ], + 'show' => [ \&snp_tag_handler_show, 1 ], + 'alias' => [ \&snp_tag_handler_alias, 1 ], + + 'start' => [ \&snip_tag_handler_start, 2 ], + 'stop' => [ \&snip_tag_handler_stop, 2 ], + 'title' => [ \&snip_tag_handler_title, 2 ], + 'uuid' => [ \&snip_tag_handler_uuid, 2 ], + + 'mark' => [ \&snp_tag_handler_mark, 0 ], + 'beg' => [ \&snp_tag_handler_keep, 3 ], # marked section begin + 'end' => [ \&snp_tag_handler_keep, 3 ], # marked section end + + 'indent' => [ \&snp_tag_handler_indent ], + + 'rem' => [ \&snp_tag_handler_ignore ], + 'trim' => [ \&snp_tag_handler_trim ], + 'drop' => [ \&snp_tag_handler_drop ], + 'quote' => [ \&snp_tag_handler_quote ], + 'todo' => [ \&snp_tag_handler_todo ], + + 'undef' => [ \&snp_tag_handler_undef, 1 ], + 'define' => [ \&snp_tag_handler_define, 1 ], + 'default' => [ \&snp_tag_handler_default, 1 ], + 'subst' => [ \&snp_tag_handler_subst, 1 ], + 'final' => [ \&snp_tag_handler_final, 1 ], + + 'verbatim'=> [ \&snp_tag_handler_verbatim, 1 ], + 'snip' => [ \&snp_tag_handler_snip, 1 ], + 'snap' => [ \&snp_tag_handler_snip, 1 ], + 'read' => [ \&snp_tag_handler_read ], + 'include' => [ \&snp_tag_handler_include ], + + 'exec' => [ \&snp_tag_handler_exec, 1 ], + 'shellq' => [ \&snp_tag_handler_shellq, 1 ], + 'shell' => [ \&snp_tag_handler_shell, 1 ], + + 'skip' => [ \&snp_tag_handler_skip, 1 ], + + 'if' => [ \&snp_tag_handler_if, 1 ], + 'elif' => [ \&snp_tag_handler_elif, 1 ], + 'else' => [ \&snp_tag_handler_else, 1 ], + 'fi' => [ \&snp_tag_handler_fi, 1 ], + + # vvv don't use eval/evalq, to keep everything portable + 'evalq' => [ \&snp_tag_handler_evalq ], + 'eval' => [ \&snp_tag_handler_eval ], + # ^^^ don't use eval/evalq, to keep everything portable + '*' => [ \&snp_tag_handler_unknown ], + }; + +my $snip_tag_handler_stack = []; + +# |:here:| + +sub snip_tag_handlers_new { + return {}; +} + +sub snip_tag_get_handlers { + return $snip_tag_handlers; +} + +sub snip_tag_handlers_copy { + my $old_handlers = shift || $snip_tag_handlers; + my $new_handlers = snip_tag_handlers_new(); + foreach my $name (keys(%{$old_handlers})) { + $new_handlers->{$name} = [ @{$old_handlers->{$name}} ]; + } + return $new_handlers; +} + +sub snips_handlers_set { + my ( $new_handlers ) = @_; + my $old_handlers = $snip_tag_handlers; + if ( !defined ( $new_handlers )) { + $new_handlers = snip_tag_handlers_copy(); + } + $snip_tag_handlers = $new_handlers; + return $old_handlers; +} + +sub snips_handlers_push { + my ( $new_handlers ) = @_; + my $old_handlers = snips_handlers_set($new_handlers); + push (@{$snip_tag_handler_stack}, $old_handlers); + return $old_handlers; +} + +# take one off the stack and discard +sub snips_handlers_drop { + my $old_handlers = pop (@{$snip_tag_handler_stack}); + if ( !defined ( $old_handlers )) { + $old_handlers = $snip_tag_handlers; + snip_msg("severe internal error: snips_handlers_pop: snip_tag_handler_stack is empty\n"); + exit(1); # |:debug:| + } + return $old_handlers; +} + +sub snips_handlers_pop { + return snips_handlers_set(snips_handlers_drop()); +} + +sub snip_tag_handler_copy { + my ( $handler, $flag ) = @_; + if (!$handler) { + return undef; + } + $handler = [@{$handler}]; + if ( defined ( $flag )) { + $handler->[1] = $flag; + } + return $handler; +} + +sub snip_tag_get_handler { + my ( $tag ) = @_; + my $handler; + if ( exists ( $snip_tag_handlers->{$tag} )) { + $handler = $snip_tag_handlers->{$tag}; + } + return $handler; +} + +sub snip_tag_get_handler_copy { + my ( $tag, $flag ) = @_; + my $handler = snip_tag_get_handler($tag); + return snip_tag_handler_copy($handler, $flag); +} + +sub snip_tag_set_handler { + my ( $tag, $handler ) = @_; + my $old_handler = snip_tag_get_handler($tag); + if ( !$handler) { + delete($snip_tag_handlers->{$tag}); + } else { + $snip_tag_handlers->{$tag} = $handler; + } + return $old_handler; +} + +snip_tag_set_handler('for_snips', snip_tag_get_handler_copy('skip', 1)); +snip_tag_set_handler('not_for_snips', snip_tag_get_handler_copy('rem', 1)); + +sub snip_tag_get_process_handler { + my ( $tag, $process, $stage, $default ) = @_; + my $handler; + if ( exists ( $snip_tag_handlers->{$tag} )) { + $handler = $snip_tag_handlers->{$tag}; + } + if ( !$handler && $default + && exists ( $snip_tag_handlers->{$default} )) { + $handler = $snip_tag_handlers->{$default}; + } + if ( $handler && ( $process || ($handler->[ 1 ] || 0) > $stage )) { + return $handler; + } + my $msg = sprintf("[%s] prc[%d] stg[%d]", + $tag, $process, $stage); + if ( $handler ) { + $msg .= sprintf(" pri[%d]", $handler->[ 1 ] || 0); + snip_msg ( " ".":DBG: %-*s: %s\n", $dbg_fwid || 15, "handler reject", $msg || '' ) + if $DEBUG > 3; + } else { + snip_msg ( " ".":DBG: %-*s: %s\n", $dbg_fwid || 15, "no handler", + $msg ) if $DEBUG> 3; + } + return; +} + +# |||:sec:||| main processing engine +sub snips_process_line__ { + my $snip_txt = shift; + my $context = shift || snips_process_context(); + my $replace = $context->[ $snpc_ind_rpl ]; + my $process = $context->[ $snpc_ind_prc ]; + my $file_name = snips_context_filename($context); + my $line_no = ++$context->[ $snpc_ind_lno ]; + my $start_seen = $context->[ $snpc_ind_sts ]; + my $done = $context->[ $snpc_ind_stp ]; + if ( $start_seen && !$done && $replace ) { + $snip_txt = snip_replace ( $snip_txt ); + my @snt_lines = split(/[\r]*\n/, $snip_txt); + if ($#snt_lines + 1 > 1) { + # multi-line replacement, process inline + my $multi_line_filename = sprintf('', $file_name, $line_no); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, + "replacement", $multi_line_filename || '' ) + if $DEBUG > 5; + snips_process_feed_string($snip_txt, $context); + return $context; + } + } + + my $stage = 1; + # |:here:| snippet sections + # |:info:| don't run any handlers in the end section + # no `start`, no `end`: stage = 1 + # with `start`, no `end`: stage = 0 + # with `start`, with `end`: stage = 2 + # + # no `start`, with `end`: stage = 3 + $stage -= 1 if $context->[$snpc_ind_sts]; + $stage += 2 if $context->[$snpc_ind_stp]; + my $match = 0; + my $type; + my $tag; + my $targs; + if ( $snip_txt =~ m,^(($comment_start_skip_rx) *|)($double_bar_rx)[|<][-:](sn[ia]?p)[-:][>|]($double_bar_rx)([ \t\r]*([^ \t\r\n]+)([ \t\r\n]+|$))?,so ) { + $match = 1; + $type = $4 || ''; + $tag = $7 || ''; + $targs = $' || ''; + $tag =~ s,[ \t\r\n]+$,,so; + $tag =~ s,[ \t\r]*($comment_end_skip_rx).*$,,so; + $tag = snips_tag_trans ( $tag ); + $targs =~ s,[ \t\r\n]+$,,so; + $targs =~ s,[ \t\r]*($comment_end_skip_rx).*$,,so; + snip_msg ( " ".":TGM: %-*s: [%s] prc[%d] stg[%d] [%s]\n", $dbg_fwid || 15, "match tag", + $tag || '', $process, $stage, dbg_format_if_array($targs) || '' ) if $DEBUG> 3; + } + + if ( $match ) { + my $effective_process = $process && $stage == 0; + my $handler = snip_tag_get_process_handler ( $tag, $effective_process, $stage, '*' ); + if ( $handler ) { + my @result = &{$handler->[ 0 ]}( $context, $snip_txt, $targs, $tag, $type ); + $snip_txt = $result[ 0 ]; + $done = $result[ 1 ]; + if ( $done ) { + return $context; + } + } + } + + # trim line + $snip_txt =~ s,[ \t]+(\r?\n?)$,$1,so; + my $indent = $context->[$snpc_ind_ind]; + if ( $indent ) { + my $is = sprintf('%-*s', $indent, ''); + $snip_txt =~ s,^,$is,mg; + $snip_txt =~ s,[ \t]+$,,so; + } + if ( $done ) { + $context->[ $snpc_ind_ftr ] .= $snip_txt; + } else { + $context->[ $snpc_ind_txt ] .= $snip_txt; + } + return $context; +} + +sub snips_process_feed_string__ { + my $snippet = shift; + my $context = shift; + + if ( !defined ( $context )) { + snips_msg("warning: snips_process_feed_string__ called without context."); + return; + } + + if ( !defined ( $snippet )) { + $snippet = ''; + } + + my @lines = split ( /\r*\n/, $snippet."" ); # |:check:| preserve trailing blank lines + my $cont_line = ''; + my $cont_lines = 0; + my $in_cont = 0; + # |:todo:| record lines verbatim for correct reprocessing + foreach my $line ( @lines ) { + if ( $in_cont ) { + if ( $line =~ m,\\$,so ) { + $cont_line .= $`; + ++$cont_lines; + next; + } + $line = $cont_line . $line; + $in_cont = 0; + } elsif ( $line =~ m,^((($comment_start_skip_rx) *|)\|?\|(.*))\\$,so ) { + # also recognize single bar snippet tags for line continuation + $cont_line = $1; + $cont_lines = 1; + $in_cont = 1; + next; + } + + snips_process_line__ ( $line."\n", $context ); + if ( $cont_lines ) { + $context->[ $snpc_ind_lno ] += $cont_lines; + $cont_lines = 0; + } + if ( $context->[ $snpc_ind_stp ]) { + # stop replacing and processing in trailer |:check:| this seems redundant with the stage increase to 2 + $context->[ $snpc_ind_rpl ] = 0; + $context->[ $snpc_ind_prc ] = 0; + last; + } + } + return; +} + +sub snips_process_feed_string { + my $snippet = shift; + my $context = shift; + my $at_line = shift || 0; + + if ( !defined ( $context )) { + snips_msg("warning: snips_process_feed_string called without context."); + return; + } + + my $file_name = snips_context_filename($context); + my $line_no = $context->[ $snpc_ind_lno ]; + my $multi_line_filename = sprintf('', $file_name, $line_no); + $context->[ $snpc_ind_fil ] = $multi_line_filename; + $context->[ $snpc_ind_lno ] = $at_line; + $context = snips_process_feed_string__($snippet, $context); + $context->[ $snpc_ind_fil ] = $file_name; + $context->[ $snpc_ind_lno ] = $line_no; + return; +} + +sub snips_process_snippet__ { + my $snippet = shift; + my $context = shift || snips_process_context(); + $context->[ $snpc_ind_lno ] = 0; + + local ( $SNIPS_MARK ) = $SNIPS_MARK; + my $is_processing = $context->[ $snpc_ind_prc ]; + if ( $context->[ $snpc_ind_prc ]) { + # turn on marking, when processing + $SNIPS_MARK |= $SNIPS_MARK_BIT_PRC; + } + + snips_process_feed_string__($snippet, $context); + + # must replace, if not start seen. + if ( $context->[ $snpc_ind_rpl ] && ! $context->[ $snpc_ind_sts ]) { + $context->[ $snpc_ind_txt ] = + snip_replace ( $context->[ $snpc_ind_txt ] ); + } + + # if not including, unescape snippet and clean up comments + if ( !$context->[ $snpc_ind_inc ] ) { + $context->[ $snpc_ind_txt ] = + snip_unescape ( $context->[ $snpc_ind_txt ]); + if ($is_processing) { + # cleanup comments only, when processing + $context->[ $snpc_ind_txt ] = + snip_cleanup_comments ( $context->[ $snpc_ind_txt ]); + } + } + + # 0 000 => no marking, unless processing + # 1 001 => mark tagged, if processing + # 2 010 => mark untagged, if processing + # 3 011 => mark both, if processing + # 4 100 => forced marking + # 5 101 => always mark tagged + # 6 110 => always mark untagged + # 7 111 => always mark both + + if ( $SNIPS_MARK & $SNIPS_MARK_BIT_PRC ) { + # marking + my $is_tagged = scalar(@{$context->[ $snpc_ind_mrk ]}); + my $accept = 0; + if ( $is_tagged ) { + if ( $SNIPS_MARK & $SNIPS_MARK_BIT_TAG ) { + # marking tagged + $accept = 1; + } + } else { + if ( $SNIPS_MARK & $SNIPS_MARK_BIT_NTG ) { + # marking untagged + my $handler = snip_tag_get_process_handler ( 'mark', 1, 0 ); + if ( $handler ) { + &{$handler->[ 0 ]}( $context, '', '', 'mark', 'snap' ); + $accept = 1; + } + } + } + + if ( $accept ) { + snip_msg ( "+ ACCEPT %s SNIPS_MARK %s" + #." BIT_TAG %s (%s) BIT_NTG %s (%s)" + ."\n", + $is_tagged ? "TAGGED " : "untagged", binf ( $SNIPS_MARK, 3 ), + binf ( $SNIPS_MARK_BIT_TAG, 3 ), ($SNIPS_MARK & $SNIPS_MARK_BIT_TAG) ? 'y' : 'n', + binf ( $SNIPS_MARK_BIT_NTG, 3 ), ($SNIPS_MARK & $SNIPS_MARK_BIT_NTG) ? 'y' : 'n', + ) if $DEBUG > 4; + my $beg = $context->[ $snpc_ind_mrk ]->[ 0 ] ; + my $end = $context->[ $snpc_ind_mrk ]->[ 1 ]; + my $rpl = $context->[ $snpc_ind_mrk ]->[ 2 ]; + if ( $rpl ) { + $beg = snip_replace ( $beg ); + $end = snip_replace ( $end ); + } + $context->[ $snpc_ind_txt ] = + ( + $beg + .($opt_replace ? '@fempty@' : '') + .$context->[ $snpc_ind_txt ] + .$end + .($opt_replace ? '@fempty@' : '') + ); + } else { + snip_msg ( "- reject %s SNIPS_MARK %s" + #." BIT_TAG %s (%s) BIT_NTG %s (%s)" + ."\n", + $is_tagged ? "TAGGED " : "untagged", binf ( $SNIPS_MARK, 3 ), + binf ( $SNIPS_MARK_BIT_TAG, 3 ), ($SNIPS_MARK & $SNIPS_MARK_BIT_TAG) ? 'y' : 'n', + binf ( $SNIPS_MARK_BIT_NTG, 3 ), ($SNIPS_MARK & $SNIPS_MARK_BIT_NTG) ? 'y' : 'n', + ) if $DEBUG > 4; + } + } + return $context; +} + +# single line cannot really handle start/stop tags or anything else ... +sub snips_process_line { + die "error: snips_process_line has no meaningful application"; + # my $snip_txt = shift || ''; + # my $context = snips_process_context ( @_ ); + # snips_process_line__ ( $snip_txt, $context ); + # return $context->[ $snpc_ind_txt ]; +} + +sub snips_include_replacements_setup { + my $snip_title; + my $snip_title_call; + my $snip_uuid; + my $snip_uuid_call; + + $snip_title = snip_get_at_replacement('snip_title', undef); + $snip_title_call = snip_get_at_replacement('snip_title_call', undef); + + # allow title handler to set it. + snip_del_at_replacement('snip_title'); + snip_del_at_replacement('snip_title_incl'); + + # pass on current snippet info + if ( defined ( $snip_title )) { + snip_set_at_replacement('snip_title_call', $snip_title); + } else { + snip_del_at_replacement('snip_title_call'); + } + + $snip_uuid = snip_get_at_replacement('snip_uuid', undef); + $snip_uuid_call = snip_get_at_replacement('snip_uuid_call', undef); + + # allow uuid handler to set it. + snip_del_at_replacement('snip_uuid'); + snip_del_at_replacement('snip_uuid_incl'); + + # pass on current snippet info + if ( defined ( $snip_uuid )) { + snip_set_at_replacement('snip_uuid_call', $snip_uuid); + } else { + snip_del_at_replacement('snip_uuid_call'); + } + return [ $snip_title, $snip_title_call, $snip_uuid, $snip_uuid_call]; +} + +sub snips_include_replacements_analysis { + my $include_context = shift; + my ( $snip_title, $snip_title_call, $snip_uuid, $snip_uuid_call ) = @{$include_context} ; + + if (snip_is_at_replacement_defined('snip_title')) { + snip_set_at_replacement + ('snip_title_incl', + snip_get_at_replacement('snip_title')); + } else { + snip_del_at_replacement('snip_title_incl'); + } + if ( defined ( $snip_title )) { + snip_set_at_replacement('snip_title', $snip_title); + } else { + snip_del_at_replacement('snip_title'); + } + if ( defined ( $snip_title_call )) { + snip_set_at_replacement('snip_title_call', $snip_title_call); + } else { + snip_del_at_replacement('snip_title_call'); + } + + if (snip_is_at_replacement_defined('snip_uuid')) { + my $snip_uuid_incl = snip_get_at_replacement('snip_uuid'); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "snip_uuid_incl", $snip_uuid_incl || '' ) + if $DEBUG > 6; + snip_set_at_replacement('snip_uuid_incl', $snip_uuid_incl); + } else { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "snip_uuid_incl", '<<>>' || '' ) + if $DEBUG > 50; + snip_del_at_replacement('snip_uuid_incl'); + } + if ( defined ( $snip_uuid )) { + snip_set_at_replacement('snip_uuid', $snip_uuid); + } else { + snip_del_at_replacement('snip_uuid'); + } + if ( defined ( $snip_uuid_call )) { + snip_set_at_replacement('snip_uuid_call', $snip_uuid_call); + } else { + snip_del_at_replacement('snip_uuid_call'); + } +} + +# snips_process_snippet ( SNIPPET-STR[, FILENAME, [, REPLACE[, PROCESS[, INCLUDING[, FOR_SNIPS]]]]]) +sub snips_process_snippet { + my $snippet = shift; + my $file = shift || ''; + my $replace = shift; + my $process = shift; + my $including = shift || 0; + my $for_snips = shift || 0; + + my $sv_for_snips; + my $sv_not_for_snips; + if ($for_snips) { + $sv_for_snips = snip_tag_set_handler + ('for_snips', snip_tag_get_handler_copy('rem', 1)); + $sv_not_for_snips = snip_tag_set_handler + ('not_for_snips', snip_tag_get_handler_copy('skip', 1)); + } + + my $context = snips_process_context ( $replace, $process, $file ); + my $include_context; + if ( $including ) { + ++$context->[ $snpc_ind_inc ]; + $include_context = snips_include_replacements_setup(); + } + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, 'context-string', + snips_context_string($context)) if $DEBUG > 5; # |:debug:| + snips_process_snippet__ ( $snippet, $context ); + if ( $including ) { + --$context->[ $snpc_ind_inc ]; + snips_include_replacements_analysis($include_context); + } + + if ($for_snips) { + snip_tag_set_handler('for_snips', $sv_for_snips); + snip_tag_set_handler('not_for_snips', $sv_not_for_snips); + } + + if ( wantarray ) { + snip_msgc ($context, "snips_process_snippet wantarray\n", + $context->[ $snpc_ind_fil ] || 'no_file', + $context->[ $snpc_ind_lno ]) if $DEBUG > 4; + return @{$context}; + } else { + return $context->[ $snpc_ind_txt ]; + } +} + +sub snip_quote_file { + my $filei = shift; + $filei =~ s, ,\@\|snip_fn_space\@,sog; + $filei =~ s,\t,\@\|snip_fn_tab\@,sog; + $filei =~ s,\r,\@\|snip_fn_cr\@,sog; + $filei =~ s,\n,\@\|snip_fn_nl\@,sog; + return $filei; +} + +# snips_read_snippet ( FILE[, REPLACE[, PROCESS[, INCLUDING[, FOR_SNIPS ]]]]) +sub snips_read_snippet { + my $file = shift; + my $replace = shift; + my $process = shift; + my $including = shift || 0; + my $for_snips = shift || 0; + + my $sv_for_snips; + my $sv_not_for_snips; + if ($for_snips) { + $sv_for_snips = snip_tag_set_handler + ('for_snips', snip_tag_get_handler_copy('rem', 1)); + $sv_not_for_snips = snip_tag_set_handler + ('not_for_snips', snip_tag_get_handler_copy('skip', 1)); + } + + my $context = snips_process_context( $replace, $process ); + if ( $file eq '-' ) { + $context->[ $snpc_ind_fil ] = ''; + } else { + $context->[ $snpc_ind_fil ] = $file; + } + my $include_context; + if ( $including ) { + ++$context->[ $snpc_ind_inc ]; + $include_context = snips_include_replacements_setup(); + } + if ( !defined ( $context )) { + printf STDERR ( "%s\n", '|||:OOPS:|||' ); + exit ( 1 ); + } + #snip_msg ( "%s\n", Data::Dumper->Dump( [ $context ], [qw ( $context )])); + snip_msg ( " :CTX: %-*s: [%s]\n", $dbg_fwid || 15, 'context-read', + snips_context_string($context)) if $DEBUG > 5; # |:debug:| + my $snippet = snips_read_file ( $file ); + + my $sv_self = snip_get_at_replacement('snip_self', '/dev/null'); + my $sv_selfi = snip_get_at_replacement('snip_selfi', "/dev/null"); + my $sv_selfq = snip_get_at_replacement('snip_selfq', "'/dev/null'"); + + my $sv_self_dir = snip_get_at_replacement('snip_self_dir', '.'); + my $sv_self_diri = snip_get_at_replacement('snip_self_diri', "."); + my $sv_self_dirq = snip_get_at_replacement('snip_self_dirq', "'.'"); + + my $sv_self_base = snip_get_at_replacement('snip_self_base', ''); + my $sv_self_basei = snip_get_at_replacement('snip_self_basei', ""); + my $sv_self_baseq = snip_get_at_replacement('snip_self_baseq', "''"); + + my $snip_self = $file; + $snip_self =~ s,/+$,,so; + my $snip_self_dir = $snip_self; + $snip_self_dir =~ s,(.*)/[^/]*$,$1,so; + if ( $snip_self_dir eq $snip_self) { + $snip_self_dir = '.'; + } + my $snip_self_base = $snip_self; + $snip_self_base =~ s,.*/,,so; + snip_set_at_replacement('snip_self', $snip_self); + snip_set_at_replacement('snip_self_dir', $snip_self_dir); + snip_set_at_replacement('snip_self_base', $snip_self_base); + + my $snip_selfi = snip_quote_file($snip_self); + my $snip_self_diri = snip_quote_file($snip_self_dir); + my $snip_self_basei = snip_quote_file($snip_self_base); + snip_set_at_replacement('snip_selfi', $snip_selfi); + snip_set_at_replacement('snip_self_diri', $snip_self_diri); + snip_set_at_replacement('snip_self_basei', $snip_self_basei); + + my $snip_selfq = "'".sq($snip_self)."'"; + my $snip_self_dirq = "'".sq($snip_self_dir)."'"; + my $snip_self_baseq = "'".sq($snip_self_base)."'"; + snip_set_at_replacement('snip_selfq', $snip_selfq); + snip_set_at_replacement('snip_self_dirq', $snip_self_dirq); + snip_set_at_replacement('snip_self_baseq', $snip_self_baseq); + + snips_process_snippet__ ( $snippet, $context ); + + snip_set_at_replacement('snip_self', $sv_self); + snip_set_at_replacement('snip_selfi', $sv_selfi); + snip_set_at_replacement('snip_selfq', $sv_selfq); + + snip_set_at_replacement('snip_self_dir', $sv_self_dir); + snip_set_at_replacement('snip_self_diri', $sv_self_diri); + snip_set_at_replacement('snip_self_dirq', $sv_self_dirq); + + snip_set_at_replacement('snip_self_base', $sv_self_base); + snip_set_at_replacement('snip_self_basei', $sv_self_basei); + snip_set_at_replacement('snip_self_baseq', $sv_self_baseq); + + if ( $including ) { + --$context->[ $snpc_ind_inc ]; + snips_include_replacements_analysis($include_context); + } + + if ($for_snips) { + snip_tag_set_handler('for_snips', $sv_for_snips); + snip_tag_set_handler('not_for_snips', $sv_not_for_snips); + } + + if ( wantarray ) { + snip_msgc ($context, "snips_read_snippet wantarray\n", + $context->[ $snpc_ind_fil ] || 'no_file', + $context->[ $snpc_ind_lno ]) if $DEBUG > 4; + return @{$context}; + } else { + return $context->[ $snpc_ind_txt ]; + } +} + +# -------------------------------------------------- +# |||:sec:||| MAIN +# -------------------------------------------------- + +# |||:sec:||| find and process first snip_setup file +sub process_snips_setup { + my $snips_setup = "snip_setup"; + my @rc_search_dirs = (reverse(@snips_path_dirs), '.'); + foreach my $dir (@rc_search_dirs) { + my $rc = $dir . '/' . $snips_setup; + if ( -r $rc ) { + snip_msg ( "--------------------------------------------------\n") + if $DEBUG > 5; + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, + $snips_setup, $rc) if $DEBUG > 0; + snips_read_snippet( $rc, 1, 1, 1, 1 ); + last; + } + } +} +process_snips_setup(); + +# |||:sec:||| find and evaluate .snips.rc resource files +sub process_snips_rcs { + my $snips_rc = ".snips.rc"; + my @rc_search_dirs = (reverse(@snips_path_dirs), '.'); + foreach my $dir (@rc_search_dirs) { + my $rc = $dir . '/' . $snips_rc; + if ( -r $rc ) { + snip_msg ( "--------------------------------------------------\n") + if $DEBUG > 5; + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, + $snips_rc, $rc) if $DEBUG > 0; + # |:todo:| remove obsolete eval interface + do $rc; + # process rc as snippets + snips_read_snippet( $rc, 1, 1, 1, 1 ); + } else { + snip_msg ( " :DBG: %-*s: [%s]\n", $dbg_fwid || 15, + $snips_rc, 'not found in ' .$dir) if $DEBUG > 5; + } + } +} +process_snips_rcs(); + +# # clear title +# if ( $opt_title ) { +# snip_set_at_replacement('title', $opt_title); +# snip_set_at_replacement('snip_title_last', $opt_title); +# } else { +# snip_del_at_replacement('title'); +# } + +snip_msg ( "--------------------------------------------------\n") + if $DEBUG > 5; + +# |||:sec:||| --work +if ( $opt_work ) { + my $snip_txt = "'".join ( "' '", map { sq ( $_ ); } @ARGV )."'"; + mkdir ( $SNIPS_DIR, 0777 ) if ! -d $SNIPS_DIR; + chdir ( $SNIPS_DIR ) || exit ( 1 ); + my $work_file = 'WORK'; + if ( -r 'WORK_DONE' ) { + $work_file = 'WORK_DONE'; + } + snip_msg ( "%s\n", sq ( $SNIPS_DIR.'/'.$work_file )) if $VERBOSE; + system ( "work ".$snip_txt ); + exit ( 0 ); +} + +# |||:sec:||| store/list/cat/new +if (( !$opt_cat && !$opt_new && $VERBOSE ) || $DEBUG ) { + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_PATH", $SNIPS_PATH || '' ); + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_DIR", $SNIPS_DIR || '' ); + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_MODE", $SNIPS_MODE || '' ); + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_CAT", $SNIPS_CAT || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_MODE_IS_DEFAULT", $SNIPS_MODE_IS_DEFAULT || '' ) + if $DEBUG; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_CAT_IS_DEFAULT", $SNIPS_CAT_IS_DEFAULT || '' ) + if $DEBUG; + if ( $DEBUG > 5 ) { + my @user_replacement_keys = sort(keys(%{$SNIPS_REPLACEMENTS_USER})); + if ( $DEBUG > 5) { # |:todo:| move to appropriate location + foreach my $key (@user_replacement_keys) { + my $value = $SNIPS_REPLACEMENTS_USER->{$key}; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, 'user '.$key, $value || '' ); + } + } + } +} + +my ( $date, $time ) = split ( / /, $time_stamp ); +my ( $year, $month, $day ) = split ( /-/, $date ); +my ( $hours, $minutes, $seconds ) = split ( /:/, $time ); +snip_set_at_replacement ( sts => $stime ); +snip_set_at_replacement ( dts => $time_stamp ); +snip_set_at_replacement ( date => $date ); +snip_set_at_replacement ( time => $time ); +snip_set_at_replacement ( year => $year ); +snip_set_at_replacement ( month => $month ); +snip_set_at_replacement ( day => $day ); +snip_set_at_replacement ( hours => $hours ); +snip_set_at_replacement ( minutes => $minutes ); +snip_set_at_replacement ( seconds => $seconds ); + +# |||:sec:||| --store +if ( $opt_store || $opt_append ) { + my $snip_txt = join ( ' ', @ARGV ); + my $snip_tag = ''; + my $name_guess_pfx = 'txt'; + my $name_guess = ''; + if ( $opt_name && !$snip_txt ) { + # single argument => no filename, just text + if ( $opt_name ne '-' ) { + $snip_txt = $opt_name; + $opt_name = ''; + } elsif ( -r $opt_name ) { + $snip_txt = $opt_name; + $opt_name = ''; + } elsif ( $opt_name =~ m,^([^/:]+)://,so ) { + $snip_txt = $opt_name; + $opt_name = ''; + } + } + + if ( !$snip_txt || $snip_txt eq '-' ) { + # no argument, or filename == stdin + $name_guess_pfx = 'pipe'; + shift ( @ARGV ); + $snip_txt = ''; + while (<>) { + $snip_txt .= $_; + } + } elsif ( $snip_txt !~ m,[\r\n],so ) { + # single line text + if ( -r $snip_txt ) { + # readable file + my $file = $snip_txt; + $snip_tag = $file; + $name_guess_pfx = 'file'; + $name_guess = $file; + $name_guess =~ s,.*/,,so; + $name_guess =~ s,^ +,,so; + $name_guess =~ s, +$,,so; + $name_guess =~ s, ,-,sog; + $name_guess =~ s,--+,-,sog; + $name_guess =~ s,-+$,,sog; + $snip_txt = ''; + if ( open ( FILE, '<'.$file )) { + while () { + $snip_txt .= $_; + } + close ( FILE ); + } + } elsif ( $snip_txt =~ m,^([^/:]+)://,so ) { + # URL + my $proto = lc ( $1 ); + my $url = $snip_txt; + $snip_tag = $url; + $name_guess_pfx = 'url'; + $name_guess = $url; + $name_guess =~ s,^([^/:]+)://,,so; + $name_guess =~ s,^ +,,so; + $name_guess =~ s, +$,,so; + $name_guess =~ s,[^0-9A-Za-z],-,sog; + $name_guess =~ s,--+,-,sog; + $name_guess = substr ( $name_guess, 0, 20 ); + $name_guess =~ s,-+$,,sog; + $snip_txt = ''; + if ( $opt_mode ne 'html' && ( $proto eq 'http' || $proto eq 'https' )) { + my $cmd = sprintf ( "w3m -cols 150 -dump '%s'", sq ( $url )); + $snip_txt = `$cmd`; + } else { + my $cmd = sprintf ( "wget -q -O - '%s'", sq ( $url )); + $snip_txt = `$cmd`; + } + } + } + + $snip_txt =~ s,[ \t\r\n]+$,,so; + + my $opt_name_guessed = ''; + + if ($SNIPS_CAT && ( !$SNIPS_CAT_IS_DEFAULT || !$SNIPS_MODE_IS_DEFAULT || !$name_guess_pfx)) { + $name_guess_pfx = $SNIPS_CAT; + } + + if ( !$opt_name ) { + if ( !$name_guess || $opt_title ) { + if ( $opt_title ) { + $name_guess = $opt_title; + } else { + $name_guess = $snip_txt; + } + $name_guess =~ s,^[^0-9A-Za-z]+,,so; + $name_guess =~ s,\n.*,,so; + $name_guess =~ s,[ \t\r]+$,,so; + $name_guess =~ s,[^0-9A-Za-z],-,sog; + $name_guess =~ s,--+,-,sog; + $name_guess = substr ( $name_guess, 0, 20 ); + $name_guess =~ s,-+$,,sog; + } + $opt_name_guessed = $name_guess_pfx.'_'.strftime( "%Y%m%d-%H%M%S", localtime ( time())).( $name_guess ? '_' : '' ).$name_guess; + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_name_guessed", + $opt_name_guessed || '' ) if $DEBUG; + } else { + if ( $opt_name ne '-') { + my $cat_pfx_part = $opt_name; + $cat_pfx_part =~ s,[.].*,,so; + if ( $cat_pfx_part !~ m,_,so ) { + # no category defined + $opt_name = $name_guess_pfx.'_'.$opt_name; + } else { + $name_guess_pfx = $cat_pfx_part; + $name_guess_pfx =~ s,_.*,,so; + } + } + } + + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "name_guess_pfx(i)", $name_guess_pfx || '' ) + if $DEBUG > 5; + + my $mode; + if ( $SNIPS_MODE_IS_DEFAULT && $name_guess_pfx ) { + $mode = snip_set_default_mode($name_guess_pfx); + } else { + $mode = snip_set_default_mode(); + } + + if ( $VERBOSE ) { + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_MODE(eff)", $SNIPS_MODE || '' ); + snip_msg ( " ".":INF: %-*s: [%s]\n", $dbg_fwid || 15, "SNIPS_CAT(eff)", $SNIPS_CAT || '' ); + } + + if ( !$opt_name ) { + $opt_name = $opt_name_guessed; + } + + if ( !$snip_txt ) { + snip_msg ( "warning: storing empty snippet\n" ) if $VERBOSE; + } + + my $snip_file; + my $hdr; + my $ftr; + # :struct: snips_header_footer SNIPS header/footer + # i use header/footer + # t read header/footer from snippet + # - + # i forced store AND no header/footer yet + # t read snippet header/footer from file + # - + # i NO header/footer + # t use default header/footer + # :struct: + + if ( $opt_use_hdr || $opt_use_ftr ) { + # just split it + # ||:todo:|| use text chunk stack a la qp-ascii-render.pl + snip_msg ( " ".":HDR: %-*s: hdr[%d] ftr[%d]]\n", $dbg_fwid || 15, + "opt_use_hdr/ftr", $opt_use_hdr || 0, $opt_use_ftr || 0 ) + if $DEBUG; + my @context = snips_process_snippet ( $snip_txt, '', 0, 0, 1 ); + if ( $opt_use_hdr ) { + $hdr = $context[ $snpc_ind_hdr ]; + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, "opt hdr", dbg_flatten_str($hdr || '')) + if $DEBUG; + } + $snip_txt = $context[ $snpc_ind_txt ]; + $snip_txt =~ s,\n$,,so; + if ( $opt_use_ftr ) { + $ftr = $context[ $snpc_ind_ftr ]; + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, "opt ftr", dbg_flatten_str($ftr || '')) + if $DEBUG; + } + } + + local ( *FILE ); + if ( $opt_name eq '-' ) { + my $rep_filename = snip_get_at_replacement ( 'filename' ); + if ( $rep_filename ) { + $snip_file = $rep_filename; + } else { + $snip_file = ''; + } + *FILE = *STDOUT; + } else { + $snip_file = $SNIPS_DIR.'/'.$opt_name; + if ( $opt_append ) { + $opt_force = 1; + } + if ( -r $snip_file ) { + if ( $opt_force ) { + local ( $VERBOSE ) = 0; + # ||:todo:|| use text chunk stack a la qp-ascii-render.pl + my @context = snips_read_snippet ( $snip_file, 0, 0 ); + if ( !$hdr ) { + $hdr = $context[ $snpc_ind_hdr ]; + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, "snippet hdr", dbg_flatten_str($hdr || '')) + if $DEBUG; + } + if ( !$ftr ) { + $ftr = $context[ $snpc_ind_ftr ]; + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, "snippet ftr", dbg_flatten_str($ftr || '')) + if $DEBUG; + } + if ( $opt_append ) { + my $txt = $context[ $snpc_ind_txt ]; + $snip_txt = $txt . $snip_txt; + } + } else { + snip_msg ( "error: snippet `%s` exists\n", $snip_file ); + exit ( 1 ); + } + } + mkdir ( $SNIPS_DIR, 0777 ) if ! -d $SNIPS_DIR; + if ( !open ( FILE, '>'.$snip_file )) { + snip_msg ( "error: writing snippet `%s` failed\n", $snip_file ); + exit ( 1 ); + } + if ( !$SNIPS_MODE && !$SNIPS_CAT ) { + $SNIPS_CAT = $opt_name; + $SNIPS_CAT =~ s,_.*,,so; + } + } + my $hf_file = $snip_file; + $hf_file =~ s,.*/,,so; + my $hf_base = $hf_file; + $hf_base =~ s,[.][^.]*$,,so; + snip_set_at_replacement('filename', $hf_file ); + snip_set_at_replacement('filebase', $hf_base ); + if ( !$hdr ) { + snips_ensure_snippets_collected( @snips_path_dirs ); + $hdr = snip_header_for_mode( $mode ); + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, sprintf("mode hdr (%s)", $mode), dbg_flatten_str($hdr || '')) + if $DEBUG; + } + if ( !$ftr ) { + snips_ensure_snippets_collected( @snips_path_dirs ); + $ftr = snip_footer_for_mode( $mode ); + snip_msg ( " ".":HDR: %-*s: [%s]\n", $dbg_fwid || 15, sprintf("mode ftr (%s)", $mode), dbg_flatten_str($ftr || '')) + if $DEBUG; + } + + if ( !$opt_literal ) { + $snip_txt = snip_escape ( $snip_txt ); + } + + my $snippet = ''; + $snippet .= $hdr; + $snippet .= snip_tag_start ( $snip_tag ); + if ( $snip_txt ) { + $snippet .= $snip_txt."\n"; + } + $snippet .= snip_tag_stop(); + $snippet .= $ftr; + + # |:todo:| final output hook + if ($SNIPS_MODE eq 'rst') { + $snippet =~ s,^[.][.] ?[|][|]<-,.. \\||<-,mog; + } + + print FILE $snippet; + + close ( FILE ) if $opt_name ne '-'; + snip_msg ( "snippet `%s` stored\n", $snip_file ) if $VERBOSE; + exit ( 0 ); +} + +# |||:sec:||| setup list/cat +snips_collect_snippets( @snips_path_dirs ); +# snip_msg ( "%s\n", Data::Dumper->Dump( [ $SNIPS_BY_CAT ], [qw ( $SNIPS_BY_CAT )])); +my @categories = sort ( keys ( %{$SNIPS_BY_CAT})); + +if ( $DEBUG ) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_ignore_cat_rx", $opt_ignore_cat_rx || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_accept_cat_rx", $opt_accept_cat_rx || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_name_rx", $opt_name_rx || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "categories", join ( ', ', @categories )); +} + +# |||:sec:||| --list +if ( $opt_list ) { + if ( $prog_name =~ m,^sn..?$, && -l $0 ) { + $prog_name = readlink ( $0 ); + $prog_name =~ s,.*/,,so; + } + if ( $opt_as_includes ) { + $SNIPS_DEF_MODE = 'generic'; + $opt_accept_cat_seen = 1; + $SNIPS_MODE = snip_set_default_mode(); + my $snips_cmd = $SNIPS_COMMENT_START_SEP.snip_ptagf ( "include ", ); + snips_iterate ( \&snips_cb_list_as_includes, [ $snips_cmd, $SNIPS_COMMENT_END_SEP ]); + } else { + my @user_replacement_keys = sort(keys(%{$SNIPS_REPLACEMENTS_USER})); + my $snips_cmd = + sprintf ( "%s" ."%s" ."%s" ."%s" ."%s" ."%s" ."%s" ."%s" ."%s" ."%s" + ." --cat ", + $prog_name, + $VERBOSE > 1 ? ' --verbose' : '', + $opt_replace ? ' --replace' : '', + $opt_process ? ' --process' : '', + $opt_accept_cat_seen ? + sprintf ( " --accept-cat '%s'", sq ( $opt_accept_cat_rx )) : '', + $opt_ignore_cat_seen ? + sprintf ( " --ignore-cat '%s'", sq ( $opt_ignore_cat_rx )) : '', + sprintf ( " --mode '%s'", $opt_mode_seen ? sq ( $opt_mode ) : '@mode@'), + $opt_mode_main_only ? ' --main-only' : '', + $opt_dir_seen ? + join ( '', map { sprintf ( " --dir '%s'", sq ( $_ )) } @opt_dirs ) : '', + join ( '', map { my $key = $_; + my @nkeys = snip_normalize_at_key( $key ); + my $nkey = $nkeys[ 1 ]; + my $res = sprintf ( " --key '%s'", sq( $nkey )); + my $value = $SNIPS_REPLACEMENTS_USER->{$key}; + if ( defined ( $value )) { + $res .= sprintf ( " --value '%s'", sq ( $value )); + } + $res; + } @user_replacement_keys), + ); + my $mode_rep = snip_get_at_replacement( 'mode' ); + my $sv_replacements = snip_replacements_save( {} ); + snip_set_at_replacement( 'mode', $mode_rep ); + snips_iterate ( \&snips_cb_list, $snips_cmd ); + snip_replacements_restore($sv_replacements); + } + exit ( 0 ); +} + +my $grep_next_is_e = 0; +my $grep_opt_done = 0; +sub grep_arg_quote { + my $opt = shift; + if ( $grep_opt_done ) { + return " '".sq( $opt )."'"; + } + if ( $grep_next_is_e ) { + $grep_next_is_e = 0; + return " '".sq( $opt )."'"; + } + if ( m/^--as/ ) { + $opt_as_includes = 1; + return ''; + } + if ( $opt =~ m/^(-e|--reg)/) { + $grep_next_is_e = 1; + return ' '.$opt; + } + if ( $opt eq '--' ) { + $grep_opt_done = 1; + return ' '.$opt; + } + return " '".sq( $opt )."'"; +} + +# |||:sec:||| --grep +if ( $opt_grep ) { + $opt_grep_opts = join ( '', map { + grep_arg_quote ( $_ ); + } @opt_grep_opts ); + if ( !$opt_grep_opts ) { + snip_msg ( "warning: empty grep options\n" ) if $VERBOSE; + exit ( 0 ); + } + if ( $opt_as_includes ) { + $opt_grep_opts = ' -l'.$opt_grep_opts; + } + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_grep_opts", $opt_grep_opts || '' ) if $DEBUG; + if ( $prog_name =~ m,^sn..?$, && -l $0 ) { + $prog_name = readlink ( $0 ); + $prog_name =~ s,.*/,,so; + } + if ( $opt_as_includes ) { + $SNIPS_DEF_MODE = 'generic'; + $opt_accept_cat_seen = 1; + $SNIPS_MODE = snip_set_default_mode(); + my $snips_cmd = sprintf ( "%s|\:snap:| include ", $SNIPS_COMMENT_START_SEP ); + snips_iterate ( \&snips_cb_grep_as_includes, [ $snips_cmd, $SNIPS_COMMENT_END_SEP ]); + } else { + my $snips_cmd = '# not used'; + snips_iterate ( \&snips_cb_grep, $snips_cmd ); + } + exit ( 0 ); +} + +# |||:sec:||| setup cat/new +{ + # # clear title + # if ( $opt_title ) { + # snip_set_at_replacement('title', $opt_title); + # snip_set_at_replacement('snip_title_last', $opt_title); + # } else { + # snip_del_at_replacement('title'); + # } + + # more deduced replacements + my $fnr = snip_get_at_replacement ( 'filename' ); + if ( $fnr ) { + my $fbr = snip_get_at_replacement ( 'filebase' ); + if ( !$fbr ) { + $fbr = $fnr; + $fbr =~ s,[.][^.]*$,,so; + snip_set_at_replacement ( 'filebase', $fbr ); + } + } +} + +if ( $DEBUG ) { + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "comment_start_skip_rx", $comment_start_skip_rx || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "comment_end_skip_rx", $comment_end_skip_rx || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_process", $opt_process || '' ); + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "opt_replace", $opt_replace || '' ); + if ( $opt_replace && $DEBUG > 4 ) { + foreach my $rkey ( sort ( keys %{$SNIPS_REPLACEMENTS})) { + my $rval = $SNIPS_REPLACEMENTS->{$rkey}; + snip_msg ( " %-26s => [%s]\n", "[".$rkey."]", dbg_flatten_str($rval)); + } + snip_msg ( " ".":DBG: %-*s: [%s]\n", $dbg_fwid || 15, "snip_replace_rx", + snip_fmt_rx ( snip_replace_rx()) || '' ); + } +} + +# |||:sec:||| --cat +if ( $opt_cat ) { + # Make sure, that all appropriate files are found ... + my $files; + if ( $opt_name_rx eq '-' ) { + # special snippet name + # if next argument is text, it is used as snippet text + # otherwise, the snippet is read from standard input. + $files = [ $opt_name_rx ]; + if ( $opt_temp_snippet ) { + my $snip_txt = snips_process_snippet ( $opt_temp_snippet, '' ); + # |:todo:| final output hook + if ($SNIPS_MODE eq 'rst') { + $snip_txt =~ s,^[.][.] ?[|][|]<-,.. \\||<-,mog; + } + print STDOUT $snip_txt; + exit ( 0 ); + } + } elsif ( -r $opt_name_rx ) { + $files = [ $opt_name_rx ]; + } else { + if ($SNIPS_CAT_IS_DEFAULT) { + $opt_accept_cat_rx = '.*'; + } + $files = snips_find_file ( 0, $opt_all, $opt_name_rx ); + } + + if ( $#{$files} < 0 ) { + snip_msg ( "warning: no snippet matching `%s` found\n", $opt_name_rx ) if $VERBOSE; + exit ( 1 ); + } else { + # ... before setting a mode that may prevent some files to be acepted. + # However, a default mode is needed to replace comments and such. + snip_set_default_mode(); + foreach my $file ( @{$files} ) { + if ($SNIPS_MODE_IS_DEFAULT) { + my $cat_pfx_part = $file; + $cat_pfx_part =~ s,.*/,,so; + $cat_pfx_part =~ s,[.].*,,so; + if ( $cat_pfx_part !~ m,_,so ) { + snip_set_default_mode(); + } else { + snip_set_mode($cat_pfx_part); + } + } + my $snip_txt = snips_read_snippet ( $file ); + if ( $opt_replace ) { + # final replacement + $snip_txt = snip_replace_final($snip_txt); + } + # |:todo:| final output hook + if ($SNIPS_MODE eq 'rst') { + $snip_txt =~ s,^[.][.] ?[|][|]<-,.. \\||<-,mog; + } + print STDOUT $snip_txt; + } + } + exit ( 0 ); +} + +# |||:sec:||| --new +if ( $opt_new ) { + $opt_name_rx = '^('.$opt_name.')$'; + my $files = snips_find_file ( 0, 0, $opt_name_rx ); + if ( $#{$files} < 0 ) { + snip_msg ( "warning: no snippet matching `%s` found\n", $opt_name_rx ) if $VERBOSE; + exit ( 1 ); + } else { + local ( *OUT ); + if ( $opt_filename ne '-' ) { + if ( !$opt_force && -r $opt_filename ) { + snip_msg ( "error: output file `%s` exists\n", $opt_filename ); + exit ( 1 ); + } + open ( OUT, '>'.$opt_filename ); + } else { + *OUT = *STDOUT; + } + foreach my $file ( @{$files} ) { + my $snip_txt = snips_read_snippet ( $file ); + if ( $opt_replace ) { + # final replacement + $snip_txt = snip_replace_final($snip_txt); + } + # |:todo:| final output hook + if ($SNIPS_MODE eq 'rst') { + $snip_txt =~ s,^[.][.] ?[|][|]<-,.. \\||<-,mog; + } + print OUT $snip_txt; + } + close ( OUT ) if $opt_filename ne '-'; + } + exit ( 0 ); +} + +__END__ # |:here:| +# +# :ide-menu: Emacs IDE Main Menu - Buffer @BUFFER@ +# . M-x `eIDE-menu' (eIDE-menu "z") + +# :ide: Find related classes +# . (shell-command (concat "find -name '*.pm' | sort | grep -v '^\\./" (file-name-nondirectory (buffer-file-name)) "$' | sed 's,^\\./,,;s,/,::,g;s,\\.pm,,;s,^,# - L<,;s,$,>,'")) + +# :ide: Extract API: +# . (shell-command (concat "grep -e '^#[^.]*\\(VOID\\| = \\).*(.*)' " (buffer-file-name) " | sed 's,^#!,# ,;s,\\(.*VOID\\|.* =\\) *\\([0-9A-Za-z_]*\\),\\1 L<#\\2>,'")) + +# :ide: Extract main API: +# . (shell-command (concat "grep -e '^#!' " (buffer-file-name) " | sed 's,^#!,# ,;s,\\(.*VOID\\|.* =\\) *\\([0-9A-Za-z_]*\\),\\1 L<#\\2>,'")) + +# :ide: Show main API +# . (occur "^#!" nil) + +# :ide: Show SUB protos +# . (occur "^#[^.\n]*\\(VOID\\| = \\).*(.*)" nil) + +# :ide: Show SUBS +# . (occur "^sub[ \t]" nil) + +# :ide: +=#=+ +# . Utilities () + +# :ide: TEXT: Insert `# ----- ...' (before line) +# . (let ((f (concat "# --------------------------------------------------\n# " (symbol-tag-make-tag "here") "\n")) (s "") b) (save-excursion (beginning-of-line) (setq b (point)) (insert-before-markers (format f (pp-to-string s))) (indent-region b (point) nil))) + +# :ide: +=#=+ +# . Text () + +# :ide: TEXT: Insert `headline' (w/prompt before line, quoted) +# . (let ((f "# --------------------\nheadline ( %s );\n") (s (read-from-minibuffer "Headline: ")) b) (save-excursion (beginning-of-line) (setq b (point)) (insert-before-markers (format f (pp-to-string s))) (indent-region b (point) nil))) + +# :ide: TEXT: Insert `show_objs' (w/prompt at point) +# . (let ((f "%sshow_objs ( '%s' );\n") (r (read-from-minibuffer "Assign to: " nil nil nil nil "$OBJ")) (s (read-from-minibuffer "Expression: " (quote ( "$OBJ" . 0 )))) b) (or (equal r "") (setq r (concat r " = "))) (insert (format f r s))) + +# :ide: TEXT: Insert `show_str' (w/prompt at point) +# . (let ((f "%sshow_str ( '%s' );\n") (r (read-from-minibuffer "Assign to: " nil nil nil nil "$ref")) (s (read-from-minibuffer "Expression: " (quote ( "$OBJ" . 0 )))) b) (or (equal r "") (setq r (concat r " = "))) (insert (format f r s))) + +# :ide: TEXT: Insert `show_exp' (w/prompt at point) +# . (let ((f "%sshow_exp ( '%s' );\n") (r (read-from-minibuffer "Assign to: " nil nil nil nil "$str")) (s (read-from-minibuffer "Expression: " (quote ( "$OBJ->()" . 7 )))) b) (or (equal r "") (setq r (concat r " = "))) (insert (format f r s))) + +# :ide: TEXT: Insert `hl' (w/prompt before line, quoted) +# . (let ((f "# --------------------\nhl ( %s );\n") (s (read-from-minibuffer "Headline: ")) b) (save-excursion (beginning-of-line) (setq b (point)) (insert-before-markers (format f (pp-to-string s))) (indent-region b (point) nil))) + +# :ide: +=#=+ +# . Test Utilities () + +# :ide: COMPILE: Read args +# . (let ((args (read-from-minibuffer "Args: "))) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --help +# . (let ((args "--help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --install +# . (let ((args "--install")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --dist +# . (let ((args "--dist")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: Standard +# . (let ((args "")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: SNIPS_DIR=somewhere/out/there .. b +# . (let ((args "b")) (save-buffer) (compile (concat "SNIPS_DIR='somewhere/out/there' perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --accept-cat sh --list +# . (let ((args "--accept-cat sh --list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --accept-cat pl --list +# . (let ((args "--accept-cat pl --list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --accept-cat pl --list=o +# . (let ((args "--accept-cat pl --list=o")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --debug --mode html --store - http://www.simul.de +# . (let ((args "--debug --mode html --store - http://www.simul.de")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --mode text --list +# . (let ((args "--mode text --list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: CMD: RAW "snippets.pl --key '@file@' --val 'file_replaced' --no-replace --cat '^snt_hello-world$' +# . (shell-command "snippets.pl --key '@file@' --val 'file_replaced' --no-replace --cat '^snt_hello-world$'" nil nil) + +# :ide: CMD: PROCESSED "snippets.pl --key '@file@' --val 'file_replaced' --no-replace --process --cat '^snt_hello-world$' +# . (shell-command "snippets.pl --key '@file@' --val 'file_replaced' --no-replace --process --cat '^snt_hello-world$'" nil nil) + +# :ide: CMD: REPLACED "snippets.pl --key '@file@' --val 'file_replaced' --replace --cat '^snt_hello-world$' +# . (shell-command "snippets.pl --key '@file@' --val 'file_replaced' --replace --cat '^snt_hello-world$'" nil nil) + +# :ide: CMD: DEBUG "snippets.pl --debug=5 -r -p --key '@file@' --val 'file_replaced' --cat '^snt_hello-world$' +# . (shell-command "snippets.pl --debug=5 -r -p --key '@file@' --val 'file_replaced' --cat '^snt_hello-world$'" nil nil) + +# :ide: CMD: RPL+PRC "snippets.pl -r -p --key '@file@' --val 'file_replaced' --cat '^snt_hello-world$' +# . (shell-command "snippets.pl -r -p --key '@file@' --val 'file_replaced' --cat '^snt_hello-world$'" nil nil) + +# :ide: CMD: RPL+PRC "snippets.pl --append 'snt_hello-world' 'ein bisschen appended ...' +# . (shell-command "snippets.pl --append 'snt_hello-world' 'ein bisschen appended ...'" nil nil) + +# :ide: COMPILE: --list +# . (let ((args "--list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --debug --as-includes --list +# . (let ((args "--debug --as-includes --list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --debug --list +# . (let ((args "--debug --list")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --debug --replace --process --mode 'emacs-lisp' --cat - TEMP-SNIPPET +# . (let ((args (concat "--debug --replace --process --mode 'emacs-lisp' --cat -")) (txt (snip-shell-single-quote "# |\:snp\:| include ^gen_hd-configuration$\n# |\:snp\:| include ^gen_hd-functions$\n# |\:snp\:| include ^gen_hd-main$\n# |\:snp\:| include ^gen_hd-setup$\n" ))) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args " " txt))) + +# :ide: COMPILE: echo TEMP-SNIPPET | --debug --replace --process --mode 'emacs-lisp' --cat - +# . (let ((args (concat "--debug --replace --process --mode 'emacs-lisp' --cat -")) (txt (snip-shell-single-quote "# |\:snp\:| include ^gen_hd-configuration$\n# |\:snp\:| include ^gen_hd-functions$\n# |\:snp\:| include ^gen_hd-main$\n# |\:snp\:| include ^gen_hd-setup$\n" ))) (save-buffer) (compile (concat "echo " txt " | perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: CLN: Clean file (remove excess blank lines and whitespace) +# . (let () (save-excursion (goto-char (point-min)) (set-buffer-modified-p t) (replace-regexp "\n\n\n+" "\n\n" nil) (c-beautify-buffer) (save-buffer))) + +# :ide: COMPIlE: "echo 'hello @where@' | snr --debug=7 --key 'hello' --value 'not-so' --key '@where@' --value 'what?' -" +# . (compile "echo 'hello @where@' | snr --debug=7 --key 'hello' --value 'not-so' --key '@where@' --value 'what?' -") + +# :ide: COMPIlE: snr --debug=7 el_new +# . (compile "snr --debug=7 el_new") + +# :ide: COMPIlE: snc --debug=7 el_new +# . (compile "snc --debug=7 -m el el_new") + +# :ide: COMPILE: --debug=7 --mode html --store - http://www.simul.de +# . (let ((args "--debug=7 --mode html --store - http://www.simul.de")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPIlE: snr --debug=7 snip_setup +# . (compile "snr --debug=7 -m gen --accept-cat '^(snip)$' snip_setup") + +# :ide: COMPIlE: snr --debug=7 snip_check.define +# . (compile "snr --debug=7 -m gen --accept-cat '^(snip)$' snip_check.define") + +# :ide: COMPIlE: snc --debug=7 --no-skip snip_check.define +# . (compile "snc --debug=7 --no-skip -m gen --accept-cat '^(snip)$' snip_check.define") + +# :ide: COMPIlE: snc --debug=7 snip_check.define +# . (compile "snc --debug=7 -m snip snip_check.define") + +# :ide: COMPIlE: snr --debug=7 whereis_new +# . (compile "snr --debug=7 -m whereis whereis_new") + +# :ide: COMPIlE: snr --debug=7 --mark=3 whereis_new +# . (compile "snr --debug=7 --mark=3 -m whereis whereis_new") + +# :ide: COMPIlE: snr --mark=3 whereis_new +# . (compile "snr --mark=3 -m whereis whereis_new") + +# :ide: COMPIlE: sns --mode snip check.store ' ' +# . (compile "rm -f /home/ws/snippets/snip_check.store; sns --debug=7 --mode snip check.store ' '; cat /home/ws/snippets/snip_check.store") + +# :ide: +-#+ +# . Other Checks () + +# :ide: QUO: $snpu_ind_ +# . (insert "$snpu_ind_" ) + +# :ide: +-#+ +# . Quotes () + +# :ide: SNIP: myself +# . (snip-cat-mode (concat "" (buffer-file-name)) nil) + +# :ide: RST: myself => HTML, xdg-open +# . (let* ((b (buffer-file-name)) (o (concat b ".html"))) (compile (concat "perl " b " --rst-help | rst2html.py --traceback --cloak-email-addresses >" o " && xdg-open " o "; sleep 2; rm -f " o))) + +# :ide: RST: myself => HTML +# . (let ((args "--rst-help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args " | rst2html.py --traceback --cloak-email-addresses"))) + +# :ide: COMPILE: --rst-min-help +# . (let ((args "--rst-min-help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --rst-help +# . (let ((args "--rst-help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --help +# . (let ((args "--help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: COMPILE: --debug=7 --help +# . (let ((args " --debug=7 --help")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: +-#+ +# . HELP () + +# :ide: COMPIlE: snr --debug=7 snip_check.verbatim +# . (compile "snr --debug=7 snip_check.verbatim") + +# :ide: QUO: ->{'|:fillme:|'} +# . (insert "->{'|\:fillme\:|'}" ) + +# :ide: QUO: $chunk->{'|:fillme:|'} +# . (insert "$chunk->{'|\:fillme\:|'}" ) + +# :ide: COMPIlE: snr snip_check.verbatim +# . (let ((args " --process --replace --cat snip_check.verbatim")) (save-buffer) (compile (concat "perl -I./lib -I../lib -I.. -I../.. -w " (buffer-file-name) " " args))) + +# :ide: +-#+ +# . Verbatim () + +# +# Local Variables: +# mode: perl +# truncate-lines: t +# End: