File Coverage

blib/lib/Sieve/Generator/Sugar.pm

Criterion	Covered	Total	%
statement	148	153	96.7
branch	25	32	78.1
condition	8	8	100.0
subroutine	37	38	97.3
pod	20	20	100.0
total	238	251	94.8

use v5.36.0;

package Sieve::Generator::Sugar 0.003;
# ABSTRACT: constructor functions for building Sieve generator objects

use JSON::MaybeXS ();
use Params::Util qw(_ARRAY0 _HASH0 _SCALAR0);

use experimental 'builtin', 'for_list';
use builtin 'blessed';

use Sub::Exporter -setup => [ qw(
  blank
  block
  command
  test
  comment
  set
  sieve
  heredoc
  ifelse

  allof
  anyof
  noneof

  bool
  hasflag
  negate
  number
  qstr
  terms
  var_eq
  var_ne
) ];

use Sieve::Generator::Element::Block;
use Sieve::Generator::Element::Command;
use Sieve::Generator::Element::Comment;
use Sieve::Generator::Element::Document;
use Sieve::Generator::Element::Heredoc;
use Sieve::Generator::Element::IfElse;
use Sieve::Generator::Element::Junction;
use Sieve::Generator::Element::Num;
use Sieve::Generator::Element::Qstr;
use Sieve::Generator::Element::QstrList;
use Sieve::Generator::Element::Terms;

#pod =head1 SYNOPSIS
#pod
#pod   use Sieve::Generator::Sugar '-all';
#pod
#pod   my $script = sieve(
#pod     command('require', [ qw(fileinto imap4flags) ]),
#pod     blank(),
#pod     ifelse(
#pod       header_exists('X-Spam'),
#pod       block(
#pod         command('addflag', '$Junk'),
#pod         command('fileinto', 'Spam'),
#pod       ),
#pod     ),
#pod   );
#pod
#pod   print $script->as_sieve;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module exports constructor functions for building
#pod L object trees.  All functions can be imported at once
#pod with the C<-all> tag.
#pod
#pod Because many of the function names (C, C, C, and so on)
#pod are common words that may clash with existing code, L allows
#pod all imported symbols to be given a prefix:
#pod
#pod   use Sieve::Generator::Sugar -all => { -prefix => 'sv_' };
#pod
#pod With that import, each function is available under its prefixed name, e.g.
#pod C, C, C, and so on.
#pod
#pod =func comment
#pod
#pod   my $comment = comment($text);
#pod   my $comment = comment($text, { hashes => 2 });
#pod
#pod This function creates a L with the given
#pod content.  The content may be a plain string or an object doing
#pod L.  The optional second argument is a hashref; its
#pod C key controls how many C<#> characters prefix each line, defaulting
#pod to one.
#pod
#pod =cut

sub comment ($content, $arg = undef) {
  return Sieve::Generator::Element::Comment->new({
    ($arg ? %$arg : ()),
    content => $content,
  });
}

#pod =func command
#pod
#pod   my $cmd = command($identifier, (\%tagged?), @args);
#pod
#pod This function creates a L with the given
#pod identifier and arguments.  Arguments may be plain strings or objects doing
#pod L.  The command renders as a semicolon-terminated
#pod Sieve statement.
#pod
#pod =cut

my sub _command ($identifier, $meta_arg, @args) {
  my $tagged_args;

  if (@args && _HASH0($args[0]) && !blessed($args[0])) {
    my $tagged_input = shift @args;

    for my ($k, $v) (%$tagged_input) {
      # The underlying data structure is designed so we can represent this:
      #
      #   :arg v1 v2 v3
      #
      # ...but there's currently
      $tagged_args->{$k} = !defined $v  ? []
                         : blessed($v)  ? [ $v ]
                         : !ref $v      ? [ Sieve::Generator::Element::Qstr->new({ str => $v }) ]
                         : _ARRAY0($v)  ? [ Sieve::Generator::Element::QstrList->new({ strs => $v }) ]
                         : _SCALAR0($v) ? [ Sieve::Generator::Element::Terms->new({ terms => [$$v] }) ]
                         : Carp::confess("unknown reference type $v passed in Sieve command sugar's tagged args");
    }
  }

  my @autoquoted_args = map {;
                           blessed($_)  ? $_
                         : !ref $_      ? Sieve::Generator::Element::Qstr->new({ str => $_ })
                         : _ARRAY0($_)  ? Sieve::Generator::Element::QstrList->new({ strs => $_ })
                         : _SCALAR0($_) ? Sieve::Generator::Element::Terms->new({ terms => [$$_] })
                         : Carp::confess("unknown reference type $_ passed in Sieve command sugar's positional args");
                        } @args;

  return Sieve::Generator::Element::Command->new({
    %$meta_arg,

    identifier  => $identifier,
    tagged_args => $tagged_args // {},
    positional_args => \@autoquoted_args,
  });
}

sub command ($identifier, @args) {
  _command($identifier, {}, @args);
}

#pod =func test
#pod
#pod   my $test = test($identifier, (\%tagged?), @args);
#pod
#pod This function creates a L with the given
#pod identifier and arguments -- and semicolon-at-the-end turned off.  In the
#pod future, this might produce a distinct object, but for now, and really in Sieve,
#pod commands and tests are I the same thing.
#pod
#pod =cut

sub test ($identifier, @args) {
  _command($identifier, { autowrap => 0, semicolon => 0 }, @args);
}

#pod =func set
#pod
#pod   my $cmd = set($variable, $value);
#pod
#pod This function creates a L for the Sieve
#pod C command (RFC 5229).  Both C<$variable> and C<$value> are automatically
#pod quoted as Sieve strings.
#pod
#pod =cut

sub set ($var, $val) {
  return Sieve::Generator::Element::Command->new({
    identifier => 'set',
    positional_args => [
      Sieve::Generator::Element::Qstr->new({ str => $var }),
      Sieve::Generator::Element::Qstr->new({ str => $val }),
    ],
  });
}

#pod =func ifelse
#pod
#pod   my $if = ifelse($condition, $block);
#pod   my $if = ifelse($cond, $if_block, [ $condN, $elsif_blockN ] ..., $else_block);
#pod
#pod This function creates a L.  The first two
#pod arguments are the condition and the block to execute when it is true.
#pod Additional condition/block pairs render as C clauses.  If the total
#pod number of trailing arguments is odd, the final argument is used as the plain
#pod C block.
#pod
#pod =cut

sub ifelse ($cond, $if_true, @rest) {
  my $else = @rest % 2 ? (pop @rest) : undef;

  return Sieve::Generator::Element::IfElse->new({
    cond   => $cond,
    true   => $if_true,
    elsifs => \@rest,
    ($else ? (else => $else) : ()),
  });
}

#pod =func blank
#pod
#pod   my $blank = blank();
#pod
#pod This function creates an empty L.  It is
#pod typically used to insert a blank line between sections of a Sieve script.
#pod
#pod =cut

sub blank () {
  return Sieve::Generator::Element::Document->new({ things => [] });
}

#pod =func sieve
#pod
#pod   my $doc = sieve(@things);
#pod
#pod This function creates a L from the given
#pod C<@things>.  The document is the top-level container for a Sieve script; its
#pod C method renders the full script as a string.
#pod
#pod =cut

sub sieve (@things) {
  return Sieve::Generator::Element::Document->new({ things => \@things });
}

#pod =func block
#pod
#pod   my $block = block(@things);
#pod
#pod This function creates a L containing the
#pod given C<@things>.  A block renders as a brace-delimited, indented sequence of
#pod statements, as used in Sieve C/C/C constructs.
#pod
#pod =cut

sub block (@things) {
  return Sieve::Generator::Element::Block->new({ things => \@things });
}

#pod =func allof
#pod
#pod   my $test = allof(@tests);
#pod
#pod This function creates a L that renders as
#pod a Sieve C test, which is true only when all of the given tests
#pod are true.
#pod
#pod =cut

sub allof (@things) {
  return Sieve::Generator::Element::Junction->new({
    type => 'allof',
    things => \@things,
  });
}

#pod =func anyof
#pod
#pod   my $test = anyof(@tests);
#pod
#pod This function creates a L that renders as
#pod a Sieve C test, which is true when any of the given tests is
#pod true.
#pod
#pod =cut

sub anyof (@things) {
  return Sieve::Generator::Element::Junction->new({
    type => 'anyof',
    things => \@things,
  });
}

#pod =func noneof
#pod
#pod   my $test = noneof(@tests);
#pod
#pod This function creates a L that renders as
#pod a Sieve C test, which is true only when none of the given
#pod tests are true.
#pod
#pod =cut

sub noneof (@things) {
  return Sieve::Generator::Element::Junction->new({
    type => 'noneof',
    things => \@things,
  });
}

#pod =func terms
#pod
#pod   my $terms = terms(@terms);
#pod
#pod This function creates a L from the given
#pod C<@terms>.  Each term may be a plain string or an object doing
#pod L; all terms are joined with single spaces when
#pod rendered.  This is the general-purpose constructor for Sieve test expressions
#pod and argument sequences.
#pod
#pod =cut

sub terms (@terms) {
  return Sieve::Generator::Element::Terms->new({ terms => \@terms });
}

#pod =func heredoc
#pod
#pod   my $hd = heredoc($text);
#pod
#pod This function creates a L containing the
#pod given C<$text>.  The text renders using the Sieve C/C<.> multiline
#pod string syntax.  Any line beginning with C<.> is automatically escaped to
#pod C<..>.
#pod
#pod =cut

sub heredoc ($text) {
  return Sieve::Generator::Element::Heredoc->new({ text => $text });
}

#pod =func number
#pod
#pod   my $num = number($value);
#pod   my $num = number($value, $suffix);
#pod
#pod This function creates a L that renders as a
#pod Sieve numeric literal (RFC 5228 section 2.4.1).  The C<$value> must be a
#pod non-negative integer.  The optional C<$suffix> is a size quantifier: C,
#pod C, or C (case insensitive).
#pod
#pod =cut

sub number ($value, $suffix = undef) {
  return Sieve::Generator::Element::Num->new({
    value  => $value,
    (defined $suffix ? (suffix => $suffix) : ()),
  });
}

#pod =func qstr
#pod
#pod   my $q    = qstr($string);
#pod   my @qs   = qstr(@strings);
#pod   my $list = qstr(\@strings);
#pod
#pod This function creates Sieve string objects.  A plain scalar produces a
#pod L that renders as a quoted Sieve string.  An
#pod array reference produces a L that renders
#pod as a bracketed Sieve string list.  When given a list of arguments, it maps
#pod over each and returns a corresponding list of objects.
#pod
#pod =cut

sub qstr (@inputs) {
  return map {;
    ref ? Sieve::Generator::Element::QstrList->new({ strs => $_ })
        : Sieve::Generator::Element::Qstr->new({ str => $_ })
  } @inputs;
}

#pod =func hasflag
#pod
#pod   my $test = hasflag($flag);
#pod
#pod This function creates an RFC 5232 C test that is true if the message
#pod has the given flag set.  The C<$flag> is automatically quoted as a Sieve
#pod string.
#pod
#pod =cut

sub hasflag ($flag) {
  return Sieve::Generator::Element::Command->new({
    autowrap  => 0,
    semicolon => 0,

    identifier      => 'hasflag',
    positional_args => [ Sieve::Generator::Element::Qstr->new({ str => $flag }) ],
  });
}

#pod =func negate
#pod
#pod   my $test = negate($inner_test);
#pod
#pod This function wraps C<$inner_test> in a Sieve C test, producing output
#pod like C.
#pod
#pod =cut

sub negate ($test) {
  return Sieve::Generator::Element::Command->new({
    autowrap  => 0,
    semicolon => 0,

    identifier      => 'not',
    positional_args => [ $test ],
  });
}

#pod =func bool
#pod
#pod   my $test = bool($value);
#pod
#pod This function returns a test representing a literal C or C
#pod depending on the truthiness of C<$value>.
#pod
#pod =cut

sub bool ($value) {
  return Sieve::Generator::Element::Command->new({
    autowrap  => 0,
    semicolon => 0,
    identifier => $value ? 'true' : 'false',
  });
}

#pod =func var_eq
#pod
#pod   my $test = var_eq($var, $value);
#pod
#pod This produces a string "is" test checking that the given variable name equals
#pod the given value, by producing something like C.
#pod
#pod =cut

sub var_eq ($var, $value) {
  return Sieve::Generator::Element::Command->new({
    autowrap  => 0,
    semicolon => 0,

    identifier  => 'string',
    tagged_args => { is => [] },
    positional_args => [
      Sieve::Generator::Element::Qstr->new({ str => "\${$var}" }),
      qstr($value),
    ],
  });
}

#pod =func var_ne
#pod
#pod   my $test = var_ne($var, $value);
#pod
#pod This produces an inverted string "is" test checking that the given variable
#pod name equals the given value, by producing something like C
#pod "${$var}" "$value">.
#pod
#pod =cut

sub var_ne ($var, $value) {
  return Sieve::Generator::Element::Command->new({
    autowrap  => 0,
    semicolon => 0,

    identifier  => 'not string',
    tagged_args => { is => [] },
    positional_args => [
      Sieve::Generator::Element::Qstr->new({ str => "\${$var}" }),
      qstr($value),
    ],
  });
}

1;

__END__