: #!/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: