}
if ( ! $rawprint and ! exists $data{format} ) {
$data{format} = 'l';
+ $data{fields} = 'subject,status,queue,created,told,owner,requestors';
}
if ( $reverse_sort and $data{orderby} =~ /^-/ ) {
$data{orderby} =~ s/^-/+/;
}
if ( ! $rawprint and ! exists $data{format} ) {
$data{format} = 'l';
+ $data{fields} = 'subject,status,queue,created,told,owner,requestors';
}
if ( $reverse_sort and $data{orderby} =~ /^-/ ) {
$data{orderby} =~ s/^-/+/;
#! /bin/sh
# From configure.ac Revision.
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.68 for RT rt-4.0.21.
+# Generated by GNU Autoconf 2.69 for RT rt-4.0.22.
#
# Report bugs to <rt-bugs@bestpractical.com>.
#
#
-# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software
-# Foundation, Inc.
+# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.
#
#
# This configure script is free software; the Free Software Foundation
# CDPATH.
(unset CDPATH) >/dev/null 2>&1 && unset CDPATH
+# Use a proper internal environment variable to ensure we don't fall
+ # into an infinite loop, continuously re-executing ourselves.
+ if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then
+ _as_can_reexec=no; export _as_can_reexec;
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+as_fn_exit 255
+ fi
+ # We don't want this to propagate to other subprocesses.
+ { _as_can_reexec=; unset _as_can_reexec;}
if test "x$CONFIG_SHELL" = x; then
as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then :
emulate sh
else
exitcode=1; echo positional parameters were not saved.
fi
-test x\$exitcode = x0 || exit 1"
+test x\$exitcode = x0 || exit 1
+test -x / || exit 1"
as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO
as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO
eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&
if test "x$CONFIG_SHELL" != x; then :
- # We cannot yet assume a decent shell, so we have to provide a
- # neutralization value for shells without unset; and this also
- # works around shells that cannot unset nonexistent variables.
- # Preserve -v and -x to the replacement shell.
- BASH_ENV=/dev/null
- ENV=/dev/null
- (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
- export CONFIG_SHELL
- case $- in # ((((
- *v*x* | *x*v* ) as_opts=-vx ;;
- *v* ) as_opts=-v ;;
- *x* ) as_opts=-x ;;
- * ) as_opts= ;;
- esac
- exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"}
+ export CONFIG_SHELL
+ # We cannot yet assume a decent shell, so we have to provide a
+# neutralization value for shells without unset; and this also
+# works around shells that cannot unset nonexistent variables.
+# Preserve -v and -x to the replacement shell.
+BASH_ENV=/dev/null
+ENV=/dev/null
+(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV
+case $- in # ((((
+ *v*x* | *x*v* ) as_opts=-vx ;;
+ *v* ) as_opts=-v ;;
+ *x* ) as_opts=-x ;;
+ * ) as_opts= ;;
+esac
+exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"}
+# Admittedly, this is quite paranoid, since all the known shells bail
+# out after a failed `exec'.
+$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2
+exit 255
fi
if test x$as_have_required = xno; then :
} # as_fn_mkdir_p
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
# as_fn_append VAR VALUE
# ----------------------
# Append the text in VALUE to the end of the definition contained in VAR. Take
chmod +x "$as_me.lineno" ||
{ $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }
+ # If we had to re-execute with $CONFIG_SHELL, we're ensured to have
+ # already done that, so ensure we don't try to do so again and fall
+ # in an infinite loop. This has already happened in practice.
+ _as_can_reexec=no; export _as_can_reexec
# Don't try to exec as it changes $[0], causing all sort of problems
# (the dirname of $[0] is not the place where we might find the
# original and so on. Autoconf is especially sensitive to this).
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
- # In both cases, we have to default to `cp -p'.
+ # In both cases, we have to default to `cp -pR'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
as_mkdir_p=false
fi
-if test -x / >/dev/null 2>&1; then
- as_test_x='test -x'
-else
- if ls -dL / >/dev/null 2>&1; then
- as_ls_L_option=L
- else
- as_ls_L_option=
- fi
- as_test_x='
- eval sh -c '\''
- if test -d "$1"; then
- test -d "$1/.";
- else
- case $1 in #(
- -*)set "./$1";;
- esac;
- case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
- ???[sx]*):;;*)false;;esac;fi
- '\'' sh
- '
-fi
-as_executable_p=$as_test_x
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# Identity of this package.
PACKAGE_NAME='RT'
PACKAGE_TARNAME='rt'
-PACKAGE_VERSION='rt-4.0.21'
-PACKAGE_STRING='RT rt-4.0.21'
+PACKAGE_VERSION='rt-4.0.22'
+PACKAGE_STRING='RT rt-4.0.22'
PACKAGE_BUGREPORT='rt-bugs@bestpractical.com'
PACKAGE_URL=''
if test "x$host_alias" != x; then
if test "x$build_alias" = x; then
cross_compiling=maybe
- $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host.
- If a cross compiler is detected then cross compile mode will be used" >&2
elif test "x$build_alias" != "x$host_alias"; then
cross_compiling=yes
fi
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures RT rt-4.0.21 to adapt to many kinds of systems.
+\`configure' configures RT rt-4.0.22 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of RT rt-4.0.21:";;
+ short | recursive ) echo "Configuration of RT rt-4.0.22:";;
esac
cat <<\_ACEOF
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-RT configure rt-4.0.21
-generated by GNU Autoconf 2.68
+RT configure rt-4.0.22
+generated by GNU Autoconf 2.69
-Copyright (C) 2010 Free Software Foundation, Inc.
+Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by RT $as_me rt-4.0.21, which was
-generated by GNU Autoconf 2.68. Invocation command line was
+It was created by RT $as_me rt-4.0.22, which was
+generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
rt_version_minor=0
-rt_version_patch=21
+rt_version_patch=22
test "x$rt_version_major" = 'x' && rt_version_major=0
test "x$rt_version_minor" = 'x' && rt_version_minor=0
# by default.
for ac_prog in ginstall scoinst install; do
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then
if test $ac_prog = install &&
grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then
# AIX install. It has an incompatible calling convention.
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_path_PERL="$as_dir/$ac_word$ac_exec_ext"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_RT_GRAPHVIZ=""yes""
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_RT_GD=""yes""
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
- if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_prog_RT_GPG=""yes""
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
# ... but there are two gotchas:
# 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.
# 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.
- # In both cases, we have to default to `cp -p'.
+ # In both cases, we have to default to `cp -pR'.
ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
elif ln conf$$.file conf$$ 2>/dev/null; then
as_ln_s=ln
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
else
- as_ln_s='cp -p'
+ as_ln_s='cp -pR'
fi
rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file
rmdir conf$$.dir 2>/dev/null
as_mkdir_p=false
fi
-if test -x / >/dev/null 2>&1; then
- as_test_x='test -x'
-else
- if ls -dL / >/dev/null 2>&1; then
- as_ls_L_option=L
- else
- as_ls_L_option=
- fi
- as_test_x='
- eval sh -c '\''
- if test -d "$1"; then
- test -d "$1/.";
- else
- case $1 in #(
- -*)set "./$1";;
- esac;
- case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((
- ???[sx]*):;;*)false;;esac;fi
- '\'' sh
- '
-fi
-as_executable_p=$as_test_x
+
+# as_fn_executable_p FILE
+# -----------------------
+# Test if FILE is an executable regular file.
+as_fn_executable_p ()
+{
+ test -f "$1" && test -x "$1"
+} # as_fn_executable_p
+as_test_x='test -x'
+as_executable_p=as_fn_executable_p
# Sed expression to map a string onto a valid CPP name.
as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by RT $as_me rt-4.0.21, which was
-generated by GNU Autoconf 2.68. Invocation command line was
+This file was extended by RT $as_me rt-4.0.22, which was
+generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
CONFIG_HEADERS = $CONFIG_HEADERS
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-RT config.status rt-4.0.21
-configured by $0, generated by GNU Autoconf 2.68,
+RT config.status rt-4.0.22
+configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
-Copyright (C) 2010 Free Software Foundation, Inc.
+Copyright (C) 2012 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
if \$ac_cs_recheck; then
- set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+ set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
shift
\$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6
CONFIG_SHELL='$SHELL'
--- /dev/null
+-----BEGIN CERTIFICATE-----
+MIICpjCCAY4CCQDLtMptx45HuDANBgkqhkiG9w0BAQUFADAUMRIwEAYDVQQDEwls
+b2NhbGhvc3QwIBcNMTIwMjE3MjIxMTU3WhgPMjExMjAxMjQyMjExNTdaMBQxEjAQ
+BgNVBAMTCWxvY2FsaG9zdDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEB
+AKokK5sAKbNkJDoOInDQpwRxDDfanXKUR7MK761G2gWmUpxy+hlUn457VLgDKgDp
+s3gSUk0x3rsXcMxpsSDQ+E37kz5DnbPGSGdiS5tJD6VoQ2NsMfvrY1pZFWNv8wHu
+c4MDtStxsIxvZHjqguWeVUsXLKSfGEMTQ/MbKbn4d/7FSRpQDum2o3AsxHi4VbrS
+aWXRgCfcPlwaoOSc73lCD0kuXIl66wO8DBQOqqBtkuS59BcH+cq1T5wwKzMdJNfp
+Rx0TXISGUa4DSbTjqfAAJe4TzavH73PgNjXBl6+GsGb5/pf8Zad+t62xRcocDfOQ
+5e2ASmInsDtlSX0pfLfBHg0CAwEAATANBgkqhkiG9w0BAQUFAAOCAQEAUuiDKlBN
+RcR/YYkk/hCgDB4ronO3AO+d264Y3vDK+JsH2lI6/kwxpmJj+bA2IVM+eM5NrcFh
+zEm+LKnyz4EvmxXTI4gI1iFPhOP4NJYmMtyKGavlZP3gNW4JQRYOiA0vQ2Egcngo
+uW2k7xUaNPPkpHptkI0P1jLVl4bX/qKA6tzrmwsmdwNOW9j9zk9BOq8HVvduBDeU
+XFsrdmN4EgD0nU39olaArg/RqMacIfCfKqYdRo9OSbBfQ7x2di9HgI1h2VVfPGi5
+cDRyLlpAY9KNuuStutcFMoQbdwKU/0GFkRuguFPJbIcDg7nhZDXRMU+XugQ8dsZ/
+0VgszAIRc510nA==
+-----END CERTIFICATE-----
--- /dev/null
+-----BEGIN RSA PRIVATE KEY-----
+MIIEogIBAAKCAQEAqiQrmwAps2QkOg4icNCnBHEMN9qdcpRHswrvrUbaBaZSnHL6
+GVSfjntUuAMqAOmzeBJSTTHeuxdwzGmxIND4TfuTPkOds8ZIZ2JLm0kPpWhDY2wx
+++tjWlkVY2/zAe5zgwO1K3GwjG9keOqC5Z5VSxcspJ8YQxND8xspufh3/sVJGlAO
+6bajcCzEeLhVutJpZdGAJ9w+XBqg5JzveUIPSS5ciXrrA7wMFA6qoG2S5Ln0Fwf5
+yrVPnDArMx0k1+lHHRNchIZRrgNJtOOp8AAl7hPNq8fvc+A2NcGXr4awZvn+l/xl
+p363rbFFyhwN85Dl7YBKYiewO2VJfSl8t8EeDQIDAQABAoIBAGeZsrulM786QRzg
+snQDeU+pDomMIsc8JxSMmjjmpac/CZqeIFAASU/XJVUPCCqaI1//uAGtVjSSJ2sx
+CFw1Ip1JjPUi8woeuMPLBMK/kDll7XLC1QTS5iKDkBSGfHA2pDuorE6R4bEBuyot
+khsDeGhK6jIrdfiR6JRFe/jzpQ2KUV7PDKhcGjWdCCGoss7s2d0Gx4UdlYn456Dr
+atPLXU9Aspg7uIUSO44Zwal03k25S0EW4WjdFCx3+1WqXs8l+XNXlqowZSL8qjOy
+cL2H5bpElE+NjSsHtTZdzC8jcDhbIRp8cZD32t+BRY5gqodKw+Z3MmblL2b3/qPi
+xNMaq8ECgYEA3ACjPUhRb7kYMgmowOXR/HL9Aht+4uCM+UM/pz0S4rn4MooBuCwv
+Nc0oFi5wFNJpFsOsiJwik7re1/olPPneZWgZWgBoiQl4+OB5hzvLc56B9Ez3Z84X
+19BxKcUaf5gXjxVAAAeKxn8ZbL/OHB3WvYP4zsIO1J+ijOe2LZJFEpUCgYEAxfr4
+RsK8avAdgOC0e/uB007rtiErCIaVnK/1WMPwWb5FxDkkl31MTB6oLO/JU5zfCsE1
+ROtnehB69c73sokWzAqMCuVFs+M0Owq1Kdm63b1k0wtUZL7v3wfGoUgZFL/65LDg
+RQ2Grntul5H7XS9c9v7Tn9GSo8VIbej6fvPPN5kCgYAqbL0N7ko1/z2ZOJ+gQzFR
+O2Nq6p53ZdIJp1w5BeAEdNRV+qMGPw8DkwJt9JqMiV7WkvlMhr9sOZcLkyNnNNAc
+QgzRfE6sTnVTmQYWfANp0mFBGS6EiAu1BG8uHOJVRKEWaISk/M9YI95lSD+Y0HA+
+r5plVKrDed1AytYox5ImWQKBgC/VNQsTnaZQoTA0GiciWvmMxdJZLSaALcGPmb16
+iaWFHSINlFOtiDOT7Jn+zSuQaSsWByLBpVyOgsbE3H+cM4/UtIUlY7PUnxfsvFyC
+KG3Ohn+e6yL0JsxB+rGY08Z5o8qBGY5VeEbLt6qTMKIRAWsDommonr9GuPslIPBv
+Q49xAoGAI7LBHEJtPTJx56EcKicST++NzUYha7E8nkqogs9oTTpdT6n+viHDCNud
+YUUK2slnEvgOPtNEkf1kHTqcajKZmIVpQi1cZqKzPCgk49JM+2OU+98qFR8UKe8i
+s5t09zDVhy9Hy+MaASqbU1AQT9bWbyfsgormjQ5jzadDdP5zovE=
+-----END RSA PRIVATE KEY-----
--- /dev/null
+# This is a mime.types for only the file types which we serve
+# statically (those that Apache might care about).
+image/gif gif
+image/png png
--- /dev/null
+#!/usr/bin/env perl
+
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use Getopt::Long;
+use FindBin;
+use Pod::Usage;
+use File::Spec::Functions qw(rel2abs);
+
+my %opt = (
+ root => ($ENV{RTHOME} || "/opt/rt4"),
+
+ fcgid => 0,
+ fastcgi => 0,
+ perl => 0,
+
+ modules => "/usr/lib/apache2/modules",
+);
+
+GetOptions( \%opt,
+ "root=s",
+
+ "rt3|3!",
+
+ "fcgid!",
+ "fastcgi!",
+ "perl!",
+
+ "port|p=i",
+ "ssl:i",
+ "single|X",
+
+ "modules=s",
+
+ "help|h|?",
+) or pod2usage( 1 );
+pod2usage( {verbose => 2} ) if $opt{help};
+
+# All paths must be absolute
+$opt{$_} = rel2abs($opt{$_})
+ for qw(root modules);
+
+# Determine what module to use
+my $mod;
+if ($opt{fcgid} + $opt{fastcgi} + $opt{perl} > 1) {
+ die "Can only supply one of fcgid, fastcgi, or perl\n";
+} elsif ($opt{fcgid} + $opt{fastcgi} + $opt{perl} == 0) {
+ my @guess = qw(fastcgi fcgid perl);
+ @guess = grep {-f "$opt{modules}/mod_$_.so"} @guess;
+ die "Neither mod_fcgid, mod_fastcgi, nor mod_perl are installed; aborting\n"
+ unless @guess;
+ warn "No deployment given -- assuming mod_$guess[0] deployment\n";
+ $mod = $guess[0];
+} else {
+ $mod = (grep {$opt{$_}} qw(fastcgi fcgid perl))[0];
+}
+
+# Sanity check that the root contains an RT install
+die "$opt{root} doesn't look like an RT install\n"
+ unless -e "$opt{root}/lib/RT.pm";
+
+# Detect if we are actually rt3
+if (not -e "$opt{root}/sbin/rt-server.fcgi"
+ and -e "$opt{root}/bin/mason_handler.fcgi") {
+ $opt{rt3}++;
+ warn "RT3 install detected!\n";
+}
+
+# Parse etc/RT_SiteConfig.pm for the default port
+my $RTCONF;
+$opt{port} ||= parseconf( "WebPort" );
+unless ($opt{port}) {
+ warn "Defaulting to port 8888\n";
+ $opt{port} = 8888;
+}
+
+# Set ssl port if they want it but didn't provide a number
+$opt{ssl} = 4430 if defined $opt{ssl} and not $opt{ssl};
+
+# Parse out the WebPath
+my $path = parseconf( "WebPath" ) || "";
+
+my $template = join("", <DATA>);
+$template =~ s/\$PORT/$opt{port}/g;
+$template =~ s!\$PATH/!$path/!g;
+$template =~ s!\$PATH!$path || "/"!ge;
+$template =~ s/\$SSL/$opt{ssl} || 0/ge;
+$template =~ s/\$RTHOME/$opt{root}/g;
+$template =~ s/\$MODULES/$opt{modules}/g;
+$template =~ s/\$TOOLS/$FindBin::Bin/g;
+$template =~ s/\$PROCESSES/$opt{single} ? 1 : 3/ge;
+
+my $conf = "$opt{root}/var/apache.conf";
+open(CONF, ">", $conf)
+ or die "Can't write $conf: $!";
+print CONF $template;
+close CONF;
+
+my @opts = ("-f", $conf, "-D" . uc($mod) );
+push @opts, "-DSSL" if $opt{ssl};
+push @opts, "-DRT3" if $opt{rt3};
+push @opts, "-DSINGLE" if $opt{single};
+
+# Wait for a previous run to terminate
+if ( open( PIDFILE, "<", "$opt{root}/var/apache2.pid") ) {
+ my $pid = <PIDFILE>;
+ chomp $pid;
+ close PIDFILE;
+ if ($pid and kill 0, $pid) {
+ warn "Waiting for previous run (pid $pid) to finish...\n";
+ sleep 1 while kill 0, $pid;
+ }
+}
+
+# Clean out the log in preparation
+my $log = "$opt{root}/var/log/apache-error.log";
+unlink($log);
+
+# Start 'er up
+warn "Starting apache server on http://localhost:$opt{port}$path/"
+ . ($opt{ssl} ? " and https://localhost:$opt{ssl}$path/" : "") . "\n";
+!system("apache2", @opts, "-k", "start")
+ or die "Can't exec apache2: $@";
+# Ignore the return value, as we expect it to be ^C'd
+system("tail", "-f", $log);
+warn "Shutting down apache...\n";
+!system("apache2", @opts, "-k", "stop")
+ or die "Can't exec apache2: $@";
+
+
+sub parseconf {
+ my ($optname) = @_;
+ # We're going to be evil, and try to parse the config
+ unless (defined $RTCONF) {
+ unless ( open(CONF, "<", "$opt{root}/etc/RT_SiteConfig.pm") ) {
+ warn "Can't open $opt{root}/etc/RT_SiteConfig.pm: $!\n";
+ $RTCONF = "";
+ return;
+ }
+ $RTCONF = join("", <CONF>);
+ close CONF;
+ }
+
+ return unless $RTCONF =~ /^\s*Set\(\s*\$$optname\s*(?:,|=>)\s*['"]?(.*?)['"]?\s*\)/m;
+ return $1;
+}
+
+=head1 NAME
+
+rt-apache - Wrapper to start Apache running RT
+
+=head1 DESCRIPTION
+
+This script exists to make it easier to run RT under Apache for testing.
+It is not intended as a way to deploy RT, or to provide example Apache
+configuration for RT. For instructions on how to deploy RT with Apache,
+please read the provided F<docs/web_deployment.pod> file.
+
+Running this script will start F<apache2> with a custom-built
+configuration file, built based on command-line options and the contents
+of your F<RT_SiteConfig.pm>. It will work with either RT 3.8.x or RT
+4.0.x. As it is primarily for simple testing, it runs Apache as the
+current user.
+
+=head1 OPTIONS
+
+C<rt-apache> will parse your F<RT_SiteConfig.pm> for its C<WebPath> and
+C<WebPort> configuration, and adjust its defaults accordingly.
+
+=over
+
+=item --root B<path>
+
+The path to the RT install to serve. This defaults to the C<RTHOME>
+environment variable, or C</opt/rt4>.
+
+=item --fastcgi, --fcgid, --perl
+
+Determines the Apache module which is used. By default, the first one
+of that list which exists will be used. See also L</--modules>.
+
+=item --port B<number>
+
+Choses the port to listen on. By default, this is parsed from the
+F<RT_SiteConfig.pm>, and falling back to 8888.
+
+=item --ssl [B<number>]
+
+Also listens on the provided port with HTTPS, using a self-signed
+certificate for C<localhost>. If the port number is not specified,
+defaults to port 4430.
+
+=item --single, -X
+
+Run only one process or thread, for ease of debugging.
+
+=item --rt3, -3
+
+Declares that the RT install in question is RT 3.8.x. C<rt-apache> can
+usually detect this for you, however.
+
+=item --modules B<path>
+
+The path to the Apache2 modules directory, which is expected to contain
+at least one of F<mod_fcgid.so>, F<mod_fastcgi.so>, or F<mod_perl.so>.
+Defaults to F</usr/lib/apache2/modules>.
+
+=back
+
+=cut
+
+__DATA__
+<IfDefine SINGLE>
+ <IfModule mpm_prefork_module>
+ StartServers 1
+ MinSpareServers 1
+ MaxSpareServers 1
+ MaxClients 1
+ MaxRequestsPerChild 0
+ </IfModule>
+
+ <IfModule mpm_worker_module>
+ StartServers 1
+ MinSpareThreads 1
+ MaxSpareThreads 1
+ ThreadLimit 1
+ ThreadsPerChild 1
+ MaxClients 1
+ MaxRequestsPerChild 0
+ </IfModule>
+</IfDefine>
+
+Listen $PORT
+<IfDefine SSL>
+ Listen $SSL
+</IfDefine>
+
+ServerName localhost
+ServerRoot $RTHOME/var
+PidFile $RTHOME/var/apache2.pid
+LockFile $RTHOME/var/apache2.lock
+ServerAdmin root@localhost
+
+LoadModule authz_host_module $MODULES/mod_authz_host.so
+LoadModule env_module $MODULES/mod_env.so
+LoadModule alias_module $MODULES/mod_alias.so
+LoadModule mime_module $MODULES/mod_mime.so
+TypesConfig $TOOLS/mime.types
+
+<IfDefine PERL>
+ LoadModule perl_module $MODULES/mod_perl.so
+</IfDefine>
+<IfDefine FASTCGI>
+ LoadModule fastcgi_module $MODULES/mod_fastcgi.so
+</IfDefine>
+<IfDefine FCGID>
+ LoadModule fcgid_module $MODULES/mod_fcgid.so
+</IfDefine>
+<IfDefine SSL>
+ LoadModule ssl_module $MODULES/mod_ssl.so
+</IfDefine>
+
+<IfModule !log_config_module>
+ LoadModule log_config_module $MODULES/mod_log_config.so
+</IfModule>
+ErrorLog "$RTHOME/var/log/apache-error.log"
+TransferLog "$RTHOME/var/log/apache-access.log"
+LogLevel notice
+
+<Directory />
+ Options FollowSymLinks
+ AllowOverride None
+ Order deny,allow
+ Deny from all
+</Directory>
+
+AddDefaultCharset UTF-8
+
+DocumentRoot $RTHOME/share/html
+<Directory $RTHOME/share/html>
+ Order allow,deny
+ Allow from all
+</Directory>
+
+Alias $PATH/NoAuth/images/ $RTHOME/share/html/NoAuth/images/
+<Directory $RTHOME/share/html/NoAuth/images>
+ Order allow,deny
+ Allow from all
+</Directory>
+
+<IfDefine !RT3>
+########## 4.0 mod_perl
+<IfDefine PERL>
+ PerlSetEnv RT_SITE_CONFIG $RTHOME/etc/RT_SiteConfig.pm
+ <Location $PATH>
+ Order allow,deny
+ Allow from all
+ SetHandler modperl
+ PerlResponseHandler Plack::Handler::Apache2
+ PerlSetVar psgi_app $RTHOME/sbin/rt-server
+ </Location>
+ <Perl>
+ use Plack::Handler::Apache2;
+ Plack::Handler::Apache2->preload("$RTHOME/sbin/rt-server");
+ </Perl>
+</IfDefine>
+
+########## 4.0 mod_fastcgi
+<IfDefine FASTCGI>
+ FastCgiIpcDir $RTHOME/var
+ FastCgiServer $RTHOME/sbin/rt-server.fcgi -processes $PROCESSES -idle-timeout 300
+ ScriptAlias $PATH $RTHOME/sbin/rt-server.fcgi/
+ <Location $PATH>
+ Order allow,deny
+ Allow from all
+ Options +ExecCGI
+ AddHandler fastcgi-script fcgi
+ </Location>
+</IfDefine>
+
+########## 4.0 mod_fcgid
+<IfDefine FCGID>
+ FcgidProcessTableFile $RTHOME/var/fcgid_shm
+ FcgidIPCDir $RTHOME/var
+ FcgidMaxRequestLen 1073741824
+ ScriptAlias $PATH $RTHOME/sbin/rt-server.fcgi/
+ <Location $PATH>
+ Order allow,deny
+ Allow from all
+ Options +ExecCGI
+ AddHandler fcgid-script fcgi
+ </Location>
+</IfDefine>
+</IfDefine>
+
+
+<IfDefine RT3>
+########## 3.8 mod_perl
+<IfDefine PERL>
+ PerlSetEnv RT_SITE_CONFIG $RTHOME/etc/RT_SiteConfig.pm
+ PerlRequire "$RTHOME/bin/webmux.pl"
+ <Location $PATH/NoAuth/images>
+ SetHandler default
+ </Location>
+ <Location $PATH>
+ SetHandler perl-script
+ PerlResponseHandler RT::Mason
+ </Location>
+</IfDefine>
+
+########## 3.8 mod_fastcgi
+<IfDefine FASTCGI>
+ FastCgiIpcDir $RTHOME/var
+ FastCgiServer $RTHOME/bin/mason_handler.fcgi -processes $PROCESSES -idle-timeout 300
+ ScriptAlias $PATH $RTHOME/bin/mason_handler.fcgi/
+ <Location $PATH>
+ Order allow,deny
+ Allow from all
+ Options +ExecCGI
+ AddHandler fastcgi-script fcgi
+ </Location>
+</IfDefine>
+
+########## 3.8 mod_fcgid
+<IfDefine FCGID>
+ FcgidProcessTableFile $RTHOME/var/fcgid_shm
+ FcgidIPCDir $RTHOME/var
+ FcgidMaxRequestLen 1073741824
+ ScriptAlias $PATH $RTHOME/bin/mason_handler.fcgi/
+ <Location $PATH>
+ Order allow,deny
+ Allow from all
+ Options +ExecCGI
+ AddHandler fcgid-script fcgi
+ </Location>
+</IfDefine>
+</IfDefine>
+
+<IfDefine SSL>
+ SSLRandomSeed startup builtin
+ SSLRandomSeed startup file:/dev/urandom 512
+ SSLRandomSeed connect builtin
+ SSLRandomSeed connect file:/dev/urandom 512
+ SSLSessionCache shmcb:$RTHOME/var/ssl_scache(512000)
+ SSLMutex file:$RTHOME/var/ssl_mutex
+ <VirtualHost *:$SSL>
+ SSLEngine on
+ SSLCertificateFile $TOOLS/localhost.crt
+ SSLCertificateKeyFile $TOOLS/localhost.key
+ </VirtualHost>
+</IfDefine>
--- /dev/null
+#!/usr/bin/env perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use Getopt::Long;
+use File::Temp;
+use File::Spec;
+use File::Path qw(make_path rmtree);
+use File::Copy qw(copy);
+use HTML::Entities qw(encode_entities);
+use RT::Pod::HTMLBatch;
+
+my %opts;
+GetOptions(
+ \%opts,
+ "help|h",
+ "rt=s",
+ "to=s",
+);
+
+if ( $opts{'help'} ) {
+ require Pod::Usage;
+ print Pod::Usage::pod2usage( -verbose => 2 );
+ exit;
+}
+
+die "--to=DIRECTORY is required\n" unless $opts{to};
+
+$opts{to} = File::Spec->rel2abs($opts{to});
+
+make_path( $opts{to} ) unless -e $opts{to};
+die "--to MUST be a directory\n" unless -d $opts{to};
+
+# Unpack the tarball, if that's what we're given.
+my $tmpdir;
+if (($opts{rt} || '') =~ /\.tar\.gz$/ and -f $opts{rt}) {
+ $tmpdir = File::Temp->newdir();
+
+ system("tar", "xzpf", $opts{rt}, "-C", $tmpdir);
+ $opts{rt} = <$tmpdir/rt-*>;
+}
+chdir $opts{rt} if $opts{rt};
+
+my @dirs = (
+ qw(
+ docs
+ etc
+ lib
+ bin
+ sbin
+ devel/tools
+ local/lib
+ local/sbin
+ local/bin
+ ),
+ glob("local/plugins/*/{lib,sbin,bin}"),
+ glob("docs/UPGRADING*"),
+);
+
+my $converter = RT::Pod::HTMLBatch->new;
+
+sub generate_configure_help {
+ my $configure = shift;
+ my $help = `./$configure --help`;
+ my $dest = "$opts{to}/configure.html";
+
+ if ($help and open my $html, ">", $dest) {
+ print $html join "\n",
+ "<pre>", encode_entities($help), "</pre>", "\n";
+ close $html;
+ $converter->note_for_contents_file(["configure options"], $configure, $dest);
+ } else {
+ warn "Can't open $dest: $!";
+ }
+}
+
+# Generate a page for ./configure --help if we can
+if (-x "configure.ac" and -d ".git") {
+ rmtree("autom4te.cache") if -d "autom4te.cache";
+ generate_configure_help("configure.ac");
+}
+elsif (-x "configure") {
+ generate_configure_help("configure");
+}
+else {
+ warn "Unable to generate a page for ./configure --help!\n";
+}
+
+# Manually "convert" README* and 3.8-era UPGRADING* to HTML and push them into
+# the known contents.
+for my $file (<README* UPGRADING*>) {
+ (my $name = $file) =~ s{^.+/}{};
+ my $dest = "$opts{to}/$name.html";
+
+ open my $source, "<", $file
+ or warn "Can't open $file: $!", next;
+
+ open my $html, ">", $dest
+ or warn "Can't open $dest: $!", next;
+
+ print $html "<pre>";
+ print $html encode_entities($_) while <$source>;
+ print $html "</pre>";
+
+ close $source; close $html;
+
+ $converter->note_for_contents_file([$name], $file, $dest);
+}
+
+# Copy images into place
+make_path("$opts{to}/images/");
+copy($_, "$opts{to}/images/")
+ for <docs/images/*.{png,jpeg,jpg,gif}>;
+
+# Temporarily set executable bits on upgrading doc to work around
+# Pod::Simple::Search limitation/bug:
+# https://rt.cpan.org/Ticket/Display.html?id=80082
+sub system_chmod {
+ system("chmod", @_) == 0
+ or die "Unable to chmod: $! (exit $?)";
+}
+system_chmod("+x", $_) for <docs/UPGRADING*>;
+
+# Convert each POD file to HTML
+$converter->batch_convert( \@dirs, $opts{to} );
+
+# Remove execution bit from workaround above
+system_chmod("-x", $_) for <docs/UPGRADING*>;
+
+# Need to chdir back out, if we are in the tmpdir, to let it clean up
+chdir "/" if $tmpdir;
+
+exit 0;
+
+__END__
+
+=head1 NAME
+
+rt-static-docs - generate doc shipped with RT
+
+=head1 SYNOPSIS
+
+ rt-static-docs --to /path/to/output [--rt /path/to/rt]
+
+=head1 DESCRIPTION
+
+RT ships with documentation (written in POD) embedded in library files, at the
+end of utility scripts, and in standalone files. This script finds all of that
+documentation, collects and converts it into a nice set of HTML files, and tops
+it off with a helpful index.
+
+Best Practical uses this to publish documentation under
+L<http://bestpractical.com/rt/docs/>.
+
+=head1 OPTIONS
+
+=over
+
+=item --to
+
+Set the destination directory for the output files.
+
+=item --rt
+
+Set the RT base directory to search under. Defaults to the current working
+directory, which is fine if you're running this script as
+C<devel/tools/rt-static-docs>.
+
+May also point to a tarball (a file ending in C<.tar.gz>) which will be
+unpacked into a temporary directory and used as the RT base directory.
+
+=item --help
+
+Print this help.
+
+=back
+
+=cut
--- /dev/null
+=head1 BACKUPS
+
+RT is often a critical piece of businesses and organizations. Backups are
+absolutely necessary to ensure you can recover quickly from an incident.
+
+Make sure you take backups. Make sure they I<work>.
+
+There are many issues that can cause broken backups, such as a
+C<max_allowed_packet> too low for MySQL (in either the client or server), or
+encoding issues, or running out of disk space.
+
+Make sure your backup cronjobs notify someone if they fail instead of failing
+silently until you need them.
+
+Test your backups regularly to discover any unknown problems B<before> they
+become an issue. You don't want to discover problems with your backups while
+tensely restoring from them in a critical data loss situation.
+
+=head2 DATABASE
+
+You should backup the entire RT database, although for improved speed and space
+you can ignore the I<data> in the C<sessions> table. Make sure you still get
+the C<sessions> schema, however.
+
+Database specific notes and example backup commands for each database are
+below. Adjust the commands as necessary for connection details such as
+database name (C<rt4> is the placeholder below), user, password, host, etc.
+You should put the example commands into a shell script for backup and setup a
+cronjob. Make sure output from cron goes to someone who reads mail! (Or into
+RT. :)
+
+=head3 MySQL
+
+ ( mysqldump rt4 --tables sessions --no-data; \
+ mysqldump rt4 --ignore-table rt4.sessions --single-transaction ) \
+ | gzip > rt-`date +%Y%M%d`.sql.gz
+
+If you're using a MySQL version older than 4.1.2 (only supported on RT 3.8.x
+and older), you should be also pass the C<--default-character-set=binary>
+option to the second C<mysqldump> command.
+
+The dump will be much faster if you can connect to the MySQL server over
+localhost. This will use a local socket instead of the network.
+
+If you find your backups taking far far too long to complete (this point should
+take quite a long time to get to on an RT database), there are some alternate
+solutions. Percona maintains a highly regarded hot-backup tool for MySQL
+called L<XtraBackup|http://www.percona.com/software/percona-xtrabackup/>. If
+you have more resources, you can also setup replication to a slave using binary
+logs and backup from there as necessary. This not only duplicates the data,
+but lets you take backups without putting load on your production server.
+
+=head3 PostgreSQL
+
+ ( pg_dump rt4 --table=sessions --schema-only; \
+ pg_dump rt4 --exclude-table=sessions ) \
+ | gzip > rt-`date +%Y%M%d`.sql.gz
+
+=head2 FILESYSTEM
+
+You will want to back up, at the very least, the following directories and files:
+
+=over 4
+
+=item /opt/rt4
+
+RT's source code, configuration, GPG data, and plugins. Your install location
+may be different, of course.
+
+You can omit F<var/mason_data> and F<var/session_data> if you'd like since
+those are temporary caches. Don't omit all of F<var/> however as it may
+contain important GPG data.
+
+=item Webserver configuration
+
+Often F</etc/httpd> or F</etc/apache2>. This will depend on your OS, web
+server, and internal configuration standards.
+
+=item /etc/aliases
+
+Your incoming mail aliases mapping addresses to queues.
+
+=item Mail server configuration
+
+If you're running an MTA like Postfix, Exim, SendMail, or qmail, you'll want to
+backup their configuration files to minimize restore time. "Lightweight" mail
+handling programs like fetchmail, msmtp, and ssmtp will also have configuration
+files, although usually not as many nor as complex. You'll still want to back
+them up.
+
+The location of these files is highly dependent on what software you're using.
+
+=item Crontab containing RT's cronjobs
+
+This may be F</etc/crontab>, F</etc/cron.d/rt>, a user-specific crontab file
+(C<crontab -l $USER>), or some other file altogether. Even if you only have
+the default cronjobs in place, it's one less piece to forget during a restore.
+If you have custom L<< C<rt-crontool> >> invocations, you don't want to have to
+recreate those.
+
+=back
+
+Simply saving a tarball should be sufficient, with something like:
+
+ tar czvpf rt-backup-`date +%Y%M%d`.tar.gz /opt/rt4 /etc/aliases /etc/httpd ...
+
+Be sure to include all the directories and files you enumerated above!
+
--- /dev/null
+=head1 RT Approvals
+
+Some types of change requests processed through RT can
+require an approval before being fulfilled. You can configure
+RT to set up such an approval workflow for tickets in
+queues you select.
+
+This document walks through the steps to set up a
+"Change requests" queue with approvals. You should try
+this in a test instance first. If you don't have a test RT
+instance, you should read through the entire document first,
+change the details as needed for your approval scenario, and then
+set up approvals.
+
+=head2 Overview
+
+The approvals solution in RT involves using a special queue,
+called ___Approvals, to hold approval requests. Scrips and
+templates automatically create the necessary tickets
+and process the approval or rejection.
+
+=head2 Change Management Queue
+
+Since this example will use a change management queue as the
+queue where tickets need approval, first we'll set up the queue.
+
+Login into UI as the 'root' user. Go to Tools -> Configuration ->
+Queues and create a new 'Change requests' queue.
+
+When you set up this queue, do not select the "approvals" Lifecycle.
+That selection is for the ___Approvals queue itself, not for queues that
+need tickets approved.
+
+=head3 Change Management Template
+
+Once the Change Management queue is created, select Templates
+-> Create in the queue configuration menu. Enter the Name 'create approval',
+leave the default Type as Perl and in the content area enter the following:
+
+ ===Create-Ticket: Manager approval
+ Subject: Manager Approval for {$Tickets{TOP}->Id} - {$Tickets{TOP}->Subject}
+ Depended-On-By: TOP
+ Queue: ___Approvals
+ Owner: root
+ Requestors: {$Tickets{TOP}->RequestorAddresses}
+ Type: approval
+ Content-Type: text/plain
+ Due: {time + 3*24*60*60}
+ Content: Please approve me.
+
+ Thanks.
+ ENDOFCONTENT
+
+All of the text should be against the left side of the textarea
+with no spaces.
+
+Click create.
+
+You'll now use this template when you create the scrip.
+
+=head3 Change Management Scrip
+
+Now you need a scrip. On the queue configuration page, select
+Scrips -> Create. For the Description, enter 'Create an approval
+on ticket create', select the 'On Create' condition, 'Create Tickets'
+action, and select the template you just created. Click create.
+
+=head3 Testing
+
+You can already test your first workflow with approvals. Create
+a ticket in your new 'Change requests' queue. You're logged in as
+'root' and the owner of the approval is root (based on the template),
+so it's your job to approve or deny the request. Select Tools -> Approvals
+in the RT main menu. You should see your first approval request.
+
+Select the 'Deny' radio button, write 'too expensive' in the notes area
+and click Go! You just rejected the approval request. If you open the ticket
+you created for testing then you will see that it's rejected
+as well and has the correspondence:
+
+ Greetings,
+
+ Your ticket has been rejected by root.
+
+ Approver's notes: too expensive
+
+You may need to search for the ticket since the rejected state means
+it's no longer 'active'.
+
+Where did this message come from? From templates in the ___Approvals
+queue.
+
+=head2 ___Approvals queue
+
+___Approvals is a special queue where all approvals are created. The queue
+is disabled and is not shown in until you search for it.
+Go to Tools -> Configuration -> Queues, leave "Name is" in the search
+area and enter ___Approvals into the search
+field. Check 'Include disabled queues in listing.' and click Go!
+You should now see the ___Approvals queue configuration page.
+
+You may want to change the name of the ___Approvals queue, but parts of RT
+expect it not to change. The name normally isn't shown to users, however, so
+it will be largely invisible.
+
+=head2 Approvals' templates
+
+From the ___Approvals queue configuration page, click 'Templates' in the
+page menu. You should see templates that are used after actions
+on approvals. For example if you click on the 'Approval Rejected'
+template in the list, you will see the template that generates
+the correspondence mentioned above.
+
+=over 4
+
+=item * New Pending Approval
+
+Owners of new approval requests get this message.
+
+=item * Approval Passed
+
+Recorded as correspondence on the ticket when it's approved by an
+approver, but still requires more people to approve.
+
+=item * All Approvals Passed
+
+Recorded when no more approvals are required.
+
+=item * Approval Rejected
+
+Recorded when the approval request is rejected (denied).
+
+=item * Approval Ready for Owner
+
+Sent to the Owner of the ticket when it's approved and no more approvals
+are required.
+
+=back
+
+You can customize these templates to meet your needs. However,
+note that there is just one ___Approvals queue for the system,
+so make sure changes work with all queues that use approvals.
+
+=head2 Approvers
+
+Navigate back to the template used to create approvals. It has
+the following line:
+
+ Owner: root
+
+With this code you set the owner of the approval request to root.
+Approvals, as well as tickets, have Ccs, AdminCcs and Requestors. For
+example the following line copies requestors from the Tickets
+to the approval request:
+
+ Requestors: {$Tickets{TOP}->RequestorAddresses}
+
+Let's create a group 'Change Approvers' and let any user of
+this group approve 'Change Requests'. Create the group, and add root
+as a member. Open the 'create an approval' template, and replace
+the 'Owner:...' line with the following:
+
+ AdminCcGroup: Change Approvers
+
+Note that this line only works in RT 4.0.5 and newer.
+
+Create another test ticket, and you as root still should be able to see
+the newly created approval, but now because of the group membership.
+You can accept or deny it.
+
+Any member of the group can accept/deny without consulting
+the other members, which is useful with more complex
+multistep workflows.
+
+=head2 Approvers' Rights
+
+Since the ___Approvals queue is a regular RT queue, you need
+to grant rights to allow your approvers to operate on approval
+requests. As root, you have super user rights and haven't needed
+specific rights for this example.
+
+It's wise to grant rights via roles as there
+is only one queue for all approvals in the system.
+
+To grant rights to your Change Approvers group, go to the queue
+configuration page for the ___Approvals queue. Click on Group Rights
+in the page menu. Grant ShowTicket and ModifyTicket rights to the
+Owner and AdminCc roles. This should be enough for most cases.
+
+Now members of the 'Change Approvers' group can act on approvals
+even if they have no SuperUser rights.
--- /dev/null
+=head1 Ticket Lifecycles
+
+By default, RT comes with ticket statuses that work for many types
+of workflows: new, open, stalled, resolved, rejected, and deleted.
+But there can be any number of workflows where these status values
+don't completely fit. RT allows you to add new custom status values and
+define their behavior with a feature called Lifecycles.
+
+=head1 Adding a New Status
+
+Because Statuses are controlled via lifecycles, you must manipulate the entire
+lifecycle configuration to add a status. In earlier versions of RT new statuses
+could be added by adding a new element to an array in RT's config file. But
+because lifecyles are built around statuses, the entire lifecycle configuration
+must be modified even if you only need new statuses.
+
+=head2 Copy Lifecycle Config
+
+First, copy the C<%Lifecycles> hash from C<RT_Config.pm> and paste it into
+C<RT_SiteConfig.pm>.
+
+=head2 Add Status Value
+
+Add the status to the set where your new status belongs. This example adds
+C<approved> to the active statuses:
+
+ active => [ 'open', 'approved', 'stalled' ],
+
+=head2 Update Transitions
+
+Now the transitions section must be updated so that the new status can
+transition to the existing statuses and also so the existing statuses can
+transition to the new status.
+
+ new => [qw( open approved stalled resolved rejected deleted)],
+ open => [qw(new approved stalled resolved rejected deleted)],
+ approved => [qw(new open stalled resolved rejected deleted)],
+ stalled => [qw(new open approved rejected resolved deleted)],
+ resolved => [qw(new open approved stalled rejected deleted)],
+ rejected => [qw(new open approved stalled resolved deleted)],
+ deleted => [qw(new open approved stalled rejected resolved )],
+
+=head1 Order Processing Example
+
+This guide demonstrates lifecycles using an order fulfillment
+system as a real-world example. You can find full lifecycles
+documentation in L<RT_Config/Lifecycles>.
+
+As with all RT custom configuration, if you are customizing the RT
+lifecycle, make your changes in your C<RT_SiteConfig.pm> file, not
+directly in C<RT_Config.pm>. If you are adding a new lifecycle, you can
+add a new entry with:
+
+ Set(%Lifecycles, my_new_lifecycle => { ... } );
+
+The detailed configuration options are discussed below. Once you add it
+and restart the server, the new lifecycle will be available on the
+queue configuration page.
+
+To show how you might use custom lifecycles, we're going to configure
+an RT lifecycle to process orders of some sort. In our order example,
+each ticket in the queue is considered a separate order and the orders
+have the following statuses:
+
+=over
+
+=item pending
+
+The order just came in untouched, pending purchase validation
+
+=item processing
+
+The order is being looked at for transaction processing
+
+=item delivery
+
+The order is out for delivery
+
+=item delivered
+
+The order was successfully delivered to its destination
+
+=item refunded
+
+The order was delivered but subsequently refunded
+
+=item declined
+
+There was an error in the process validation and the order was denied purchase
+
+=back
+
+In this particular example, the only status an order can start with is
+'pending.' When a process coordinator chooses to take this order, it
+goes into processing. The order can then either be delivered or denied
+processing. Once denied, the lifecycle for that order ends. If it is
+delivered, the order can still be refunded.
+
+The following sections walk through each part of the configuration.
+You can find the full configuration at the end in case you want to
+see the exact syntax or use it to experiment with.
+
+=head2 Defining Status Values
+
+Every queue has a lifecycle assigned to it. Without changing any
+configuration, you are given two lifecycles to choose from: "default"
+and "approvals." The approvals lifecycle is used by the internal
+approvals queue, and should not be changed or used by other queues. Do
+not modify the approvals lifecycle unless you fully understand how RT
+approvals work.
+
+=for html <img alt="Lifecycle choices" src="../images/lifecycle-choices.png">
+
+=for :text [Lifecycle choices F<docs/images/lifecycle-choices.png>]
+
+=for :man [Lifecycle choices F<docs/images/lifecycle-choices.png>]
+
+In RT 4.0, the C<@ActiveStatus> and C<@InactiveStatus> configurations
+which were previously available are gone. The logic defined by those
+options is now a subset of RT's lifecycle features, as described here.
+
+A ticket naturally has three states: initial (I<new>), active (I<open> and
+I<stalled>), and inactive (I<resolved>, I<rejected>, and I<deleted>). These
+default settings look like this in the C<RT_Config.pm> file:
+
+ default => {
+ initial => [ 'new' ],
+ active => [ 'open', 'stalled' ],
+ inactive => [ 'resolved', 'rejected', 'deleted' ],
+
+The initial state is the default starting place for new tickets, although
+you can create tickets with other statuses. Initial is generally used
+to acknowledge that a request has been made, but not yet acted on. RT
+sets the Started date on a ticket when it is moved out of the initial state.
+
+Active tickets are currently being worked on, inactive tickets have reached
+some final state. By default, inactive tickets don't show up in search
+results. The AutoOpen action sets a ticket's status to the first active
+status. You can find more details in L<RT_Config/"Lifecycle definitions">.
+
+Now we want to set up some statuses appropriate for order fulfillment,
+so we create a new top-level key called C<orders> and add our new status
+values.
+
+ Set( %Lifecycles, orders => {
+ initial => [ 'pending' ],
+ active => [ 'processing', 'delivery' ],
+ inactive => [ 'delivered', 'returned', 'declined', 'deleted' ],
+ # ...,
+ });
+
+We still use the initial, active and inactive categories, but we are
+able to define status values that are appropriate for the workflow
+we want to create. This should make the system more intuitive for users.
+
+=head2 Transitions
+
+The typical lifecycle follows the path initial -> active -> inactive.
+Obviously the path of a ticket can get more complicated than this, which
+is where transitions come into play.
+
+Transitions manage the flow of a ticket from status to status. This
+section of the configuration has keys, which are the current status,
+and values that define which other statuses the ticket can transition
+to. Here are the transitions we define for our order process.
+
+ Set( %Lifecycles, orders => {
+ # ...,
+ transitions => {
+ '' => [qw(pending processing declined)],
+ pending => [qw(processing declined deleted)],
+ processing => [qw(pending declined delivery delivered deleted)],
+ delivery => [qw(pending delivered returned deleted)],
+ delivered => [qw(pending returned deleted)],
+ returned => [qw(pending delivery deleted)],
+ deleted => [qw(pending processing delivered delivery returned)],
+ },
+ # ...,
+ });
+
+If a ticket is in the delivered status, it doesn't make sense for it to
+transition to processing or declined since the customer already has the
+order. However, it can transition to returned since they could send it back.
+The configuration above defines this for RT.
+
+The C<''> entry defines the valid statuses when a ticket is created.
+
+Deleted is a special status in RT that allows you to remove a ticket from
+active use. You may need to do this if a ticket is created by mistake, or
+a duplicate is created. Once deleted, a ticket will never show up in search
+results. As you can see, the system will allow you to
+transition to deleted from any status.
+
+=head2 Rights and Access Control
+
+Your workflow may have several people working on tickets at different
+steps, and for some you may want to make sure only certain users
+can perform certain actions. For example, the company may have a rule
+that only the quality assurance team is allowed to approve (or decline)
+an order for delivery.
+
+You can apply labels to transitions and assign rights to them to allow
+you to apply this sort of access control. This is done with a rights
+entry:
+
+ Set( %Lifecycles, orders => {
+ # ...,
+ rights => {
+ '* -> declined' => 'DeclineOrder',
+ '* -> delivery' => 'ApproveOrder',
+ },
+ # ...,
+ });
+
+This configuration tells RT to require the right DeclineOrder for a
+transition from any status (C<*>) to C<declined>. The ApproveOrder
+right is similar, but for C<delivery>. These rights take the place of
+the standard ModifyTicket right, not in addition to it, so keep that
+in mind when creating and assigning new rights.
+
+Once these rights are configured and loaded (by restarting the web
+server), they can be assigned in the web UI to groups, queues, and users.
+The rights show up on the rights pages in a Status tab alongside the
+standard RT rights tabs.
+
+=for html <img alt="Lifecycle group rights" src="../images/global-lifecycle-group-rights.png">
+
+=for :text [Lifecycle group rights F<docs/images/global-lifecycle-group-rights.png>]
+
+=for :man [Lifecycle group rights F<docs/images/global-lifecycle-group-rights.png>]
+
+After a status transition right is granted, users with the right will see
+the status in the drop-down, and possibly any related actions (see
+L</Actions>).
+
+=head2 Default Status
+
+There are interfaces to RT from which it isn't possible to define a status,
+like sending an email to create a ticket, but tickets
+require a status. To handle these cases, you can set
+default status values for RT to use when the user doesn't explicitly set
+a value.
+
+Looking at the defaults section in the standard RT configuration,
+you can see the events for which you can define a default status.
+For example, 'on_create' => 'new' automatically gives newly created tickets
+a C<new> status when the requestor doesn't supply a status. We can do the same
+for our process.
+
+ Set( %Lifecycles, orders => {
+ defaults => {
+ on_create => 'pending',
+ },
+ # ...,
+ });
+
+Only a small number of defaults are needed because in practice there are
+relatively few cases where a ticket will find itself without a status or
+in an ambiguous state.
+
+=head2 Actions
+
+To customize how transitions are presented in RT, lifecycles have an
+C<actions> section where you can customize how an action (e.g. changing
+status from new -> open) looks and functions. You can customize the action's
+label, which is how it appears to users, and the type of update, either comment
+or reply. As an example, in the default RT configuration the action
+"new -> open" has the default label "Open it" and an update value of C<Respond>.
+
+Using the lifecycles configuration, you can change the label to anything you
+like. You can set the update option to C<Comment> or C<Respond>, which tells RT
+to process the action as a comment (not sent to requestors) or a reply (sent
+to requestors).
+
+This part of the lifecycles configuration replaces the previous
+C<$ResolveDefaultUpdateType> configuration value. To mimic that option, set
+the update type to C<Comment> for all transitions to C<resolved>.
+
+Here is an example of a change we might make for our order process:
+
+ Set( %Lifecycles, orders => {
+ # ...,
+ actions => [
+ 'pending -> processing' => {
+ label => 'Open For Processing',
+ update => 'Comment',
+ },
+ 'pending -> declined' => {
+ label => 'Decline',
+ update => 'Respond',
+ },
+ # ...
+ ],
+ # ...
+ });
+
+Alternatively, supplying no update type results in a "quick"
+action that changes the status immediately without going through the
+ticket update page. RT's default "Delete" action is a "quick" action,
+for example:
+
+ # from the RT "default" lifecycle
+ 'new -> deleted' => {
+ label => 'Delete',
+ },
+
+If the transition has an associated right, it must be granted for a user to
+see the action. For example, if we give a group the DeclineOrder right as
+shown in the earlier example, members of that group will see a Decline option
+in their Actions menu if a ticket has a pending status. The
+L</"Full Configuration"> at the end shows other action entries that
+make the Decline option available in more cases.
+
+=for html <img alt="Action menu decline" src="../images/action-decline.png">
+
+=for :text [Action menu decline F<docs/images/action-decline.png>]
+
+=for :man [Action menu decline F<docs/images/action-decline.png>]
+
+=head2 Mapping Between Queues
+
+As we've demonstrated, each queue can have its own custom lifecycle, but
+in RT you sometimes want to move a ticket from one queue to another.
+A ticket will have a status in a given queue, but that status may not
+exist in another queue you want to move the ticket to, or it may exist
+but mean something different. To allow tickets to move between queues with
+different lifecycles, RT needs to know how to set the status appropriately.
+
+The lifecycle configuration has a C<__maps__> entry to allow you to
+specify the mappings you want between different queues. Sometimes statuses
+between queues don't or can't match perfectly, but if you need to move
+tickets between those queues, it's important that you provide a complete
+mapping, defining the most sensible mapping you can.
+
+If you don't provide a mapping, users will see an error when they try to
+move a ticket between queues with different lifecycles but no mapping.
+
+ Set( %Lifecycles, orders => {
+ # ...,
+ __maps__ => {
+ 'default -> orders' => {
+ 'new' => 'pending',
+ 'open' => 'processing',
+ # ...,
+ },
+ 'orders -> default' => {
+ 'pending' => 'new',
+ 'processing' => 'open',
+ # ...,
+ },
+ # ...,
+ },
+ # ...,
+ });
+
+In the example above, we first define mappings between the default queue and
+our new orders queue. The second block defines the reverse for tickets that
+might be moved from the orders queue to a queue that uses the default lifecycle.
+
+=head2 Full Configuration
+
+Here is the full configuration if you want to add it to your RT instance
+to experiment.
+
+ Set(%Lifecycles,
+
+ # 'orders' shows up as a lifecycle choice when you create a new
+ # queue or modify an existing one
+ orders => {
+ # All the appropriate order statuses
+ initial => [ 'pending' ],
+ active => [ 'processing', 'delivery' ],
+ inactive => [ 'delivered', 'returned', 'declined' ],
+
+ # Default order statuses for certain actions
+ defaults => {
+ on_create => 'pending',
+ },
+
+ # Status change restrictions
+ transitions => {
+ '' => [qw(pending processing declined)],
+ pending => [qw(processing declined deleted)],
+ processing => [qw(pending declined delivery delivered deleted)],
+ delivery => [qw(pending delivered returned deleted)],
+ delivered => [qw(pending returned deleted)],
+ returned => [qw(pending delivery deleted)],
+ deleted => [qw(pending processing delivered delivery returned)],
+ },
+
+ # Rights for different actions
+ rights => {
+
+ # These rights are in the default lifecycle
+ '* -> deleted' => 'DeleteTicket',
+ '* -> *' => 'ModifyTicket',
+
+ # Maybe we want to create rights to keep QA rigid
+ '* -> declined' => 'DeclineOrder',
+ '* -> delivery' => 'ApproveOrder',
+ },
+
+ # Actions for the web UI
+ actions => [
+ 'pending -> processing' => {
+ label => 'Open For Processing',
+ update => 'Comment',
+ },
+ 'pending -> delivered' => {
+ label => 'Mark as being delivered',
+ update => 'Comment',
+ },
+ 'pending -> declined' => {
+ label => 'Decline',
+ update => 'Respond',
+ },
+ 'pending -> deleted' => {
+ label => 'Delete',
+ },
+ 'processing -> declined' => {
+ label => 'Decline',
+ update => 'Respond',
+ },
+ 'processing -> delivery' => {
+ label => 'Out for delivery',
+ update => 'Comment',
+ },
+ 'delivery -> delivered' => {
+ label => 'Mark as delivered',
+ update => 'Comment',
+ },
+ 'delivery -> returned' => {
+ label => 'Returned to Manufacturer',
+ update => 'Respond',
+ },
+ 'delivered -> returned' => {
+ label => 'Returned to Manufacturer',
+ update => 'Respond',
+ },
+ 'returned -> delivery' => {
+ label => 'Re-deliver Order',
+ update => 'Respond',
+ },
+ 'deleted -> pending' => {
+ label => 'Undelete',
+ update => 'Respond',
+ },
+ ],
+ },
+
+ # Status mapping different different lifecycles
+ __maps__ => {
+ 'default -> orders' => {
+ 'new' => 'pending',
+ 'open' => 'processing',
+ 'stalled' => 'processing',
+ 'resolved' => 'delivered',
+ 'rejected' => 'declined',
+ 'deleted' => 'deleted',
+ },
+ 'orders -> default' => {
+ 'pending' => 'new',
+ 'processing' => 'open',
+ 'delivered' => 'resolved',
+ 'returned' => 'open', # closest matching we have in 'default'
+ 'declined' => 'rejected',
+ 'deleted' => 'deleted',
+ },
+ },
+ );
+
+Here is an example history of a ticket following this lifecycle:
+
+=for html <img alt="Lifecycle history" src="../images/order-history-example.png">
+
+=for :text [Lifecycle history F<docs/images/order-history-example.png>]
+
+=for :man [Lifecycle history F<docs/images/order-history-example.png>]
--- /dev/null
+=head1 RT Search Results
+
+Ticket search results in RT are presented as a table with multiple heading
+rows, one for each element of ticket metadata you have selected. Each
+row in the table represents one ticket and the appropriate metadata is
+displayed in each column. You can see similar listings when you search
+for other objects in RT like users, queues, templates, etc.
+
+For tickets, the Query Builder allows you to modify the column layout using
+the Sorting and Display Columns sections at the bottom of the page. With
+them you can add and remove data elements to sort by, change the sort order,
+and add and remove which columns you want to see.
+
+Although the Add Columns box has an extensive list of available columns, there
+are times when you need a value not listed. Sometimes what you want is a
+value calculated based on existing ticket values, like finding the difference
+between two date fields. RT provides a way to add this sort of customization
+using something called a Column Map.
+
+=head2 Level of Difficulty
+
+The customizations described in this section require administrative access
+to the RT server and the RT filesystem, typically root or sudo level access.
+The customizations involve adding new code to RT, which is written in the
+L<Perl|http://www.perl.org/> programming language and uses the
+L<Mason|http://www.masonbook.com/> templating system. If you follow the example
+closely, you should be able to set up simple column maps with a basic
+understanding of these. For more complicated configurations, you may need
+to do more research to understand the Perl and Mason syntax.
+
+=head2 Column Maps
+
+Each column in a ticket listing gets run through a bit of code called a
+Column Map that allows you to perform transformations on the value before
+it is displayed. In some cases, the value is just passed through. In others,
+like DueRelative, a date is transformed to a relative time like "2 days ago."
+You can tap into this functionality to add your own transformations or even
+generate completely new values.
+
+To add to the existing Column Maps, you can use RT's callback
+mechanism. This allows you to add code to RT without modifying the core files,
+making upgrades much easier. As an example, we'll add a Column Map to the
+ticket display and explain the necessary callbacks. You can read more about
+callbacks in general in the L<writing_extensions/Callbacks> documentation.
+
+For our example, let's assume we want to display a response time column that
+shows the difference between when a ticket is created and when someone
+starts working on it (started date). The two initial values are already
+available on the ticket, but it would be convenient to display the
+calculated value in our search.
+
+=head2 Column Map Callback
+
+First we need to determine where to put our callback. RT's core Column Map code
+for tickets is here:
+
+ share/html/Elements/RT__Ticket/ColumnMap
+
+We'll look there first, both to see some sample Column Maps and also to look
+for an appropriate callback to use to add our own. Looking in that file,
+we see C<$COLUMN_MAP>, which is a large hashref with entries for each of the
+items you see in the Add Columns section of the Query Builder. That's where
+we need to add our new Column Map.
+
+Looking in the C<init> section, we find a callback with a C<CallbackName>
+"Once" and it passes the C<$COLUMN_MAP> reference as an argument, so that's
+the callback we need.
+
+Following the callback documentation, we determine we can put our callback
+here:
+
+ local/html/Callbacks/MyRT/Elements/RT__Ticket/ColumnMap/Once
+
+where F<Once> is the name of the file where we'll put our code.
+
+In the F<Once> file, we'll put the following code:
+
+ <%init>
+ $COLUMN_MAP->{'TimeToFirstResponse'} = {
+ title => 'First Response', # loc
+ attribute => 'First Response',
+ value => sub {
+ my $ticket = shift;
+ return $ticket->StartedObj->DiffAsString($ticket->CreatedObj);
+ }
+ };
+ </%init>
+ <%args>
+ $COLUMN_MAP
+ </%args>
+
+Starting with the C<args> section, the value we're interested in is
+the C<$COLUMN_MAP> hash reference. Since it's a reference, it's pointing
+to the actual data structure constructed in the core RT code. This means
+we can add more entries and RT will have access to them.
+
+=head2 Column Map Parameters
+
+As you can see in the examples in the core F<ColumnMap> file, each entry
+has a key and a hashref with several other parameters. The key needs to be a
+unique value. If you using an existing value, you'll overwrite the original
+values.
+
+The parameters in the hashref are as follows:
+
+=over
+
+=item title
+
+The title is what will be used in the header row to identify this value.
+The C<# loc> is some special markup that allows RT to replace the value
+with translations in other languages, if they are available.
+
+=item attribute
+
+This defines the value you can use to reference your new column map
+from an RT Format configuration. You can edit formats in the Query
+Builder's Advanced section. If you're not familiar with formats, it's
+usually safe to set the attribute to the same value as C<title>. It should
+be descriptive and unique.
+
+=item value
+
+This is where you can put code to transform or calculate the value that
+will be displayed. This sets the value you see in the search results
+for this column.
+
+=back
+
+=cut
+
+Each of these can be a value like a simple string or an anonymous
+subroutine with code that runs to calculate the value.
+
+If you write a subroutine, as we do for C<value> in our example, RT will
+pass the current object as the first parameter to the sub. Since
+we're creating a column map for tickets, as RT processes the ticket for
+each row in the search results, the ticket object for that ticket is made
+available as the first parameter to our subroutine.
+
+This allows us to then call methods on the L<RT::Ticket> object to access
+and process the value. In our case, we can get the L<RT::Date> objects for
+the two dates and use the L<RT::Date/DiffAsString> method to calculate and
+return the difference.
+
+When writing code to calculate values, remember that it will be run for each
+row in search results. You should avoid doing things that are too time
+intensive in that code, like calling a web service to fetch a value.
+
+=head2 Adding to Display Columns
+
+Now that we have our column map created, there is one more callback to add
+to make it available for all of our users in the Add Columns section in
+the Query Builder. This file builds the list of fields available:
+
+ share/html/Search/Elements/BuildFormatString
+
+Looking there, we see the default callback (the callback without an
+explicit C<CallbackName>) passes the C<@fields> array, so that will work.
+Create the file:
+
+ local/html/Callbacks/MyRT/Search/Elements/BuildFormatString/Default
+
+And put the following code in the F<Default> file:
+
+ <%INIT>
+ push @{$Fields}, 'TimeToFirstResponse';
+ </%INIT>
+ <%ARGS>
+ $Fields => undef
+ </%ARGS>
+
+This puts the hash key we chose for our column map in the fields list so it
+will be available in the list of available fields.
+
+=head2 Last Steps
+
+Once you have the code in place, stop the RT web server, clear the Mason
+cache, and restart the server. Watch the RT logs for any errors, and
+navigate to the Query Build to use your new column map.
--- /dev/null
+=head1 Customizing the Look of Your RT
+
+While the default RT color scheme nicely matches the Best Practical colors,
+you may want to personalize your RT instance to make it better fit with
+your company colors.
+
+
+=head1 Selecting a Theme
+
+The fundamental look of RT comes from the selected theme. Different
+RT versions have a default, and the RT admin can set the system-wide
+theme with the C<$WebDefaultStylesheet> configuration value in the
+F<RT_SiteConfig.pm> file.
+
+RT 4.0 comes with the following themes:
+
+=over
+
+=item web2
+
+An approximation of the 3.8 style
+
+=item aileron
+
+The default layout for RT 4.0
+
+=item ballard
+
+Theme which doesn't rely on JavaScript for menuing
+
+=back
+
+If you have granted the ModifySelf right to users on your system,
+they can pick a different theme for themselves by going to
+Logged in as -> Settings -> Options and selecting a different theme.
+
+
+=head1 RT Theme Editor
+
+RT has some built-in controls to manage the look of the theme you select.
+To use the Theme Editor, log in as a SuperUser (like root), and navigate
+to Tools -> Configuration -> Tools -> Theme.
+
+=for html <img alt="RT theme editor, defaults" src="../images/theme_editor_defaults.png">
+
+=for :text [RT theme editor image at F<docs/images/theme_editor_defaults.png>]
+
+=for :man [RT theme editor image at F<docs/images/theme_editor_defaults.png>]
+
+=head2 Logo and Colors
+
+From there you can upload a logo and pick colors for the various page
+sections. RT will automatically pick out the six most frequent primary
+colors from your logo and offer them as options next to the color wheel.
+In less than a minute, you can upload a logo and set a few colors.
+
+Until you click "Save", color changes are temporary and are only shown
+to you. When you find the color scheme you want, click Save to make it
+the new theme for the entire RT instance. If you ever want to wipe the
+slate clean, you can use one or both of the "Reset to default" buttons.
+
+=head2 Basic CSS Customization
+
+The theme editor lets you do a bit more if you know your way around CSS
+or have a web designer who does. By writing your own styles in the
+Custom CSS box, you can quickly customize the RT look and feel pretty
+extensively. The primary RT elements are stubbed out for you in the
+edit box.
+
+After making CSS changes, click Try to see how they look, and click Save
+when you're done.
+
+
+=head1 Advanced CSS Customization
+
+If you're more ambitious and good at CSS, you can go even further and
+create your own theme. As with all modifications to RT, it's a bad idea
+to just change the CSS for one of the standard RT themes in place. When
+you upgrade, if you protect your modifications from being over-written,
+you may miss out on updates that are required for new features. In the
+worst case, an upgrade might wipe out all of your changes.
+
+Below are a few approaches to customizing RT's CSS.
+
+=head2 Additional files
+
+RT allows you to conveniently include additional CSS files after the
+default CSS styles, via the C<@CSSFiles> configuration option. To add
+an extra CSS file, for example F<my-site.css>, create the local overlay
+directory:
+
+ $ mkdir -p local/html/NoAuth/css/
+
+And place your F<my-site.css> file in it. Finally, adjust your
+C<@CSSFiles> in your F<RT_SiteConfig.pm>:
+
+ Set( @CSSFiles, ('my-site.css') );
+
+This technique is preferred to callbacks (below) because CSS included
+via this way will be minified. It is also included across all styles,
+unlike the callback technique.
+
+If you are writing an extension, see L<RT/AddStyleSheets> for how to
+simply and programmatically add values to C<@CSSFiles>.
+
+=head2 Callbacks
+
+RT's CSS files are also Mason templates and the main CSS file,
+conveniently called C<main.css>, has a C<Begin> and C<End> callback
+allowing you to inject custom CSS.
+
+To create an End callback, create the callback directory and an
+End file in that directory:
+
+ $ mkdir -p local/html/Callbacks/MyRT/NoAuth/css/aileron/main.css
+ $ touch local/html/Callbacks/MyRT/NoAuth/css/aileron/main.css/End
+
+You can use any name you want for the C<MyRT> directory and the theme
+directory should correspond with the theme you want to change.
+
+RT will now evaluate the contents of that file after it processes all
+of the C<@import> statements in C<main.css>.
+
+
+=head1 Designing Your Own Theme
+
+The above approaches work well if you need to change the look of
+part of RT, but you may want to design your own RT theme
+and leave the standard RT themes available to users unmodified. In
+this case, you'll want to create your own CSS directory.
+
+As shown above, the C<local> directory is the place to put
+local modifications to RT. Run the following commands in your
+C</opt/rt4> directory (or wherever your RT is installed) to get
+started:
+
+ $ mkdir -p local/html/NoAuth/css/localstyle
+ $ cp -R share/html/NoAuth/css/aileron/* local/html/NoAuth/css/localstyle/
+
+You can call your "localstyle" directory whatever you want and you don't
+have to copy the aileron theme to start from, but it's a good place to
+start off for RT4.
+
+Now set C<$WebDefaultStylesheet> in RT_SiteConfig.pm to the new directory
+name you selected, for example:
+
+ Set( $WebDefaultStylesheet, 'localstyle' );
+
+If you restart your RT it should look just the same (assuming you copied
+your current default theme), but if you go to your Options page you'll
+see that the system default theme is now your new "localtheme."
+
+If you look at the CSS being loaded, you'll also see that the main css
+file is now being loaded from your local directory. But you'll also see
+that files are still being loaded from the main RT css directories as
+well. Why?
+
+The place to start understanding the loading order of RT's CSS is the
+C<main.css> file. You'll see it first loads C<..base/main.css> which
+are the base styles for RT along with styles for other tools RT uses
+like jQuery. After loading all of the base styles, C<main.css> then
+imports a theme-specific version with overrides and new style elements
+for the selected theme. So as long as you follow the CSS precedence rules
+and use the correct specificity, you get the last chance to modify things.
+
+You can start modifying things by editing the CSS files in your new
+localstyle directory. When you upgrade RT, you'll want to look specifically
+at any changes to the style you started from to see if there are any new
+styles you want to merge into your new style.
--- /dev/null
+=head1 Summary of initialdata files
+
+It's often useful to be able to test configuration/database changes and then
+apply the same changes in production without manually clicking around. It's
+also helpful if you're developing customizations or extensions to be able to
+get a fresh database back to the state you want for testing/development.
+
+This documentation applies to careful and thorough sysadmins as well as
+extension authors who need to make database changes easily and repeatably for
+new installs or upgrades.
+
+=head1 Examples
+
+RT ships with many initialdata files, only one of which is used to
+configure a fresh install; the rest are used for upgrades, but function
+the same despite being named differently.
+
+ etc/initialdata
+ etc/upgrade/*/content
+
+The upgrade "content" files are meant to be incremental changes applied on top
+of one another while the top level initialdata file is for fresh RT installs.
+
+Extensions may also ship with database changes in such files. You may find
+some in your install with:
+
+ find local/plugins -name initialdata -or -name content
+
+=head1 What can be in an initialdata file?
+
+initialdata files are Perl, but often consist primarily of a bunch of data
+structures defining the new records you want and not much extra code. There's
+nothing stopping you from writing a bunch of code, however!
+
+The basic template of a new initialdata file should look something like this:
+
+ use strict;
+ use warnings;
+
+ our @Queues = (
+ # some definitions here
+ );
+
+ our @Groups = (
+ # some other definitions here
+ );
+
+ 1;
+
+The C<@Queues> and C<@Groups> arrays are expected by RT and should contain
+hashref definitions. There are many other arrays RT will look for and act on,
+described below. None are required, all may be used. Keep in mind that since
+they're just normal Perl arrays, you can C<push> onto them from a loop or
+C<grep> out definitions based on conditionals or generate their content with
+C<map>, etc.
+
+The complete list of possible arrays which can be used, along with
+descriptions of the values to place in them, is below.
+
+=head2 C<@Users>
+
+ push @Users, {
+ Name => 'john.doe',
+ Password => 'changethis',
+ Language => 'fr',
+ Timezone => 'America/Vancouver',
+ Privileged => 1,
+ Disabled => 0,
+ };
+
+Each hashref in C<@Users> is treated as a new user to create and passed
+straight into C<< RT::User->Create >>. All of the normal user fields are
+available, as well as C<Privileged> and C<Disabled> (both booleans) which will
+do the appropriate internal group/flag handling.
+
+For a full list of fields, read the documentation for L<RT::User/Create>.
+
+=head2 C<@Groups>
+
+ push @Groups, {
+ Domain => 'UserDefined',
+ Name => 'Example Employees',
+ Description => 'All of the employees of my company',
+ };
+
+Creates a new L<RT::Group> for each hashref. In almost all cases you'll want
+to follow the example above to create a group just as if you had done it from
+the admin interface. B<Do not> omit the C<< Domain => 'UserDefined' >> line.
+
+Additionally, the C<MemberOf> field is specially handled to make it easier to
+add the new group to other groups. C<MemberOf> may be a single value or an
+array ref. Each value should be a user-defined group name or hashref to pass
+into L<< RT::Group->LoadByCols >>. Each group found will have the new group
+added as a member.
+
+Unfortunately you can't specify the I<members> of a group at this time. As a
+workaround, you can push a subref into C<@Final> which adds members to your new
+groups. An example, using a convenience function to avoid repeating yourself:
+
+ push @Final, sub {
+ add_members('My New Group Name' => qw(trs alex ruslan));
+ add_members('My Second Group' => qw(jesse kevin sunnavy jim));
+ };
+
+ sub add_members {
+ my $group_name = shift;
+ my @members = @_;
+
+ my $group = RT::Group->new( RT->SystemUser );
+ $group->LoadUserDefinedGroup($group_name);
+
+ if ($group->id) {
+ for my $name (@members) {
+ my $member = RT::User->new( RT->SystemUser );
+ $member->LoadByCols( Name => $name );
+
+ unless ($member->Id) {
+ RT->Logger->error("Unable to find user '$name'");
+ next;
+ }
+
+ my ($ok, $msg) = $group->AddMember( $member->PrincipalObj->Id );
+ if ($ok) {
+ RT->Logger->info("Added member $name to $group_name");
+ } else {
+ RT->Logger->error("Unable to AddMember $name to $group_name: $msg");
+ }
+ }
+ } else {
+ RT->Logger->error("Unable to find group '$group_name'!");
+ }
+ }
+
+=head2 C<@Queues>
+
+ push @Queues, {
+ Name => 'Helpdesk',
+ CorrespondAddress => 'help@example.com',
+ CommentAddress => 'help-comment@example.com',
+ };
+
+Creates a new L<RT::Queue> for each hashref. Refer to the documentation of
+L<RT::Queue/Create> for the fields you can use.
+
+=head2 C<@CustomFields>
+
+ push @CustomFields, {
+ Queue => 0,
+ Name => 'Favorite color',
+ Type => 'FreeformSingle',
+ LookupType => 'RT::Queue-RT::Ticket',
+ };
+
+Creates a new L<RT::CustomField> for each hashref. It is the most complex of
+the initialdata structures. The most commonly used fields are:
+
+=over 4
+
+=item C<Name>
+
+The name of this CF as displayed in RT.
+
+=item C<Description>
+
+A short summary of what this CF is for.
+
+=item C<Queue>
+
+May be a Name or ID. The single queue or array ref of queues to apply this CF
+to. This does not apply when C<LookupType> does not start with C<RT::Queue>.
+
+=item C<Type>
+
+One of the following on the left hand side:
+
+ SelectSingle # Select one value
+ SelectMultiple # Select multiple values
+
+ FreeformSingle # Enter one value
+ FreeformMultiple # Enter multiple values
+
+ Text # Fill in one text area
+ Wikitext # Fill in one wikitext area
+
+ BinarySingle # Upload one file
+ BinaryMultiple # Upload multiple files
+
+ ImageSingle # Upload one image
+ ImageMultiple # Upload multiple images
+
+ Combobox # Combobox: Select or enter one value
+
+ AutocompleteSingle # Enter one value with autocompletion
+ AutocompleteMultiple # Enter multiple values with autocompletion
+
+ Date # Select date
+ DateTime # Select datetime
+
+ IPAddressSingle # Enter one IP address
+ IPAddressMultiple # Enter multiple IP addresses
+
+ IPAddressRangeSingle # Enter one IP address range
+ IPAddressRangeMultiple # Enter multiple IP address ranges
+
+If you don't specify "Single" or "Multiple" in the type, you must specify
+C<MaxValues>.
+
+=item C<LookupType>
+
+Labeled in the CF admin page as "Applies to". This determines whether your CF
+is for Tickets, Transactions, Users, Groups, or Queues. Possible values:
+
+ RT::Queue-RT::Ticket # Tickets
+ RT::Queue-RT::Ticket-RT::Transaction # Transactions
+ RT::User # Users
+ RT::Group # Groups
+ RT::Queue # Queues
+
+Ticket CFs are the most common, meaning C<RT::Queue-RT::Ticket> is the most
+common C<LookupType>.
+
+=item C<RenderType>
+
+Only valid when C<Type> is "Select". Controls how the CF is displayed when
+editing it. Valid values are: C<Select box>, C<List>, and C<Dropdown>.
+
+C<List> is either a list of radio buttons or a list of checkboxes depending on
+C<MaxValues>.
+
+=item C<MaxValues>
+
+Determines whether this CF is a Single or Multiple type. 0 means multiple. 1
+means single.
+
+Make sure to set the C<MaxValues> field appropriately, otherwise you can end up
+with unsupported CF types like a "Select multiple dates" (it doesn't Just
+Work).
+
+You can also use old-style C<Type>s which end with "Single" or "Multiple", for
+example: SelectSingle, SelectMultiple, FreeformSingle, etc.
+
+=item C<Values>
+
+C<Values> should be an array ref (never a single value!) of hashrefs
+representing new L<RT::CustomFieldValue> objects to create for the new custom
+field. This only makes sense for "Select" CFs. An example:
+
+ my $i = 1;
+ push @CustomFields, {
+ Queue => 0, # Globally applied
+ LookupType => 'RT::Queue-RT::Ticket', # for Tickets
+ Name => 'Type of food',
+ Type => 'SelectSingle', # SelectSingle is the same as: Type => 'Select', MaxValues => 1
+ RenderType => 'Dropdown',
+ Values => [
+ { Name => 'Fruit', Description => 'Berries, peaches, tomatos, etc', SortOrder => $i++ },
+ { Name => 'Vegetable', Description => 'Asparagus, peas, lettuce, etc', SortOrder => $i++ },
+ # more values as such...
+ ],
+ };
+
+In order to ensure the same sorting of C<Values>, set C<SortOrder> inside each
+value. A clever way to do this easily is with a simple variable you increment
+each time (as above with C<$i>). You can use the same variable throughout the
+whole file, and don't need one per CF.
+
+=item C<BasedOn>
+
+Name or ID of another Select Custom Field. This makes the named CF the source
+of categories for your values.
+
+=item C<Pattern>
+
+The regular expression text (not C<qr//>!) used to validate values.
+
+=back
+
+Refer to the documentation and implementation of L<RT::CustomField/Create> and
+L<RT::CustomFieldValue/Create> for the full list of available fields and
+allowed values.
+
+=head2 C<@ACL>
+
+C<@ACL> is very useful for granting rights on your newly created records or
+setting up a standard system configuration. It is one of the most complex
+initialdata structures.
+
+=head3 Pick a Right
+
+All ACL definitions expect a key named C<Right> with the internal right name
+you want to grant. The internal right names are visible in RT's admin
+interface in grey next to the longer descriptions.
+
+=head3 Pick a level: on a queue, on a CF, or globally
+
+After picking a C<Right>, you need to specify on what object the right is
+granted. This is B<different> than the user/group/role receiving the right.
+
+=over 4
+
+=item Granted on a custom field by name (or ID), potentially a global or queue
+
+ CF => 'Name',
+
+=item Granted on a queue
+
+ Queue => 'Name',
+
+=item Granted on a custom field applied to a specific queue
+
+ CF => 'Name',
+ Queue => 'Name',
+
+=item Granted globally
+
+Specifying none of the above will get you a global right.
+
+=back
+
+There is currently no way to grant rights on a group or article class level.
+Note that you can grant rights B<to> a group; see below. If you need to grants
+rights on a group or article class level, you'll need to write an C<@Final>
+subref to handle it using the RT Perl API.
+
+=head3 Pick a Principal: User or Group or Role
+
+Finally you need to specify to what system group, system/queue role,
+user defined group, or user you want to grant the right B<to>.
+
+=over 4
+
+=item An internal user group
+
+ GroupDomain => 'SystemInternal',
+ GroupType => 'Everyone, Privileged, or Unprivileged'
+
+=item A system-level role
+
+ GroupDomain => 'RT::System-Role',
+ GroupType => 'Requestor, Owner, AdminCc, or Cc'
+
+=item A queue-level role
+
+ GroupDomain => 'RT::Queue-Role',
+ Queue => 'Name',
+ GroupType => 'Requestor, Owner, AdminCc, or Cc',
+
+=item A group you created
+
+ GroupDomain => 'UserDefined',
+ GroupId => 'Name'
+
+=item Individual user
+
+ UserId => 'Name or email or ID'
+
+=back
+
+=head3 Common cases
+
+You're probably looking for definitions like these most of the time.
+
+=over 4
+
+=item Grant a global right to a group you created
+
+ { Right => '...',
+ GroupDomain => 'UserDefined',
+ GroupId => 'Name' }
+
+=item Grant a queue-level right to a group you created
+
+ { Queue => 'Name',
+ Right => '...',
+ GroupDomain => 'UserDefined',
+ GroupId => 'Name' }
+
+=item Grant a CF-level right to a group you created
+
+ { CF => 'Name',
+ Right => '...',
+ GroupDomain => 'UserDefined',
+ GroupId => 'Name' }
+
+=back
+
+Since you often want to grant a list of rights on the same object/level to the
+same role/group/user, we generally use Perl loops and operators to aid in the
+generation of C<@ACL> without repeating ourselves.
+
+ # Give Requestors globally the right to see tickets, reply, and see the
+ # queue their ticket is in
+ push @ACL, map {
+ {
+ Right => $_,
+ GroupDomain => 'RT::System-Role',
+ GroupType => 'Requestor',
+ }
+ } qw(ShowTicket ReplyToTicket SeeQueue);
+
+=head3 Troubleshooting
+
+The best troubleshooting is often to see how the rights you define in C<@ACL>
+show up in the RT admin interface.
+
+=head2 C<@Scrips>
+
+Creates a new L<RT::Scrip> for each hashref. Refer to the documentation of
+L<RT::Scrip/Create> for the fields you can use.
+
+Additionally, the C<Queue> field is specially handled to make it easier to
+setup the same Scrip on multiple queues:
+
+=over 4
+
+=item Globally
+
+ Queue => 0,
+
+=item Single queue
+
+ Queue => 'General', # Name or ID
+
+=item Multiple queues
+
+ Queue => ['General', 'Helpdesk', 13], # Array ref of Name or ID
+
+=back
+
+=head2 C<@ScripActions>
+
+Creates a new L<RT::ScripAction> for each hashref. Refer to the documentation
+of L<RT::ScripAction/Create> for the fields you can use.
+
+=head2 C<@ScripConditions>
+
+Creates a new L<RT::ScripCondition> for each hashref. Refer to the
+documentation of L<RT::ScripCondition/Create> for the fields you can use.
+
+=head2 C<@Templates>
+
+Creates a new L<RT::Template> for each hashref. Refer to the documentation of
+L<RT::Template/Create> for the fields you can use.
+
+=head2 C<@Attributes>
+
+An array of L<RT::Attribute>s to create. You likely don't need to mess with
+this. If you do, know that the key C<Object> is expected to be an
+L<RT::Record> object on which to call C<AddAttribute>. If you don't provide
+C<Object> or it's undefined, C<< RT->System >> will be used.
+
+=head2 C<@Initial>
+
+=head2 C<@Final>
+
+C<@Initial> and C<@Final> are special and let you write your own processing
+code that runs before anything else or after everything else. They are
+expected to be arrays of subrefs (usually anonymous) like so:
+
+ our @Final = (sub {
+ RT->Logger->info("Finishing up!");
+ });
+
+You have the full power of RT's Perl libraries at your disposal. Be sure to do
+error checking and log any errors with C<< RT->Logger->error("...") >>!
+
+=head1 What's missing?
+
+There is currently no way, short of writing code in C<@Final> or C<@Initial>,
+to easily create B<Classes>, B<Topics>, or B<Articles> from initialdata files.
+
+=head1 Running an initialdata file
+
+ sbin/rt-setup-database --action insert --datafile /path/to/your/initialdata
+
+This may prompt you for a database password.
+
+=head1 Implementation details
+
+All the handling of initialdata files is done in C<< RT::Handle->InsertData >>.
+If you want to know B<exactly> what's happening with each array, your best bet
+is to start reading the code there.
+
+RT takes care of the ordering so that your new queues are created before it
+processes the new ACLs for those queues. This lets you refer to new queues you
+just created by Name.
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+
+use RT;
+RT::LoadConfig();
+RT::Init();
+
+use RT::Queues;
+
+my $queues = RT::Queues->new( RT->SystemUser );
+$queues->UnLimit();
+while ( my $queue = $queues->Next ) {
+ print "Processing queue ". ($queue->Name || $queue->id) ."...\n";
+ my $old_attr = $queue->FirstAttribute('BrandedSubjectTag');
+ unless ( $old_attr ) {
+ print "\thas no old-style subject tag. skipping\n";
+ next;
+ }
+ my $old_value = $old_attr->Content;
+ unless ( $old_value ) {
+ print "\thas empty old-style subject tag\n";
+ } else {
+ my ($status, $msg) = $queue->SetSubjectTag( $old_value );
+ unless ( $status ) {
+ print STDERR "\tERROR. Couldn't set tag: $msg\n";
+ next;
+ } else {
+ print "\thave set new-style subject tag to '$old_value'\n";
+ }
+ }
+
+ my ($status, $msg) = $queue->DeleteAttribute('BrandedSubjectTag');
+ unless ( $status ) {
+ print STDERR "\tERROR. Couldn't delete old-style tag: $msg\n";
+ next;
+ } else {
+ print "\tdeleted old-style tag entry\n";
+ }
+ print "\tDONE\n";
+}
+
+exit 0;
+
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+
+use RT;
+RT::LoadConfig();
+RT::Init();
+
+use RT::Attributes;
+my $attrs = RT::Attributes->new( RT->SystemUser );
+$attrs->Limit(FIELD => 'ObjectType', OPERATOR=> '=', VALUE => 'RT::User');
+$attrs->Limit(FIELD => 'Name', OPERATOR=> '=', VALUE => 'ical-auth-token');
+while ( my $attr = $attrs->Next ) {
+ my $uid = $attr->ObjectId;
+ print "Processing auth token of user #". $uid ."...\n";
+
+ my $user = RT::User->new( RT->SystemUser );
+ $user->Load( $uid );
+ unless ( $user->id ) {
+ print STDERR "\tERROR. Couldn't load user record\n";
+ next;
+ }
+
+ my ($status, $msg);
+
+ ($status, $msg) = $user->DeleteAttribute('AuthToken')
+ if $user->FirstAttribute('AuthToken');
+ unless ( $status ) {
+ print STDERR "\tERROR. Couldn't delete duplicated attribute: $msg\n";
+ next;
+ } else {
+ print "\tdeleted duplicate attribute\n";
+ }
+
+ ($status, $msg) = $attr->SetName('AuthToken');
+ unless ( $status ) {
+ print STDERR "\tERROR. Couldn't rename attribute: $msg\n";
+ next;
+ } else {
+ print "\trenamed attribute\n";
+ }
+ print "\tDONE\n";
+}
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+use RT;
+RT::LoadConfig();
+RT::Init();
+
+use RT::CustomFields;
+my $cfs = RT::CustomFields->new( RT->SystemUser );
+$cfs->{find_disabled_rows} = 1;
+$cfs->Limit(
+ FIELD => 'Type',
+ VALUE => 'SelectCheckbox',
+);
+
+while ( my $cf = $cfs->Next ) {
+ print 'Processing custom field #' . $cf->id . "\n";
+ my ( $ret, $msg ) = $cf->SetType('Select');
+ unless ($ret) {
+ warn "Failed to set custom field #"
+ . $cf->id
+ . " Type to 'Select': $msg\n";
+ }
+
+ ( $ret, $msg ) = $cf->SetRenderType('List');
+ unless ($ret) {
+ warn "Failed to set custom field #"
+ . $cf->id
+ . " RenderType to 'List': $msg\n";
+ }
+}
+
+print "DONE\n";
+
+exit 0;
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+use RT;
+RT::LoadConfig();
+RT->Config->Set('LogToScreen' => 'debug');
+RT::Init();
+
+$| = 1;
+
+if (my $re = RT->Config->Get('RTAddressRegexp')) {
+ print "No need to use this script, you already have RTAddressRegexp set to $re\n";
+ exit;
+}
+
+use RT::Queues;
+my $queues = RT::Queues->new( RT->SystemUser );
+$queues->UnLimit;
+
+my %merged;
+merge(\%merged, RT->Config->Get('CorrespondAddress'), RT->Config->Get('CommentAddress'));
+while ( my $queue = $queues->Next ) {
+ merge(\%merged, $queue->CorrespondAddress, $queue->CommentAddress);
+}
+
+my @domains;
+for my $domain (sort keys %merged) {
+ my @addresses;
+ for my $base (sort keys %{$merged{$domain}}) {
+ my @subbits = keys(%{$merged{$domain}{$base}});
+ if (@subbits > 1) {
+ push @addresses, "\Q$base\E(?:".join("|",@subbits).")";
+ } else {
+ push @addresses, "\Q$base\E$subbits[0]";
+ }
+ }
+ if (@addresses > 1) {
+ push @domains, "(?:".join("|", @addresses).")\Q\@".$domain."\E";
+ } else {
+ push @domains, "$addresses[0]\Q\@$domain\E";
+ }
+}
+my $re = join "|", @domains;
+
+print <<ENDDESCRIPTION;
+You can add the following to RT_SiteConfig.pm, but may want to collapse it into a more efficient regexp.
+Keep in mind that this only contains the email addresses that RT knows about, you should also examine
+your mail system for aliases that reach RT but which RT doesn't know about.
+ENDDESCRIPTION
+print "Set(\$RTAddressRegexp,qr{^(?:${re})\$}i);\n";
+
+sub merge {
+ my $merged = shift;
+ for my $address (grep {defined and length} @_) {
+ $address =~ /^\s*(.*?)(-comments?)?\@(.*?)\s*$/;
+ $merged->{lc $3}{$1}{$2||''}++;
+ }
+}
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+use RT;
+RT::LoadConfig();
+RT->Config->Set('LogToScreen' => 'debug');
+RT::Init();
+
+$| = 1;
+
+$RT::Handle->BeginTransaction();
+
+use RT::CustomFields;
+my $CFs = RT::CustomFields->new( RT->SystemUser );
+$CFs->UnLimit;
+$CFs->Limit( FIELD => 'Type', VALUE => 'Select' );
+
+my $seen;
+while (my $cf = $CFs->Next ) {
+ next if $cf->BasedOnObj->Id;
+ my @categories;
+ my %mapping;
+ my $values = $cf->Values;
+ while (my $value = $values->Next) {
+ next unless defined $value->Category and length $value->Category;
+ push @categories, $value->Category unless grep {$_ eq $value->Category} @categories;
+ $mapping{$value->Name} = $value->Category;
+ }
+ next unless @categories;
+
+ $seen++;
+ print "Found CF '@{[$cf->Name]}' with categories:\n";
+ print " $_\n" for @categories;
+
+ print "Split this CF's categories into a hierarchical custom field (Y/n)? ";
+ my $dothis = <>;
+ next if $dothis =~ /n/i;
+
+ print "Enter name of CF to create as category ('@{[$cf->Name]} category'): ";
+ my $newname = <>;
+ chomp $newname;
+ $newname = $cf->Name . " category" unless length $newname;
+
+ # bump the CF's sort oder up by one
+ $cf->SetSortOrder( ($cf->SortOrder || 0) + 1 );
+
+ # ..and add a new CF before it
+ my $new = RT::CustomField->new( RT->SystemUser );
+ my ($id, $msg) = $new->Create(
+ Name => $newname,
+ Type => 'Select',
+ MaxValues => 1,
+ LookupType => $cf->LookupType,
+ SortOrder => $cf->SortOrder - 1,
+ );
+ die "Can't create custom field '$newname': $msg" unless $id;
+
+ # Set the CF to be based on what we just made
+ $cf->SetBasedOn( $new->Id );
+
+ # Apply it to all of the same things
+ {
+ my $ocfs = RT::ObjectCustomFields->new( RT->SystemUser );
+ $ocfs->LimitToCustomField( $cf->Id );
+ while (my $ocf = $ocfs->Next) {
+ my $newocf = RT::ObjectCustomField->new( RT->SystemUser );
+ ($id, $msg) = $newocf->Create(
+ SortOrder => $ocf->SortOrder,
+ CustomField => $new->Id,
+ ObjectId => $ocf->ObjectId,
+ );
+ die "Can't create ObjectCustomField: $msg" unless $id;
+ }
+ }
+
+ # Copy over all of the rights
+ {
+ my $acl = RT::ACL->new( RT->SystemUser );
+ $acl->LimitToObject( $cf );
+ while (my $ace = $acl->Next) {
+ my $newace = RT::ACE->new( RT->SystemUser );
+ ($id, $msg) = $newace->Create(
+ PrincipalId => $ace->PrincipalId,
+ PrincipalType => $ace->PrincipalType,
+ RightName => $ace->RightName,
+ Object => $new,
+ );
+ die "Can't assign rights: $msg" unless $id;
+ }
+ }
+
+ # Add values for all of the categories
+ for my $i (0..$#categories) {
+ ($id, $msg) = $new->AddValue(
+ Name => $categories[$i],
+ SortOrder => $i + 1,
+ );
+ die "Can't create custom field value: $msg" unless $id;
+ }
+
+ # Grovel through all ObjectCustomFieldValues, and add the
+ # appropriate category
+ {
+ my $ocfvs = RT::ObjectCustomFieldValues->new( RT->SystemUser );
+ $ocfvs->LimitToCustomField( $cf->Id );
+ while (my $ocfv = $ocfvs->Next) {
+ next unless exists $mapping{$ocfv->Content};
+ my $newocfv = RT::ObjectCustomFieldValue->new( RT->SystemUser );
+ ($id, $msg) = $newocfv->Create(
+ CustomField => $new->Id,
+ ObjectType => $ocfv->ObjectType,
+ ObjectId => $ocfv->ObjectId,
+ Content => $mapping{$ocfv->Content},
+ );
+ }
+ }
+}
+
+$RT::Handle->Commit;
+print "No custom fields with categories found\n" unless $seen;
--- /dev/null
+#!/usr/bin/perl
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+use strict;
+use warnings;
+
+use lib "/opt/rt3/local/lib";
+use lib "/opt/rt3/lib";
+
+use RT;
+RT::LoadConfig;
+RT::Init;
+
+$| = 1;
+
+use Getopt::Long;
+use Digest::SHA;
+my $fix;
+GetOptions("fix!" => \$fix);
+
+use RT::Users;
+my $users = RT::Users->new( $RT::SystemUser );
+$users->Limit(
+ FIELD => 'Password',
+ OPERATOR => 'IS NOT',
+ VALUE => 'NULL',
+ ENTRYAGGREGATOR => 'AND',
+);
+$users->Limit(
+ FIELD => 'Password',
+ OPERATOR => '!=',
+ VALUE => '*NO-PASSWORD*',
+ ENTRYAGGREGATOR => 'AND',
+);
+$users->Limit(
+ FIELD => 'Password',
+ OPERATOR => 'NOT STARTSWITH',
+ VALUE => '!',
+ ENTRYAGGREGATOR => 'AND',
+);
+push @{$users->{'restrictions'}{ "main.Password" }}, "AND", {
+ field => 'LENGTH(main.Password)',
+ op => '<',
+ value => '40',
+};
+
+# we want to update passwords on disabled users
+$users->{'find_disabled_rows'} = 1;
+
+my $count = $users->Count;
+if ($count == 0) {
+ print "No users with unsalted or weak cryptography found.\n";
+ exit 0;
+}
+
+if ($fix) {
+ print "Upgrading $count users...\n";
+ while (my $u = $users->Next) {
+ my $stored = $u->__Value("Password");
+ my $raw;
+ if (length $stored == 32) {
+ $raw = pack("H*",$stored);
+ } elsif (length $stored == 22) {
+ $raw = MIME::Base64::decode_base64($stored);
+ } elsif (length $stored == 13) {
+ printf "%20s => Old crypt() format, cannot upgrade\n", $u->Name;
+ } else {
+ printf "%20s => Unknown password format!\n", $u->Name;
+ }
+ next unless $raw;
+
+ my $salt = pack("C4",map{int rand(256)} 1..4);
+ my $sha = Digest::SHA::sha256(
+ $salt . $raw
+ );
+ $u->_Set(
+ Field => "Password",
+ Value => MIME::Base64::encode_base64(
+ $salt . substr($sha,0,26), ""),
+ );
+ }
+ print "Done.\n";
+ exit 0;
+} else {
+ if ($count < 20) {
+ print "$count users found with unsalted or weak-cryptography passwords:\n";
+ print " Id | Name\n", "-"x9, "+", "-"x9, "\n";
+ while (my $u = $users->Next) {
+ printf "%8d | %s\n", $u->Id, $u->Name;
+ }
+ } else {
+ print "$count users found with unsalted or weak-cryptography passwords\n";
+ }
+
+ print "\n", "Run again with --fix to upgrade.\n";
+ exit 1;
+}
package RT;
+use Encode ();
use File::Spec ();
use Cwd ();
$frame++ while caller($frame) && caller($frame) =~ /^Log::/;
my ($package, $filename, $line) = caller($frame);
+ # Encode to bytes, so we don't send wide characters
+ $p{message} = Encode::encode("UTF-8", $p{message});
+
$p{'message'} =~ s/(?:\r*\n)+$//;
return "[$$] [". gmtime(time) ."] [". $p{'level'} ."]: "
. $p{'message'} ." ($filename:$line)\n";
$frame++ while caller($frame) && caller($frame) =~ /^Log::/;
my ($package, $filename, $line) = caller($frame);
- # syswrite() cannot take utf8; turn it off here.
- Encode::_utf8_off($p{message});
+ # Encode to bytes, so we don't send wide characters
+ $p{message} = Encode::encode("UTF-8", $p{message});
$p{message} =~ s/(?:\r*\n)+$//;
if ($p{level} eq 'debug') {
## mechanism (see above).
$SIG{__WARN__} = sub {
- # The 'wide character' warnings has to be silenced for now, at least
- # until HTML::Mason offers a sane way to process both raw output and
- # unicode strings.
# use 'goto &foo' syntax to hide ANON sub from stack
- if( index($_[0], 'Wide character in ') != 0 ) {
- unshift @_, $RT::Logger, qw(level warning message);
- goto &Log::Dispatch::log;
- }
- # Return value is used only by RT::Test to filter warnings from
- # reaching the Test::NoWarnings catcher. If Log::Dispatch::log() ever
- # starts returning 'IGNORE', we'll need to switch to something more
- # clever. I don't expect that to happen.
- return 'IGNORE';
+ unshift @_, $RT::Logger, qw(level warning message);
+ goto &Log::Dispatch::log;
};
#When we call die, trap it and log->crit with the value of the die.
my %args = (@_);
my $template_id;
- require Encode;
- require utf8;
my ( $queue, $requestor );
$RT::Logger->debug("Line: ===");
foreach my $line ( split( /\n/, $args{'Content'} ) ) {
$line =~ s/\r$//;
- $RT::Logger->debug( "Line: " . utf8::is_utf8($line)
- ? Encode::encode_utf8($line)
- : $line );
+ $RT::Logger->debug( "Line: $line" );
if ( $line =~ /^===/ ) {
if ( $template_id && !$queue && $args{'Queue'} ) {
$self->{'templates'}->{$template_id}
);
if ( $args{content} ) {
- my $mimeobj = MIME::Entity->new();
- $mimeobj->build(
- Type => $args{'contenttype'} || 'text/plain',
- Data => $args{'content'}
+ my $mimeobj = MIME::Entity->build(
+ Type => $args{'contenttype'} || 'text/plain',
+ Charset => 'UTF-8',
+ Data => [ map {Encode::encode( "UTF-8", $_ )} @{$args{'content'}} ],
);
$ticketargs{MIMEObj} = $mimeobj;
$ticketargs{UpdateType} = $args{'updatetype'} || 'correspond';
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+package RT::Action::CreateTickets;
+use base 'RT::Action';
+
+use strict;
+use warnings;
+
+use MIME::Entity;
+
+=head1 NAME
+
+RT::Action::CreateTickets - Create one or more tickets according to an externally supplied template
+
+=head1 SYNOPSIS
+
+ ===Create-Ticket: codereview
+ Subject: Code review for {$Tickets{'TOP'}->Subject}
+ Depended-On-By: TOP
+ Content: Someone has created a ticket. you should review and approve it,
+ so they can finish their work
+ ENDOFCONTENT
+
+=head1 DESCRIPTION
+
+The CreateTickets ScripAction allows you to create automated workflows in RT,
+creating new tickets in response to actions and conditions from other
+tickets.
+
+=head2 Format
+
+CreateTickets uses the RT template configured in the scrip as a template
+for an ordered set of tickets to create. The basic format is as follows:
+
+ ===Create-Ticket: identifier
+ Param: Value
+ Param2: Value
+ Param3: Value
+ Content: Blah
+ blah
+ blah
+ ENDOFCONTENT
+ ===Create-Ticket: id2
+ Param: Value
+ Content: Blah
+ ENDOFCONTENT
+
+As shown, you can put one or more C<===Create-Ticket:> sections in
+a template. Each C<===Create-Ticket:> section is evaluated as its own
+L<Text::Template> object, which means that you can embed snippets
+of Perl inside the L<Text::Template> using C<{}> delimiters, but that
+such sections absolutely can not span a C<===Create-Ticket:> boundary.
+
+Note that each C<Value> must come right after the C<Param> on the same
+line. The C<Content:> param can extend over multiple lines, but the text
+of the first line must start right after C<Content:>. Don't try to start
+your C<Content:> section with a newline.
+
+After each ticket is created, it's stuffed into a hash called C<%Tickets>
+making it available during the creation of other tickets during the
+same ScripAction. The hash key for each ticket is C<create-[identifier]>,
+where C<[identifier]> is the value you put after C<===Create-Ticket:>. The hash
+is prepopulated with the ticket which triggered the ScripAction as
+C<$Tickets{'TOP'}>. You can also access that ticket using the shorthand
+C<TOP>.
+
+A simple example:
+
+ ===Create-Ticket: codereview
+ Subject: Code review for {$Tickets{'TOP'}->Subject}
+ Depended-On-By: TOP
+ Content: Someone has created a ticket. you should review and approve it,
+ so they can finish their work
+ ENDOFCONTENT
+
+A convoluted example:
+
+ ===Create-Ticket: approval
+ { # Find out who the administrators of the group called "HR"
+ # of which the creator of this ticket is a member
+ my $name = "HR";
+
+ my $groups = RT::Groups->new(RT->SystemUser);
+ $groups->LimitToUserDefinedGroups();
+ $groups->Limit(FIELD => "Name", OPERATOR => "=", VALUE => "$name");
+ $groups->WithMember($TransactionObj->CreatorObj->Id);
+
+ my $groupid = $groups->First->Id;
+
+ my $adminccs = RT::Users->new(RT->SystemUser);
+ $adminccs->WhoHaveRight(
+ Right => "AdminGroup",
+ Object =>$groups->First,
+ IncludeSystemRights => undef,
+ IncludeSuperusers => 0,
+ IncludeSubgroupMembers => 0,
+ );
+
+ our @admins;
+ while (my $admin = $adminccs->Next) {
+ push (@admins, $admin->EmailAddress);
+ }
+ }
+ Queue: ___Approvals
+ Type: approval
+ AdminCc: {join ("\nAdminCc: ",@admins) }
+ Depended-On-By: TOP
+ Refers-To: TOP
+ Subject: Approval for ticket: {$Tickets{"TOP"}->Id} - {$Tickets{"TOP"}->Subject}
+ Due: {time + 86400}
+ Content-Type: text/plain
+ Content: Your approval is requested for the ticket {$Tickets{"TOP"}->Id}: {$Tickets{"TOP"}->Subject}
+ Blah
+ Blah
+ ENDOFCONTENT
+ ===Create-Ticket: two
+ Subject: Manager approval
+ Type: approval
+ Depended-On-By: TOP
+ Refers-To: {$Tickets{"create-approval"}->Id}
+ Queue: ___Approvals
+ Content-Type: text/plain
+ Content: Your approval is requred for this ticket, too.
+ ENDOFCONTENT
+
+As shown above, you can include a block with Perl code to set up some
+values for the new tickets. If you want to access a variable in the
+template section after the block, you must scope it with C<our> rather
+than C<my>. Just as with other RT templates, you can also include
+Perl code in the template sections using C<{}>.
+
+=head2 Acceptable Fields
+
+A complete list of acceptable fields:
+
+ * Queue => Name or id# of a queue
+ Subject => A text string
+ ! Status => A valid status. Defaults to 'new'
+ Due => Dates can be specified in seconds since the epoch
+ to be handled literally or in a semi-free textual
+ format which RT will attempt to parse.
+ Starts =>
+ Started =>
+ Resolved =>
+ Owner => Username or id of an RT user who can and should own
+ this ticket; forces the owner if necessary
+ + Requestor => Email address
+ + Cc => Email address
+ + AdminCc => Email address
+ + RequestorGroup => Group name
+ + CcGroup => Group name
+ + AdminCcGroup => Group name
+ TimeWorked =>
+ TimeEstimated =>
+ TimeLeft =>
+ InitialPriority =>
+ FinalPriority =>
+ Type =>
+ +! DependsOn =>
+ +! DependedOnBy =>
+ +! RefersTo =>
+ +! ReferredToBy =>
+ +! Members =>
+ +! MemberOf =>
+ Content => Content. Can extend to multiple lines. Everything
+ within a template after a Content: header is treated
+ as content until we hit a line containing only
+ ENDOFCONTENT
+ ContentType => the content-type of the Content field. Defaults to
+ 'text/plain'
+ UpdateType => 'correspond' or 'comment'; used in conjunction with
+ 'content' if this is an update. Defaults to
+ 'correspond'
+
+ CustomField-<id#> => custom field value
+ CF-name => custom field value
+ CustomField-name => custom field value
+
+Fields marked with an C<*> are required.
+
+Fields marked with a C<+> may have multiple values, simply
+by repeating the fieldname on a new line with an additional value.
+
+Fields marked with a C<!> have processing postponed until after all
+tickets in the same actions are created. Except for C<Status>, those
+fields can also take a ticket name within the same action (i.e.
+the identifiers after C<===Create-Ticket:>), instead of raw ticket ID
+numbers.
+
+When parsed, field names are converted to lowercase and have hyphens stripped.
+C<Refers-To>, C<RefersTo>, C<refersto>, C<refers-to> and C<r-e-f-er-s-tO> will
+all be treated as the same thing.
+
+=head1 METHODS
+
+=cut
+
+my %LINKTYPEMAP = (
+ MemberOf => {
+ Type => 'MemberOf',
+ Mode => 'Target',
+ },
+ Parents => {
+ Type => 'MemberOf',
+ Mode => 'Target',
+ },
+ Members => {
+ Type => 'MemberOf',
+ Mode => 'Base',
+ },
+ Children => {
+ Type => 'MemberOf',
+ Mode => 'Base',
+ },
+ HasMember => {
+ Type => 'MemberOf',
+ Mode => 'Base',
+ },
+ RefersTo => {
+ Type => 'RefersTo',
+ Mode => 'Target',
+ },
+ ReferredToBy => {
+ Type => 'RefersTo',
+ Mode => 'Base',
+ },
+ DependsOn => {
+ Type => 'DependsOn',
+ Mode => 'Target',
+ },
+ DependedOnBy => {
+ Type => 'DependsOn',
+ Mode => 'Base',
+ },
+
+);
+
+
+#Do what we need to do and send it out.
+sub Commit {
+ my $self = shift;
+
+ # Create all the tickets we care about
+ return (1) unless $self->TicketObj->Type eq 'ticket';
+
+ $self->CreateByTemplate( $self->TicketObj );
+ $self->UpdateByTemplate( $self->TicketObj );
+ return (1);
+}
+
+
+
+sub Prepare {
+ my $self = shift;
+
+ unless ( $self->TemplateObj ) {
+ $RT::Logger->warning("No template object handed to $self");
+ }
+
+ unless ( $self->TransactionObj ) {
+ $RT::Logger->warning("No transaction object handed to $self");
+
+ }
+
+ unless ( $self->TicketObj ) {
+ $RT::Logger->warning("No ticket object handed to $self");
+
+ }
+
+ my $active = 0;
+ if ( $self->TemplateObj->Type eq 'Perl' ) {
+ $active = 1;
+ } else {
+ RT->Logger->info(sprintf(
+ "Template #%d is type %s. You most likely want to use a Perl template instead.",
+ $self->TemplateObj->id, $self->TemplateObj->Type
+ ));
+ }
+
+ $self->Parse(
+ Content => $self->TemplateObj->Content,
+ _ActiveContent => $active,
+ );
+ return 1;
+
+}
+
+
+
+sub CreateByTemplate {
+ my $self = shift;
+ my $top = shift;
+
+ $RT::Logger->debug("In CreateByTemplate");
+
+ my @results;
+
+ # XXX: cargo cult programming that works. i'll be back.
+
+ local %T::Tickets = %T::Tickets;
+ local $T::TOP = $T::TOP;
+ local $T::ID = $T::ID;
+ $T::Tickets{'TOP'} = $T::TOP = $top if $top;
+ local $T::TransactionObj = $self->TransactionObj;
+
+ my $ticketargs;
+ my ( @links, @postponed );
+ foreach my $template_id ( @{ $self->{'create_tickets'} } ) {
+ $RT::Logger->debug("Workflow: processing $template_id of $T::TOP")
+ if $T::TOP;
+
+ $T::ID = $template_id;
+ @T::AllID = @{ $self->{'create_tickets'} };
+
+ ( $T::Tickets{$template_id}, $ticketargs )
+ = $self->ParseLines( $template_id, \@links, \@postponed );
+
+ # Now we have a %args to work with.
+ # Make sure we have at least the minimum set of
+ # reasonable data and do our thang
+
+ my ( $id, $transid, $msg )
+ = $T::Tickets{$template_id}->Create(%$ticketargs);
+
+ foreach my $res ( split( '\n', $msg ) ) {
+ push @results,
+ $T::Tickets{$template_id}
+ ->loc( "Ticket [_1]", $T::Tickets{$template_id}->Id ) . ': '
+ . $res;
+ }
+ if ( !$id ) {
+ if ( $self->TicketObj ) {
+ $msg = "Couldn't create related ticket $template_id for "
+ . $self->TicketObj->Id . " "
+ . $msg;
+ } else {
+ $msg = "Couldn't create ticket $template_id " . $msg;
+ }
+
+ $RT::Logger->error($msg);
+ next;
+ }
+
+ $RT::Logger->debug("Assigned $template_id with $id");
+ $T::Tickets{$template_id}->SetOriginObj( $self->TicketObj )
+ if $self->TicketObj
+ && $T::Tickets{$template_id}->can('SetOriginObj');
+
+ }
+
+ $self->PostProcess( \@links, \@postponed );
+
+ return @results;
+}
+
+sub UpdateByTemplate {
+ my $self = shift;
+ my $top = shift;
+
+ # XXX: cargo cult programming that works. i'll be back.
+
+ my @results;
+ local %T::Tickets = %T::Tickets;
+ local $T::ID = $T::ID;
+
+ my $ticketargs;
+ my ( @links, @postponed );
+ foreach my $template_id ( @{ $self->{'update_tickets'} } ) {
+ $RT::Logger->debug("Update Workflow: processing $template_id");
+
+ $T::ID = $template_id;
+ @T::AllID = @{ $self->{'update_tickets'} };
+
+ ( $T::Tickets{$template_id}, $ticketargs )
+ = $self->ParseLines( $template_id, \@links, \@postponed );
+
+ # Now we have a %args to work with.
+ # Make sure we have at least the minimum set of
+ # reasonable data and do our thang
+
+ my @attribs = qw(
+ Subject
+ FinalPriority
+ Priority
+ TimeEstimated
+ TimeWorked
+ TimeLeft
+ Status
+ Queue
+ Due
+ Starts
+ Started
+ Resolved
+ );
+
+ my $id = $template_id;
+ $id =~ s/update-(\d+).*/$1/;
+ my ($loaded, $msg) = $T::Tickets{$template_id}->LoadById($id);
+
+ unless ( $loaded ) {
+ $RT::Logger->error("Couldn't update ticket $template_id: " . $msg);
+ push @results, $self->loc( "Couldn't load ticket '[_1]'", $id );
+ next;
+ }
+
+ my $current = $self->GetBaseTemplate( $T::Tickets{$template_id} );
+
+ $template_id =~ m/^update-(.*)/;
+ my $base_id = "base-$1";
+ my $base = $self->{'templates'}->{$base_id};
+ if ($base) {
+ $base =~ s/\r//g;
+ $base =~ s/\n+$//;
+ $current =~ s/\n+$//;
+
+ # If we have no base template, set what we can.
+ if ( $base ne $current ) {
+ push @results,
+ "Could not update ticket "
+ . $T::Tickets{$template_id}->Id
+ . ": Ticket has changed";
+ next;
+ }
+ }
+ push @results, $T::Tickets{$template_id}->Update(
+ AttributesRef => \@attribs,
+ ARGSRef => $ticketargs
+ );
+
+ if ( $ticketargs->{'Owner'} ) {
+ ($id, $msg) = $T::Tickets{$template_id}->SetOwner($ticketargs->{'Owner'}, "Force");
+ push @results, $msg unless $msg eq $self->loc("That user already owns that ticket");
+ }
+
+ push @results,
+ $self->UpdateWatchers( $T::Tickets{$template_id}, $ticketargs );
+
+ push @results,
+ $self->UpdateCustomFields( $T::Tickets{$template_id}, $ticketargs );
+
+ next unless $ticketargs->{'MIMEObj'};
+ if ( $ticketargs->{'UpdateType'} =~ /^(private|comment)$/i ) {
+ my ( $Transaction, $Description, $Object )
+ = $T::Tickets{$template_id}->Comment(
+ BccMessageTo => $ticketargs->{'Bcc'},
+ MIMEObj => $ticketargs->{'MIMEObj'},
+ TimeTaken => $ticketargs->{'TimeWorked'}
+ );
+ push( @results,
+ $T::Tickets{$template_id}
+ ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id )
+ . ': '
+ . $Description );
+ } elsif ( $ticketargs->{'UpdateType'} =~ /^(public|response|correspond)$/i ) {
+ my ( $Transaction, $Description, $Object )
+ = $T::Tickets{$template_id}->Correspond(
+ BccMessageTo => $ticketargs->{'Bcc'},
+ MIMEObj => $ticketargs->{'MIMEObj'},
+ TimeTaken => $ticketargs->{'TimeWorked'}
+ );
+ push( @results,
+ $T::Tickets{$template_id}
+ ->loc( "Ticket [_1]", $T::Tickets{$template_id}->id )
+ . ': '
+ . $Description );
+ } else {
+ push(
+ @results,
+ $T::Tickets{$template_id}->loc(
+ "Update type was neither correspondence nor comment.")
+ . " "
+ . $T::Tickets{$template_id}->loc("Update not recorded.")
+ );
+ }
+ }
+
+ $self->PostProcess( \@links, \@postponed );
+
+ return @results;
+}
+
+=head2 Parse
+
+Takes (in order) template content, a default queue, a default requestor, and
+active (a boolean flag).
+
+Parses a template in the template content, defaulting queue and requestor if
+unspecified in the template to the values provided as arguments.
+
+If the active flag is true, then we'll use L<Text::Template> to parse the
+templates, allowing you to embed active Perl in your templates.
+
+=cut
+
+sub Parse {
+ my $self = shift;
+ my %args = (
+ Content => undef,
+ Queue => undef,
+ Requestor => undef,
+ _ActiveContent => undef,
+ @_
+ );
+
+ if ( $args{'_ActiveContent'} ) {
+ $self->{'UsePerlTextTemplate'} = 1;
+ } else {
+
+ $self->{'UsePerlTextTemplate'} = 0;
+ }
+
+ if ( substr( $args{'Content'}, 0, 3 ) eq '===' ) {
+ $self->_ParseMultilineTemplate(%args);
+ } elsif ( $args{'Content'} =~ /(?:\t|,)/i ) {
+ $self->_ParseXSVTemplate(%args);
+ } else {
+ RT->Logger->error("Invalid Template Content (Couldn't find ===, and is not a csv/tsv template) - unable to parse: $args{Content}");
+ }
+}
+
+=head2 _ParseMultilineTemplate
+
+Parses mulitline templates. Things like:
+
+ ===Create-Ticket: ...
+
+Takes the same arguments as L</Parse>.
+
+=cut
+
+sub _ParseMultilineTemplate {
+ my $self = shift;
+ my %args = (@_);
+
+ my $template_id;
+ require Encode;
+ require utf8;
+ my ( $queue, $requestor );
+ $RT::Logger->debug("Line: ===");
+ foreach my $line ( split( /\n/, $args{'Content'} ) ) {
+ $line =~ s/\r$//;
+ $RT::Logger->debug( "Line: " . utf8::is_utf8($line)
+ ? Encode::encode_utf8($line)
+ : $line );
+ if ( $line =~ /^===/ ) {
+ if ( $template_id && !$queue && $args{'Queue'} ) {
+ $self->{'templates'}->{$template_id}
+ .= "Queue: $args{'Queue'}\n";
+ }
+ if ( $template_id && !$requestor && $args{'Requestor'} ) {
+ $self->{'templates'}->{$template_id}
+ .= "Requestor: $args{'Requestor'}\n";
+ }
+ $queue = 0;
+ $requestor = 0;
+ }
+ if ( $line =~ /^===Create-Ticket: (.*)$/ ) {
+ $template_id = "create-$1";
+ $RT::Logger->debug("**** Create ticket: $template_id");
+ push @{ $self->{'create_tickets'} }, $template_id;
+ } elsif ( $line =~ /^===Update-Ticket: (.*)$/ ) {
+ $template_id = "update-$1";
+ $RT::Logger->debug("**** Update ticket: $template_id");
+ push @{ $self->{'update_tickets'} }, $template_id;
+ } elsif ( $line =~ /^===Base-Ticket: (.*)$/ ) {
+ $template_id = "base-$1";
+ $RT::Logger->debug("**** Base ticket: $template_id");
+ push @{ $self->{'base_tickets'} }, $template_id;
+ } elsif ( $line =~ /^===#.*$/ ) { # a comment
+ next;
+ } else {
+ if ( $line =~ /^Queue:(.*)/i ) {
+ $queue = 1;
+ my $value = $1;
+ $value =~ s/^\s//;
+ $value =~ s/\s$//;
+ if ( !$value && $args{'Queue'} ) {
+ $value = $args{'Queue'};
+ $line = "Queue: $value";
+ }
+ }
+ if ( $line =~ /^Requestors?:(.*)/i ) {
+ $requestor = 1;
+ my $value = $1;
+ $value =~ s/^\s//;
+ $value =~ s/\s$//;
+ if ( !$value && $args{'Requestor'} ) {
+ $value = $args{'Requestor'};
+ $line = "Requestor: $value";
+ }
+ }
+ $self->{'templates'}->{$template_id} .= $line . "\n";
+ }
+ }
+ if ( $template_id && !$queue && $args{'Queue'} ) {
+ $self->{'templates'}->{$template_id} .= "Queue: $args{'Queue'}\n";
+ }
+ }
+
+sub ParseLines {
+ my $self = shift;
+ my $template_id = shift;
+ my $links = shift;
+ my $postponed = shift;
+
+ my $content = $self->{'templates'}->{$template_id};
+
+ if ( $self->{'UsePerlTextTemplate'} ) {
+
+ $RT::Logger->debug(
+ "Workflow: evaluating\n$self->{templates}{$template_id}");
+
+ my $template = Text::Template->new(
+ TYPE => 'STRING',
+ SOURCE => $content
+ );
+
+ my $err;
+ $content = $template->fill_in(
+ PACKAGE => 'T',
+ BROKEN => sub {
+ $err = {@_}->{error};
+ }
+ );
+
+ $RT::Logger->debug("Workflow: yielding $content");
+
+ if ($err) {
+ $RT::Logger->error( "Ticket creation failed: " . $err );
+ while ( my ( $k, $v ) = each %T::X ) {
+ $RT::Logger->debug(
+ "Eliminating $template_id from ${k}'s parents.");
+ delete $v->{$template_id};
+ }
+ next;
+ }
+ }
+
+ my $TicketObj ||= RT::Ticket->new( $self->CurrentUser );
+
+ my %args;
+ my %original_tags;
+ my @lines = ( split( /\n/, $content ) );
+ while ( defined( my $line = shift @lines ) ) {
+ if ( $line =~ /^(.*?):(?:\s+)(.*?)(?:\s*)$/ ) {
+ my $value = $2;
+ my $original_tag = $1;
+ my $tag = lc($original_tag);
+ $tag =~ s/-//g;
+ $tag =~ s/^(requestor|cc|admincc)s?$/$1/i;
+
+ $original_tags{$tag} = $original_tag;
+
+ if ( ref( $args{$tag} ) )
+ { #If it's an array, we want to push the value
+ push @{ $args{$tag} }, $value;
+ } elsif ( defined( $args{$tag} ) )
+ { #if we're about to get a second value, make it an array
+ $args{$tag} = [ $args{$tag}, $value ];
+ } else { #if there's nothing there, just set the value
+ $args{$tag} = $value;
+ }
+
+ if ( $tag =~ /^content$/i ) { #just build up the content
+ # convert it to an array
+ $args{$tag} = defined($value) ? [ $value . "\n" ] : [];
+ while ( defined( my $l = shift @lines ) ) {
+ last if ( $l =~ /^ENDOFCONTENT\s*$/ );
+ push @{ $args{'content'} }, $l . "\n";
+ }
+ } else {
+ # if it's not content, strip leading and trailing spaces
+ if ( $args{$tag} ) {
+ $args{$tag} =~ s/^\s+//g;
+ $args{$tag} =~ s/\s+$//g;
+ }
+ if (
+ ($tag =~ /^(requestor|cc|admincc)(group)?$/i
+ or grep {lc $_ eq $tag} keys %LINKTYPEMAP)
+ and $args{$tag} =~ /,/
+ ) {
+ $args{$tag} = [ split /,\s*/, $args{$tag} ];
+ }
+ }
+ }
+ }
+
+ foreach my $date (qw(due starts started resolved)) {
+ my $dateobj = RT::Date->new( $self->CurrentUser );
+ next unless $args{$date};
+ if ( $args{$date} =~ /^\d+$/ ) {
+ $dateobj->Set( Format => 'unix', Value => $args{$date} );
+ } else {
+ eval {
+ $dateobj->Set( Format => 'iso', Value => $args{$date} );
+ };
+ if ($@ or $dateobj->Unix <= 0) {
+ $dateobj->Set( Format => 'unknown', Value => $args{$date} );
+ }
+ }
+ $args{$date} = $dateobj->ISO;
+ }
+
+ foreach my $role (qw(requestor cc admincc)) {
+ next unless my $value = $args{ $role . 'group' };
+
+ my $group = RT::Group->new( $self->CurrentUser );
+ $group->LoadUserDefinedGroup( $value );
+ unless ( $group->id ) {
+ $RT::Logger->error("Couldn't load group '$value'");
+ next;
+ }
+
+ $args{ $role } = $args{ $role } ? [$args{ $role }] : []
+ unless ref $args{ $role };
+ push @{ $args{ $role } }, $group->PrincipalObj->id;
+ }
+
+ $args{'requestor'} ||= $self->TicketObj->Requestors->MemberEmailAddresses
+ if $self->TicketObj;
+
+ $args{'type'} ||= 'ticket';
+
+ my %ticketargs = (
+ Queue => $args{'queue'},
+ Subject => $args{'subject'},
+ Status => $args{'status'} || 'new',
+ Due => $args{'due'},
+ Starts => $args{'starts'},
+ Started => $args{'started'},
+ Resolved => $args{'resolved'},
+ Owner => $args{'owner'},
+ Requestor => $args{'requestor'},
+ Cc => $args{'cc'},
+ AdminCc => $args{'admincc'},
+ TimeWorked => $args{'timeworked'},
+ TimeEstimated => $args{'timeestimated'},
+ TimeLeft => $args{'timeleft'},
+ InitialPriority => $args{'initialpriority'} || 0,
+ FinalPriority => $args{'finalpriority'} || 0,
+ SquelchMailTo => $args{'squelchmailto'},
+ Type => $args{'type'},
+ $self->Rules
+ );
+
+ if ( $args{content} ) {
+ my $mimeobj = MIME::Entity->new();
+ $mimeobj->build(
+ Type => $args{'contenttype'} || 'text/plain',
+ Data => $args{'content'}
+ );
+ $ticketargs{MIMEObj} = $mimeobj;
+ $ticketargs{UpdateType} = $args{'updatetype'} || 'correspond';
+ }
+
+ foreach my $tag ( keys(%args) ) {
+ # if the tag was added later, skip it
+ my $orig_tag = $original_tags{$tag} or next;
+ if ( $orig_tag =~ /^customfield-?(\d+)$/i ) {
+ $ticketargs{ "CustomField-" . $1 } = $args{$tag};
+ } elsif ( $orig_tag =~ /^(?:customfield|cf)-?(.+)$/i ) {
+ my $cf = RT::CustomField->new( $self->CurrentUser );
+ $cf->LoadByName( Name => $1, Queue => $ticketargs{Queue} );
+ $cf->LoadByName( Name => $1, Queue => 0 ) unless $cf->id;
+ next unless $cf->id;
+ $ticketargs{ "CustomField-" . $cf->id } = $args{$tag};
+ } elsif ($orig_tag) {
+ my $cf = RT::CustomField->new( $self->CurrentUser );
+ $cf->LoadByName( Name => $orig_tag, Queue => $ticketargs{Queue} );
+ $cf->LoadByName( Name => $orig_tag, Queue => 0 ) unless $cf->id;
+ next unless $cf->id;
+ $ticketargs{ "CustomField-" . $cf->id } = $args{$tag};
+
+ }
+ }
+
+ $self->GetDeferred( \%args, $template_id, $links, $postponed );
+
+ return $TicketObj, \%ticketargs;
+}
+
+
+=head2 _ParseXSVTemplate
+
+Parses a tab or comma delimited template. Should only ever be called by
+L</Parse>.
+
+=cut
+
+sub _ParseXSVTemplate {
+ my $self = shift;
+ my %args = (@_);
+
+ use Regexp::Common qw(delimited);
+ my($first, $content) = split(/\r?\n/, $args{'Content'}, 2);
+
+ my $delimiter;
+ if ( $first =~ /\t/ ) {
+ $delimiter = "\t";
+ } else {
+ $delimiter = ',';
+ }
+ my @fields = split( /$delimiter/, $first );
+
+ my $delimiter_re = qr[$delimiter];
+ my $justquoted = qr[$RE{quoted}];
+
+ # Used to generate automatic template ids
+ my $autoid = 1;
+
+ LINE:
+ while ($content) {
+ $content =~ s/^(\s*\r?\n)+//;
+
+ # Keep track of Queue and Requestor, so we can provide defaults
+ my $queue;
+ my $requestor;
+
+ # The template for this line
+ my $template;
+
+ # What column we're on
+ my $i = 0;
+
+ # If the last iteration was the end of the line
+ my $EOL = 0;
+
+ # The template id
+ my $template_id;
+
+ COLUMN:
+ while (not $EOL and length $content and $content =~ s/^($justquoted|.*?)($delimiter_re|$)//smix) {
+ $EOL = not $2;
+
+ # Strip off quotes, if they exist
+ my $value = $1;
+ if ( $value =~ /^$RE{delimited}{-delim=>qq{\'\"}}$/ ) {
+ substr( $value, 0, 1 ) = "";
+ substr( $value, -1, 1 ) = "";
+ }
+
+ # What column is this?
+ my $field = $fields[$i++];
+ next COLUMN unless $field =~ /\S/;
+ $field =~ s/^\s//;
+ $field =~ s/\s$//;
+
+ if ( $field =~ /^id$/i ) {
+ # Special case if this is the ID column
+ if ( $value =~ /^\d+$/ ) {
+ $template_id = 'update-' . $value;
+ push @{ $self->{'update_tickets'} }, $template_id;
+ } elsif ( $value =~ /^#base-(\d+)$/ ) {
+ $template_id = 'base-' . $1;
+ push @{ $self->{'base_tickets'} }, $template_id;
+ } elsif ( $value =~ /\S/ ) {
+ $template_id = 'create-' . $value;
+ push @{ $self->{'create_tickets'} }, $template_id;
+ }
+ } else {
+ # Some translations
+ if ( $field =~ /^Body$/i
+ || $field =~ /^Data$/i
+ || $field =~ /^Message$/i )
+ {
+ $field = 'Content';
+ } elsif ( $field =~ /^Summary$/i ) {
+ $field = 'Subject';
+ } elsif ( $field =~ /^Queue$/i ) {
+ # Note that we found a queue
+ $queue = 1;
+ $value ||= $args{'Queue'};
+ } elsif ( $field =~ /^Requestors?$/i ) {
+ $field = 'Requestor'; # Remove plural
+ # Note that we found a requestor
+ $requestor = 1;
+ $value ||= $args{'Requestor'};
+ }
+
+ # Tack onto the end of the template
+ $template .= $field . ": ";
+ $template .= (defined $value ? $value : "");
+ $template .= "\n";
+ $template .= "ENDOFCONTENT\n"
+ if $field =~ /^Content$/i;
+ }
+ }
+
+ # Ignore blank lines
+ next unless $template;
+
+ # If we didn't find a queue of requestor, tack on the defaults
+ if ( !$queue && $args{'Queue'} ) {
+ $template .= "Queue: $args{'Queue'}\n";
+ }
+ if ( !$requestor && $args{'Requestor'} ) {
+ $template .= "Requestor: $args{'Requestor'}\n";
+ }
+
+ # If we never found an ID, come up with one
+ unless ($template_id) {
+ $autoid++ while exists $self->{'templates'}->{"create-auto-$autoid"};
+ $template_id = "create-auto-$autoid";
+ # Also, it's a ticket to create
+ push @{ $self->{'create_tickets'} }, $template_id;
+ }
+
+ # Save the template we generated
+ $self->{'templates'}->{$template_id} = $template;
+
+ }
+}
+
+sub GetDeferred {
+ my $self = shift;
+ my $args = shift;
+ my $id = shift;
+ my $links = shift;
+ my $postponed = shift;
+
+ # Deferred processing
+ push @$links,
+ (
+ $id,
+ { DependsOn => $args->{'dependson'},
+ DependedOnBy => $args->{'dependedonby'},
+ RefersTo => $args->{'refersto'},
+ ReferredToBy => $args->{'referredtoby'},
+ Children => $args->{'children'},
+ Parents => $args->{'parents'},
+ }
+ );
+
+ push @$postponed, (
+
+ # Status is postponed so we don't violate dependencies
+ $id, { Status => $args->{'status'}, }
+ );
+}
+
+sub GetUpdateTemplate {
+ my $self = shift;
+ my $t = shift;
+
+ my $string;
+ $string .= "Queue: " . $t->QueueObj->Name . "\n";
+ $string .= "Subject: " . $t->Subject . "\n";
+ $string .= "Status: " . $t->Status . "\n";
+ $string .= "UpdateType: correspond\n";
+ $string .= "Content: \n";
+ $string .= "ENDOFCONTENT\n";
+ $string .= "Due: " . $t->DueObj->AsString . "\n";
+ $string .= "Starts: " . $t->StartsObj->AsString . "\n";
+ $string .= "Started: " . $t->StartedObj->AsString . "\n";
+ $string .= "Resolved: " . $t->ResolvedObj->AsString . "\n";
+ $string .= "Owner: " . $t->OwnerObj->Name . "\n";
+ $string .= "Requestor: " . $t->RequestorAddresses . "\n";
+ $string .= "Cc: " . $t->CcAddresses . "\n";
+ $string .= "AdminCc: " . $t->AdminCcAddresses . "\n";
+ $string .= "TimeWorked: " . $t->TimeWorked . "\n";
+ $string .= "TimeEstimated: " . $t->TimeEstimated . "\n";
+ $string .= "TimeLeft: " . $t->TimeLeft . "\n";
+ $string .= "InitialPriority: " . $t->Priority . "\n";
+ $string .= "FinalPriority: " . $t->FinalPriority . "\n";
+
+ foreach my $type ( sort keys %LINKTYPEMAP ) {
+
+ # don't display duplicates
+ if ( $type eq "HasMember"
+ || $type eq "Members"
+ || $type eq "MemberOf" )
+ {
+ next;
+ }
+ $string .= "$type: ";
+
+ my $mode = $LINKTYPEMAP{$type}->{Mode};
+ my $method = $LINKTYPEMAP{$type}->{Type};
+
+ my $links = '';
+ while ( my $link = $t->$method->Next ) {
+ $links .= ", " if $links;
+
+ my $object = $mode . "Obj";
+ my $member = $link->$object;
+ $links .= $member->Id if $member;
+ }
+ $string .= $links;
+ $string .= "\n";
+ }
+
+ return $string;
+}
+
+sub GetBaseTemplate {
+ my $self = shift;
+ my $t = shift;
+
+ my $string;
+ $string .= "Queue: " . $t->Queue . "\n";
+ $string .= "Subject: " . $t->Subject . "\n";
+ $string .= "Status: " . $t->Status . "\n";
+ $string .= "Due: " . $t->DueObj->Unix . "\n";
+ $string .= "Starts: " . $t->StartsObj->Unix . "\n";
+ $string .= "Started: " . $t->StartedObj->Unix . "\n";
+ $string .= "Resolved: " . $t->ResolvedObj->Unix . "\n";
+ $string .= "Owner: " . $t->Owner . "\n";
+ $string .= "Requestor: " . $t->RequestorAddresses . "\n";
+ $string .= "Cc: " . $t->CcAddresses . "\n";
+ $string .= "AdminCc: " . $t->AdminCcAddresses . "\n";
+ $string .= "TimeWorked: " . $t->TimeWorked . "\n";
+ $string .= "TimeEstimated: " . $t->TimeEstimated . "\n";
+ $string .= "TimeLeft: " . $t->TimeLeft . "\n";
+ $string .= "InitialPriority: " . $t->Priority . "\n";
+ $string .= "FinalPriority: " . $t->FinalPriority . "\n";
+
+ return $string;
+}
+
+sub GetCreateTemplate {
+ my $self = shift;
+
+ my $string;
+
+ $string .= "Queue: General\n";
+ $string .= "Subject: \n";
+ $string .= "Status: new\n";
+ $string .= "Content: \n";
+ $string .= "ENDOFCONTENT\n";
+ $string .= "Due: \n";
+ $string .= "Starts: \n";
+ $string .= "Started: \n";
+ $string .= "Resolved: \n";
+ $string .= "Owner: \n";
+ $string .= "Requestor: \n";
+ $string .= "Cc: \n";
+ $string .= "AdminCc:\n";
+ $string .= "TimeWorked: \n";
+ $string .= "TimeEstimated: \n";
+ $string .= "TimeLeft: \n";
+ $string .= "InitialPriority: \n";
+ $string .= "FinalPriority: \n";
+
+ foreach my $type ( keys %LINKTYPEMAP ) {
+
+ # don't display duplicates
+ if ( $type eq "HasMember"
+ || $type eq 'Members'
+ || $type eq 'MemberOf' )
+ {
+ next;
+ }
+ $string .= "$type: \n";
+ }
+ return $string;
+}
+
+sub UpdateWatchers {
+ my $self = shift;
+ my $ticket = shift;
+ my $args = shift;
+
+ my @results;
+
+ foreach my $type (qw(Requestor Cc AdminCc)) {
+ my $method = $type . 'Addresses';
+ my $oldaddr = $ticket->$method;
+
+ # Skip unless we have a defined field
+ next unless defined $args->{$type};
+ my $newaddr = $args->{$type};
+
+ my @old = split( /,\s*/, $oldaddr );
+ my @new;
+ for (ref $newaddr ? @{$newaddr} : split( /,\s*/, $newaddr )) {
+ # Sometimes these are email addresses, sometimes they're
+ # users. Try to guess which is which, as we want to deal
+ # with email addresses if at all possible.
+ if (/^\S+@\S+$/) {
+ push @new, $_;
+ } else {
+ # It doesn't look like an email address. Try to load it.
+ my $user = RT::User->new($self->CurrentUser);
+ $user->Load($_);
+ if ($user->Id) {
+ push @new, $user->EmailAddress;
+ } else {
+ push @new, $_;
+ }
+ }
+ }
+
+ my %oldhash = map { $_ => 1 } @old;
+ my %newhash = map { $_ => 1 } @new;
+
+ my @add = grep( !defined $oldhash{$_}, @new );
+ my @delete = grep( !defined $newhash{$_}, @old );
+
+ foreach (@add) {
+ my ( $val, $msg ) = $ticket->AddWatcher(
+ Type => $type,
+ Email => $_
+ );
+
+ push @results,
+ $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg;
+ }
+
+ foreach (@delete) {
+ my ( $val, $msg ) = $ticket->DeleteWatcher(
+ Type => $type,
+ Email => $_
+ );
+ push @results,
+ $ticket->loc( "Ticket [_1]", $ticket->Id ) . ': ' . $msg;
+ }
+ }
+ return @results;
+}
+
+sub UpdateCustomFields {
+ my $self = shift;
+ my $ticket = shift;
+ my $args = shift;
+
+ my @results;
+ foreach my $arg (keys %{$args}) {
+ next unless $arg =~ /^CustomField-(\d+)$/;
+ my $cf = $1;
+
+ my $CustomFieldObj = RT::CustomField->new($self->CurrentUser);
+ $CustomFieldObj->SetContextObject( $ticket );
+ $CustomFieldObj->LoadById($cf);
+
+ my @values;
+ if ($CustomFieldObj->Type =~ /text/i) { # Both Text and Wikitext
+ @values = ($args->{$arg});
+ } else {
+ @values = split /\n/, $args->{$arg};
+ }
+
+ if ( ($CustomFieldObj->Type eq 'Freeform'
+ && ! $CustomFieldObj->SingleValue) ||
+ $CustomFieldObj->Type =~ /text/i) {
+ foreach my $val (@values) {
+ $val =~ s/\r//g;
+ }
+ }
+
+ foreach my $value (@values) {
+ next unless length($value);
+ my ( $val, $msg ) = $ticket->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push ( @results, $msg );
+ }
+ }
+ return @results;
+}
+
+sub PostProcess {
+ my $self = shift;
+ my $links = shift;
+ my $postponed = shift;
+
+ # postprocessing: add links
+
+ while ( my $template_id = shift(@$links) ) {
+ my $ticket = $T::Tickets{$template_id};
+ $RT::Logger->debug( "Handling links for " . $ticket->Id );
+ my %args = %{ shift(@$links) };
+
+ foreach my $type ( keys %LINKTYPEMAP ) {
+ next unless ( defined $args{$type} );
+ foreach my $link (
+ ref( $args{$type} ) ? @{ $args{$type} } : ( $args{$type} ) )
+ {
+ next unless $link;
+
+ if ( $link =~ /^TOP$/i ) {
+ $RT::Logger->debug( "Building $type link for $link: "
+ . $T::Tickets{TOP}->Id );
+ $link = $T::Tickets{TOP}->Id;
+
+ } elsif ( $link !~ m/^\d+$/ ) {
+ my $key = "create-$link";
+ if ( !exists $T::Tickets{$key} ) {
+ $RT::Logger->debug(
+ "Skipping $type link for $key (non-existent)");
+ next;
+ }
+ $RT::Logger->debug( "Building $type link for $link: "
+ . $T::Tickets{$key}->Id );
+ $link = $T::Tickets{$key}->Id;
+ } else {
+ $RT::Logger->debug("Building $type link for $link");
+ }
+
+ my ( $wval, $wmsg ) = $ticket->AddLink(
+ Type => $LINKTYPEMAP{$type}->{'Type'},
+ $LINKTYPEMAP{$type}->{'Mode'} => $link,
+ Silent => 1
+ );
+
+ $RT::Logger->warning("AddLink thru $link failed: $wmsg")
+ unless $wval;
+
+ # push @non_fatal_errors, $wmsg unless ($wval);
+ }
+
+ }
+ }
+
+ # postponed actions -- Status only, currently
+ while ( my $template_id = shift(@$postponed) ) {
+ my $ticket = $T::Tickets{$template_id};
+ $RT::Logger->debug( "Handling postponed actions for " . $ticket->id );
+ my %args = %{ shift(@$postponed) };
+ $ticket->SetStatus( $args{Status} ) if defined $args{Status};
+ }
+
+}
+
+sub Options {
+ my $self = shift;
+ my $queues = RT::Queues->new($self->CurrentUser);
+ $queues->UnLimit;
+ my @names;
+ while (my $queue = $queues->Next) {
+ push @names, $queue->Id, $queue->Name;
+ }
+ return (
+ {
+ 'name' => 'Queue',
+ 'label' => 'In queue',
+ 'type' => 'select',
+ 'options' => \@names
+ }
+ )
+}
+
+RT::Base->_ImportOverlays();
+
+1;
+
sub AddressesFromHeader {
my $self = shift;
my $field = shift;
- my $header = $self->TemplateObj->MIMEObj->head->get($field);
+ my $header = Encode::decode("UTF-8",$self->TemplateObj->MIMEObj->head->get($field));
my @addresses = Email::Address->parse($header);
return (@addresses);
# ability to pass @_ to a 'post' routine.
my ( $self, $MIMEObj ) = @_;
- my $msgid = $MIMEObj->head->get('Message-ID');
+ my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') );
chomp $msgid;
$self->ScripActionObj->{_Message_ID}++;
my $success = $msgid . " sent ";
foreach (@EMAIL_RECIPIENT_HEADERS) {
- my $recipients = $MIMEObj->head->get($_);
+ my $recipients = Encode::decode( "UTF-8", $MIMEObj->head->get($_) );
$success .= " $_: " . $recipients if $recipients;
}
$type = 'EmailRecord';
}
- my $msgid = $MIMEObj->head->get('Message-ID');
+ my $msgid = Encode::decode( "UTF-8", $MIMEObj->head->get('Message-ID') );
chomp $msgid;
my ( $id, $msg ) = $transaction->Create(
# Have to get the list of addresses directly from the MIME header
# at this point.
- $RT::Logger->debug( $self->TemplateObj->MIMEObj->head->as_string );
+ $RT::Logger->debug( Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->as_string ) );
foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
next unless $rcpt;
my $user_obj = RT::User->new(RT->SystemUser);
# If there are no recipients, don't try to send the message.
# If the transaction has content and has the header RT-Squelch-Replies-To
- my $msgid = $self->TemplateObj->MIMEObj->head->get('Message-Id');
+ my $msgid = Encode::decode( "UTF-8", $self->TemplateObj->MIMEObj->head->get('Message-Id') );
if ( my $attachment = $self->TransactionObj->Attachments->First ) {
if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
=head2 SetHeader FIELD, VALUE
-Set the FIELD of the current MIME object into VALUE.
+Set the FIELD of the current MIME object into VALUE, which should be in
+characters, not bytes. Returns the new header, in bytes.
=cut
chomp $field;
my $head = $self->TemplateObj->MIMEObj->head;
$head->fold_length( $field, 10000 );
- $head->replace( $field, $val );
+ $head->replace( $field, Encode::encode( "UTF-8", $val ) );
return $head->get($field);
}
$subject =~ s/(\r\n|\n|\s)/ /g;
- $self->SetHeader( 'Subject', Encode::encode_utf8( $subject ) );
+ $self->SetHeader( 'Subject', $subject );
}
my $head = $self->TemplateObj->MIMEObj->head;
$self->SetHeader(
Subject =>
- Encode::encode_utf8(
- RT::Interface::Email::AddSubjectTag(
- Encode::decode_utf8( $head->get('Subject') ),
- $self->TicketObj,
- ),
+ RT::Interface::Email::AddSubjectTag(
+ Encode::decode( "UTF-8", $head->get('Subject') ),
+ $self->TicketObj,
),
);
}
=head2 SetHeaderAsEncoding($field_name, $charset_encoding)
-This routine converts the field into specified charset encoding.
+This routine converts the field into specified charset encoding, then
+applies the MIME-Header transfer encoding.
=cut
my $head = $self->TemplateObj->MIMEObj->head;
if ( lc($field) eq 'from' and RT->Config->Get('SMTPFrom') ) {
- $head->replace( $field, RT->Config->Get('SMTPFrom') );
+ $head->replace( $field, Encode::encode( "UTF-8", RT->Config->Get('SMTPFrom') ) );
return;
}
- my $value = $head->get( $field );
- $value = $self->MIMEEncodeString( $value, $enc );
+ my $value = Encode::decode("UTF-8", $head->get( $field ));
+ $value = $self->MIMEEncodeString( $value, $enc ); # Returns bytes
$head->replace( $field, $value );
}
Takes a perl string and optional encoding pass it over
L<RT::Interface::Email/EncodeToMIME>.
-Basicly encode a string using B encoding according to RFC2047.
+Basicly encode a string using B encoding according to RFC2047, returning
+bytes.
=cut
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+# Portions Copyright 2000 Tobias Brox <tobix@cpan.org>
+
+package RT::Action::SendEmail;
+
+use strict;
+use warnings;
+
+use base qw(RT::Action);
+
+use RT::EmailParser;
+use RT::Interface::Email;
+use Email::Address;
+our @EMAIL_RECIPIENT_HEADERS = qw(To Cc Bcc);
+
+
+=head1 NAME
+
+RT::Action::SendEmail - An Action which users can use to send mail
+or can subclassed for more specialized mail sending behavior.
+RT::Action::AutoReply is a good example subclass.
+
+=head1 SYNOPSIS
+
+ use base 'RT::Action::SendEmail';
+
+=head1 DESCRIPTION
+
+Basically, you create another module RT::Action::YourAction which ISA
+RT::Action::SendEmail.
+
+=head1 METHODS
+
+=head2 CleanSlate
+
+Cleans class-wide options, like L</AttachTickets>.
+
+=cut
+
+sub CleanSlate {
+ my $self = shift;
+ $self->AttachTickets(undef);
+}
+
+=head2 Commit
+
+Sends the prepared message and writes outgoing record into DB if the feature is
+activated in the config.
+
+=cut
+
+sub Commit {
+ my $self = shift;
+
+ return abs $self->SendMessage( $self->TemplateObj->MIMEObj )
+ unless RT->Config->Get('RecordOutgoingEmail');
+
+ $self->DeferDigestRecipients();
+ my $message = $self->TemplateObj->MIMEObj;
+
+ my $orig_message;
+ $orig_message = $message->dup if RT::Interface::Email::WillSignEncrypt(
+ Attachment => $self->TransactionObj->Attachments->First,
+ Ticket => $self->TicketObj,
+ );
+
+ my ($ret) = $self->SendMessage($message);
+ return abs( $ret ) if $ret <= 0;
+
+ if ($orig_message) {
+ $message->attach(
+ Type => 'application/x-rt-original-message',
+ Disposition => 'inline',
+ Data => $orig_message->as_string,
+ );
+ }
+ $self->RecordOutgoingMailTransaction($message);
+ $self->RecordDeferredRecipients();
+ return 1;
+}
+
+=head2 Prepare
+
+Builds an outgoing email we're going to send using scrip's template.
+
+=cut
+
+sub Prepare {
+ my $self = shift;
+
+ my ( $result, $message ) = $self->TemplateObj->Parse(
+ Argument => $self->Argument,
+ TicketObj => $self->TicketObj,
+ TransactionObj => $self->TransactionObj
+ );
+ if ( !$result ) {
+ return (undef);
+ }
+
+ my $MIMEObj = $self->TemplateObj->MIMEObj;
+
+ # Header
+ $self->SetRTSpecialHeaders();
+
+ my %seen;
+ foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
+ @{ $self->{$type} }
+ = grep defined && length && !$seen{ lc $_ }++,
+ @{ $self->{$type} };
+ }
+
+ $self->RemoveInappropriateRecipients();
+
+ # Go add all the Tos, Ccs and Bccs that we need to to the message to
+ # make it happy, but only if we actually have values in those arrays.
+
+# TODO: We should be pulling the recipients out of the template and shove them into To, Cc and Bcc
+
+ for my $header (@EMAIL_RECIPIENT_HEADERS) {
+
+ $self->SetHeader( $header, join( ', ', @{ $self->{$header} } ) )
+ if (!$MIMEObj->head->get($header)
+ && $self->{$header}
+ && @{ $self->{$header} } );
+ }
+ # PseudoTo (fake to headers) shouldn't get matched for message recipients.
+ # If we don't have any 'To' header (but do have other recipients), drop in
+ # the pseudo-to header.
+ $self->SetHeader( 'To', join( ', ', @{ $self->{'PseudoTo'} } ) )
+ if $self->{'PseudoTo'}
+ && @{ $self->{'PseudoTo'} }
+ && !$MIMEObj->head->get('To')
+ && ( $MIMEObj->head->get('Cc') or $MIMEObj->head->get('Bcc') );
+
+ # We should never have to set the MIME-Version header
+ $self->SetHeader( 'MIME-Version', '1.0' );
+
+ # fsck.com #5959: Since RT sends 8bit mail, we should say so.
+ $self->SetHeader( 'Content-Transfer-Encoding', '8bit' );
+
+ # For security reasons, we only send out textual mails.
+ foreach my $part ( grep !$_->is_multipart, $MIMEObj->parts_DFS ) {
+ my $type = $part->mime_type || 'text/plain';
+ $type = 'text/plain' unless RT::I18N::IsTextualContentType($type);
+ $part->head->mime_attr( "Content-Type" => $type );
+ # utf-8 here is for _FindOrGuessCharset in I18N.pm
+ # it's not the final charset/encoding sent
+ $part->head->mime_attr( "Content-Type.charset" => 'utf-8' );
+ }
+
+ RT::I18N::SetMIMEEntityToEncoding( $MIMEObj,
+ RT->Config->Get('EmailOutputEncoding'),
+ 'mime_words_ok', );
+
+ # Build up a MIME::Entity that looks like the original message.
+ $self->AddAttachments if ( $MIMEObj->head->get('RT-Attach-Message')
+ && ( $MIMEObj->head->get('RT-Attach-Message') !~ /^(n|no|0|off|false)$/i ) );
+
+ $self->AddTickets;
+
+ my $attachment = $self->TransactionObj->Attachments->First;
+ if ($attachment
+ && !(
+ $attachment->GetHeader('X-RT-Encrypt')
+ || $self->TicketObj->QueueObj->Encrypt
+ )
+ )
+ {
+ $attachment->SetHeader( 'X-RT-Encrypt' => 1 )
+ if ( $attachment->GetHeader("X-RT-Incoming-Encryption") || '' ) eq
+ 'Success';
+ }
+
+ return $result;
+}
+
+=head2 To
+
+Returns an array of L<Email::Address> objects containing all the To: recipients for this notification
+
+=cut
+
+sub To {
+ my $self = shift;
+ return ( $self->AddressesFromHeader('To') );
+}
+
+=head2 Cc
+
+Returns an array of L<Email::Address> objects containing all the Cc: recipients for this notification
+
+=cut
+
+sub Cc {
+ my $self = shift;
+ return ( $self->AddressesFromHeader('Cc') );
+}
+
+=head2 Bcc
+
+Returns an array of L<Email::Address> objects containing all the Bcc: recipients for this notification
+
+=cut
+
+sub Bcc {
+ my $self = shift;
+ return ( $self->AddressesFromHeader('Bcc') );
+
+}
+
+sub AddressesFromHeader {
+ my $self = shift;
+ my $field = shift;
+ my $header = $self->TemplateObj->MIMEObj->head->get($field);
+ my @addresses = Email::Address->parse($header);
+
+ return (@addresses);
+}
+
+=head2 SendMessage MIMEObj
+
+sends the message using RT's preferred API.
+TODO: Break this out to a separate module
+
+=cut
+
+sub SendMessage {
+
+ # DO NOT SHIFT @_ in this subroutine. It breaks Hook::LexWrap's
+ # ability to pass @_ to a 'post' routine.
+ my ( $self, $MIMEObj ) = @_;
+
+ my $msgid = $MIMEObj->head->get('Message-ID');
+ chomp $msgid;
+
+ $self->ScripActionObj->{_Message_ID}++;
+
+ $RT::Logger->info( $msgid . " #"
+ . $self->TicketObj->id . "/"
+ . $self->TransactionObj->id
+ . " - Scrip "
+ . ($self->ScripObj->id || '#rule'). " "
+ . ( $self->ScripObj->Description || '' ) );
+
+ my $status = RT::Interface::Email::SendEmail(
+ Entity => $MIMEObj,
+ Ticket => $self->TicketObj,
+ Transaction => $self->TransactionObj,
+ );
+
+
+ return $status unless ($status > 0 || exists $self->{'Deferred'});
+
+ my $success = $msgid . " sent ";
+ foreach (@EMAIL_RECIPIENT_HEADERS) {
+ my $recipients = $MIMEObj->head->get($_);
+ $success .= " $_: " . $recipients if $recipients;
+ }
+
+ if( exists $self->{'Deferred'} ) {
+ for (qw(daily weekly susp)) {
+ $success .= "\nBatched email $_ for: ". join(", ", keys %{ $self->{'Deferred'}{ $_ } } )
+ if exists $self->{'Deferred'}{ $_ };
+ }
+ }
+
+ $success =~ s/\n//g;
+
+ $RT::Logger->info($success);
+
+ return (1);
+}
+
+=head2 AddAttachments
+
+Takes any attachments to this transaction and attaches them to the message
+we're building.
+
+=cut
+
+sub AddAttachments {
+ my $self = shift;
+
+ my $MIMEObj = $self->TemplateObj->MIMEObj;
+
+ $MIMEObj->head->delete('RT-Attach-Message');
+
+ my $attachments = RT::Attachments->new( RT->SystemUser );
+ $attachments->Limit(
+ FIELD => 'TransactionId',
+ VALUE => $self->TransactionObj->Id
+ );
+
+ # Don't attach anything blank
+ $attachments->LimitNotEmpty;
+ $attachments->OrderBy( FIELD => 'id' );
+
+ # We want to make sure that we don't include the attachment that's
+ # being used as the "Content" of this message" unless that attachment's
+ # content type is not like text/...
+ my $transaction_content_obj = $self->TransactionObj->ContentObj;
+
+ if ( $transaction_content_obj
+ && $transaction_content_obj->ContentType =~ m{text/}i )
+ {
+ # If this was part of a multipart/alternative, skip all of the kids
+ my $parent = $transaction_content_obj->ParentObj;
+ if ($parent and $parent->Id and $parent->ContentType eq "multipart/alternative") {
+ $attachments->Limit(
+ ENTRYAGGREGATOR => 'AND',
+ FIELD => 'parent',
+ OPERATOR => '!=',
+ VALUE => $parent->Id,
+ );
+ } else {
+ $attachments->Limit(
+ ENTRYAGGREGATOR => 'AND',
+ FIELD => 'id',
+ OPERATOR => '!=',
+ VALUE => $transaction_content_obj->Id,
+ );
+ }
+ }
+
+ # attach any of this transaction's attachments
+ my $seen_attachment = 0;
+ while ( my $attach = $attachments->Next ) {
+ if ( !$seen_attachment ) {
+ $MIMEObj->make_multipart( 'mixed', Force => 1 );
+ $seen_attachment = 1;
+ }
+ $self->AddAttachment($attach);
+ }
+}
+
+=head2 AddAttachment $attachment
+
+Takes one attachment object of L<RT::Attachment> class and attaches it to the message
+we're building.
+
+=cut
+
+sub AddAttachment {
+ my $self = shift;
+ my $attach = shift;
+ my $MIMEObj = shift || $self->TemplateObj->MIMEObj;
+
+ # $attach->TransactionObj may not always be $self->TransactionObj
+ return unless $attach->Id
+ and $attach->TransactionObj->CurrentUserCanSee;
+
+ # ->attach expects just the disposition type; extract it if we have the header
+ # or default to "attachment"
+ my $disp = ($attach->GetHeader('Content-Disposition') || '')
+ =~ /^\s*(inline|attachment)/i ? $1 : "attachment";
+
+ $MIMEObj->attach(
+ Type => $attach->ContentType,
+ Charset => $attach->OriginalEncoding,
+ Data => $attach->OriginalContent,
+ Disposition => $disp,
+ Filename => $self->MIMEEncodeString( $attach->Filename ),
+ 'RT-Attachment:' => $self->TicketObj->Id . "/"
+ . $self->TransactionObj->Id . "/"
+ . $attach->id,
+ Encoding => '-SUGGEST',
+ );
+}
+
+=head2 AttachTickets [@IDs]
+
+Returns or set list of ticket's IDs that should be attached to an outgoing message.
+
+B<Note> this method works as a class method and setup things global, so you have to
+clean list by passing undef as argument.
+
+=cut
+
+{
+ my $list = [];
+
+ sub AttachTickets {
+ my $self = shift;
+ $list = [ grep defined, @_ ] if @_;
+ return @$list;
+ }
+}
+
+=head2 AddTickets
+
+Attaches tickets to the current message, list of tickets' ids get from
+L</AttachTickets> method.
+
+=cut
+
+sub AddTickets {
+ my $self = shift;
+ $self->AddTicket($_) foreach $self->AttachTickets;
+ return;
+}
+
+=head2 AddTicket $ID
+
+Attaches a ticket with ID to the message.
+
+Each ticket is attached as multipart entity and all its messages and attachments
+are attached as sub entities in order of creation, but only if transaction type
+is Create or Correspond.
+
+=cut
+
+sub AddTicket {
+ my $self = shift;
+ my $tid = shift;
+
+ my $attachs = RT::Attachments->new( $self->TransactionObj->CreatorObj );
+ my $txn_alias = $attachs->TransactionAlias;
+ $attachs->Limit( ALIAS => $txn_alias, FIELD => 'Type', VALUE => 'Create' );
+ $attachs->Limit(
+ ALIAS => $txn_alias,
+ FIELD => 'Type',
+ VALUE => 'Correspond'
+ );
+ $attachs->LimitByTicket($tid);
+ $attachs->LimitNotEmpty;
+ $attachs->OrderBy( FIELD => 'Created' );
+
+ my $ticket_mime = MIME::Entity->build(
+ Type => 'multipart/mixed',
+ Top => 0,
+ Description => "ticket #$tid",
+ );
+ while ( my $attachment = $attachs->Next ) {
+ $self->AddAttachment( $attachment, $ticket_mime );
+ }
+ if ( $ticket_mime->parts ) {
+ my $email_mime = $self->TemplateObj->MIMEObj;
+ $email_mime->make_multipart;
+ $email_mime->add_part($ticket_mime);
+ }
+ return;
+}
+
+=head2 RecordOutgoingMailTransaction MIMEObj
+
+Record a transaction in RT with this outgoing message for future record-keeping purposes
+
+=cut
+
+sub RecordOutgoingMailTransaction {
+ my $self = shift;
+ my $MIMEObj = shift;
+
+ my @parts = $MIMEObj->parts;
+ my @attachments;
+ my @keep;
+ foreach my $part (@parts) {
+ my $attach = $part->head->get('RT-Attachment');
+ if ($attach) {
+ $RT::Logger->debug(
+ "We found an attachment. we want to not record it.");
+ push @attachments, $attach;
+ } else {
+ $RT::Logger->debug("We found a part. we want to record it.");
+ push @keep, $part;
+ }
+ }
+ $MIMEObj->parts( \@keep );
+ foreach my $attachment (@attachments) {
+ $MIMEObj->head->add( 'RT-Attachment', $attachment );
+ }
+
+ RT::I18N::SetMIMEEntityToEncoding( $MIMEObj, 'utf-8', 'mime_words_ok' );
+
+ my $transaction
+ = RT::Transaction->new( $self->TransactionObj->CurrentUser );
+
+# XXX: TODO -> Record attachments as references to things in the attachments table, maybe.
+
+ my $type;
+ if ( $self->TransactionObj->Type eq 'Comment' ) {
+ $type = 'CommentEmailRecord';
+ } else {
+ $type = 'EmailRecord';
+ }
+
+ my $msgid = $MIMEObj->head->get('Message-ID');
+ chomp $msgid;
+
+ my ( $id, $msg ) = $transaction->Create(
+ Ticket => $self->TicketObj->Id,
+ Type => $type,
+ Data => $msgid,
+ MIMEObj => $MIMEObj,
+ ActivateScrips => 0
+ );
+
+ if ($id) {
+ $self->{'OutgoingMailTransaction'} = $id;
+ } else {
+ $RT::Logger->warning(
+ "Could not record outgoing message transaction: $msg");
+ }
+ return $id;
+}
+
+=head2 SetRTSpecialHeaders
+
+This routine adds all the random headers that RT wants in a mail message
+that don't matter much to anybody else.
+
+=cut
+
+sub SetRTSpecialHeaders {
+ my $self = shift;
+
+ $self->SetSubject();
+ $self->SetSubjectToken();
+ $self->SetHeaderAsEncoding( 'Subject',
+ RT->Config->Get('EmailOutputEncoding') )
+ if ( RT->Config->Get('EmailOutputEncoding') );
+ $self->SetReturnAddress();
+ $self->SetReferencesHeaders();
+
+ unless ( $self->TemplateObj->MIMEObj->head->get('Message-ID') ) {
+
+ # Get Message-ID for this txn
+ my $msgid = "";
+ if ( my $msg = $self->TransactionObj->Message->First ) {
+ $msgid = $msg->GetHeader("RT-Message-ID")
+ || $msg->GetHeader("Message-ID");
+ }
+
+ # If there is one, and we can parse it, then base our Message-ID on it
+ if ( $msgid
+ and $msgid
+ =~ s/<(rt-.*?-\d+-\d+)\.(\d+)-\d+-\d+\@\QRT->Config->Get('Organization')\E>$/
+ "<$1." . $self->TicketObj->id
+ . "-" . $self->ScripObj->id
+ . "-" . $self->ScripActionObj->{_Message_ID}
+ . "@" . RT->Config->Get('Organization') . ">"/eg
+ and $2 == $self->TicketObj->id
+ )
+ {
+ $self->SetHeader( "Message-ID" => $msgid );
+ } else {
+ $self->SetHeader(
+ 'Message-ID' => RT::Interface::Email::GenMessageId(
+ Ticket => $self->TicketObj,
+ Scrip => $self->ScripObj,
+ ScripAction => $self->ScripActionObj
+ ),
+ );
+ }
+ }
+
+ if (my $precedence = RT->Config->Get('DefaultMailPrecedence')
+ and !$self->TemplateObj->MIMEObj->head->get("Precedence")
+ ) {
+ $self->SetHeader( 'Precedence', $precedence );
+ }
+
+ $self->SetHeader( 'X-RT-Loop-Prevention', RT->Config->Get('rtname') );
+ $self->SetHeader( 'RT-Ticket',
+ RT->Config->Get('rtname') . " #" . $self->TicketObj->id() );
+ $self->SetHeader( 'Managed-by',
+ "RT $RT::VERSION (http://www.bestpractical.com/rt/)" );
+
+# XXX, TODO: use /ShowUser/ShowUserEntry(or something like that) when it would be
+# refactored into user's method.
+ if ( my $email = $self->TransactionObj->CreatorObj->EmailAddress
+ and RT->Config->Get('UseOriginatorHeader')
+ ) {
+ $self->SetHeader( 'RT-Originator', $email );
+ }
+
+}
+
+
+sub DeferDigestRecipients {
+ my $self = shift;
+ $RT::Logger->debug( "Calling SetRecipientDigests for transaction " . $self->TransactionObj . ", id " . $self->TransactionObj->id );
+
+ # The digest attribute will be an array of notifications that need to
+ # be sent for this transaction. The array will have the following
+ # format for its objects.
+ # $digest_hash -> {daily|weekly|susp} -> address -> {To|Cc|Bcc}
+ # -> sent -> {true|false}
+ # The "sent" flag will be used by the cron job to indicate that it has
+ # run on this transaction.
+ # In a perfect world we might move this hash construction to the
+ # extension module itself.
+ my $digest_hash = {};
+
+ foreach my $mailfield (@EMAIL_RECIPIENT_HEADERS) {
+ # If we have a "PseudoTo", the "To" contains it, so we don't need to access it
+ next if ( ( $self->{'PseudoTo'} && @{ $self->{'PseudoTo'} } ) && ( $mailfield eq 'To' ) );
+ $RT::Logger->debug( "Working on mailfield $mailfield; recipients are " . join( ',', @{ $self->{$mailfield} } ) );
+
+ # Store the 'daily digest' folk in an array.
+ my ( @send_now, @daily_digest, @weekly_digest, @suspended );
+
+ # Have to get the list of addresses directly from the MIME header
+ # at this point.
+ $RT::Logger->debug( $self->TemplateObj->MIMEObj->head->as_string );
+ foreach my $rcpt ( map { $_->address } $self->AddressesFromHeader($mailfield) ) {
+ next unless $rcpt;
+ my $user_obj = RT::User->new(RT->SystemUser);
+ $user_obj->LoadByEmail($rcpt);
+ if ( ! $user_obj->id ) {
+ # If there's an email address in here without an associated
+ # RT user, pass it on through.
+ $RT::Logger->debug( "User $rcpt is not associated with an RT user object. Send mail.");
+ push( @send_now, $rcpt );
+ next;
+ }
+
+ my $mailpref = RT->Config->Get( 'EmailFrequency', $user_obj ) || '';
+ $RT::Logger->debug( "Got user mail preference '$mailpref' for user $rcpt");
+
+ if ( $mailpref =~ /daily/i ) { push( @daily_digest, $rcpt ) }
+ elsif ( $mailpref =~ /weekly/i ) { push( @weekly_digest, $rcpt ) }
+ elsif ( $mailpref =~ /suspend/i ) { push( @suspended, $rcpt ) }
+ else { push( @send_now, $rcpt ) }
+ }
+
+ # Reset the relevant mail field.
+ $RT::Logger->debug( "Removing deferred recipients from $mailfield: line");
+ if (@send_now) {
+ $self->SetHeader( $mailfield, join( ', ', @send_now ) );
+ } else { # No recipients! Remove the header.
+ $self->TemplateObj->MIMEObj->head->delete($mailfield);
+ }
+
+ # Push the deferred addresses into the appropriate field in
+ # our attribute hash, with the appropriate mail header.
+ $RT::Logger->debug(
+ "Setting deferred recipients for attribute creation");
+ $digest_hash->{'daily'}->{$_} = {'header' => $mailfield , _sent => 0} for (@daily_digest);
+ $digest_hash->{'weekly'}->{$_} ={'header' => $mailfield, _sent => 0} for (@weekly_digest);
+ $digest_hash->{'susp'}->{$_} = {'header' => $mailfield, _sent =>0 } for (@suspended);
+ }
+
+ if ( scalar keys %$digest_hash ) {
+
+ # Save the hash so that we can add it as an attribute to the
+ # outgoing email transaction.
+ $self->{'Deferred'} = $digest_hash;
+ } else {
+ $RT::Logger->debug( "No recipients found for deferred delivery on "
+ . "transaction #"
+ . $self->TransactionObj->id );
+ }
+}
+
+
+
+sub RecordDeferredRecipients {
+ my $self = shift;
+ return unless exists $self->{'Deferred'};
+
+ my $txn_id = $self->{'OutgoingMailTransaction'};
+ return unless $txn_id;
+
+ my $txn_obj = RT::Transaction->new( $self->CurrentUser );
+ $txn_obj->Load( $txn_id );
+ my( $ret, $msg ) = $txn_obj->AddAttribute(
+ Name => 'DeferredRecipients',
+ Content => $self->{'Deferred'}
+ );
+ $RT::Logger->warning( "Unable to add deferred recipients to outgoing transaction: $msg" )
+ unless $ret;
+
+ return ($ret,$msg);
+}
+
+=head2 SquelchMailTo
+
+Returns list of the addresses to squelch on this transaction.
+
+=cut
+
+sub SquelchMailTo {
+ my $self = shift;
+ return map $_->Content, $self->TransactionObj->SquelchMailTo;
+}
+
+=head2 RemoveInappropriateRecipients
+
+Remove addresses that are RT addresses or that are on this transaction's blacklist
+
+=cut
+
+sub RemoveInappropriateRecipients {
+ my $self = shift;
+
+ my @blacklist = ();
+
+ # If there are no recipients, don't try to send the message.
+ # If the transaction has content and has the header RT-Squelch-Replies-To
+
+ my $msgid = $self->TemplateObj->MIMEObj->head->get('Message-Id');
+ if ( my $attachment = $self->TransactionObj->Attachments->First ) {
+
+ if ( $attachment->GetHeader('RT-DetectedAutoGenerated') ) {
+
+ # What do we want to do with this? It's probably (?) a bounce
+ # caused by one of the watcher addresses being broken.
+ # Default ("true") is to redistribute, for historical reasons.
+
+ if ( !RT->Config->Get('RedistributeAutoGeneratedMessages') ) {
+
+ # Don't send to any watchers.
+ @{ $self->{$_} } = () for (@EMAIL_RECIPIENT_HEADERS);
+ $RT::Logger->info( $msgid
+ . " The incoming message was autogenerated. "
+ . "Not redistributing this message based on site configuration."
+ );
+ } elsif ( RT->Config->Get('RedistributeAutoGeneratedMessages') eq
+ 'privileged' )
+ {
+
+ # Only send to "privileged" watchers.
+ foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
+ foreach my $addr ( @{ $self->{$type} } ) {
+ my $user = RT::User->new(RT->SystemUser);
+ $user->LoadByEmail($addr);
+ push @blacklist, $addr unless $user->id && $user->Privileged;
+ }
+ }
+ $RT::Logger->info( $msgid
+ . " The incoming message was autogenerated. "
+ . "Not redistributing this message to unprivileged users based on site configuration."
+ );
+ }
+ }
+
+ if ( my $squelch = $attachment->GetHeader('RT-Squelch-Replies-To') ) {
+ push @blacklist, split( /,/, $squelch );
+ }
+ }
+
+ # Let's grab the SquelchMailTo attributes and push those entries into the @blacklisted
+ push @blacklist, map $_->Content, $self->TicketObj->SquelchMailTo, $self->TransactionObj->SquelchMailTo;
+
+ # Cycle through the people we're sending to and pull out anyone on the
+ # system blacklist
+
+ # Trim leading and trailing spaces.
+ @blacklist = map { RT::User->CanonicalizeEmailAddress( $_->address ) }
+ Email::Address->parse( join ', ', grep defined, @blacklist );
+
+ foreach my $type (@EMAIL_RECIPIENT_HEADERS) {
+ my @addrs;
+ foreach my $addr ( @{ $self->{$type} } ) {
+
+ # Weed out any RT addresses. We really don't want to talk to ourselves!
+ # If we get a reply back, that means it's not an RT address
+ if ( !RT::EmailParser->CullRTAddresses($addr) ) {
+ $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" );
+ next;
+ }
+ if ( grep $addr eq $_, @blacklist ) {
+ $RT::Logger->info( $msgid . "$addr was blacklisted for outbound mail on this transaction. Skipping");
+ next;
+ }
+ push @addrs, $addr;
+ }
+ foreach my $addr ( @{ $self->{'NoSquelch'}{$type} || [] } ) {
+ # never send email to itself
+ if ( !RT::EmailParser->CullRTAddresses($addr) ) {
+ $RT::Logger->info( $msgid . "$addr appears to point to this RT instance. Skipping" );
+ next;
+ }
+ push @addrs, $addr;
+ }
+ @{ $self->{$type} } = @addrs;
+ }
+}
+
+=head2 SetReturnAddress is_comment => BOOLEAN
+
+Calculate and set From and Reply-To headers based on the is_comment flag.
+
+=cut
+
+sub SetReturnAddress {
+
+ my $self = shift;
+ my %args = (
+ is_comment => 0,
+ friendly_name => undef,
+ @_
+ );
+
+ # From and Reply-To
+ # $args{is_comment} should be set if the comment address is to be used.
+ my $replyto;
+
+ if ( $args{'is_comment'} ) {
+ $replyto = $self->TicketObj->QueueObj->CommentAddress
+ || RT->Config->Get('CommentAddress');
+ } else {
+ $replyto = $self->TicketObj->QueueObj->CorrespondAddress
+ || RT->Config->Get('CorrespondAddress');
+ }
+
+ unless ( $self->TemplateObj->MIMEObj->head->get('From') ) {
+ $self->SetFrom( %args, From => $replyto );
+ }
+
+ unless ( $self->TemplateObj->MIMEObj->head->get('Reply-To') ) {
+ $self->SetHeader( 'Reply-To', "$replyto" );
+ }
+
+}
+
+=head2 SetFrom ( From => emailaddress )
+
+Set the From: address for outgoing email
+
+=cut
+
+sub SetFrom {
+ my $self = shift;
+ my %args = @_;
+
+ my $from = $args{From};
+
+ if ( RT->Config->Get('UseFriendlyFromLine') ) {
+ my $friendly_name = $self->GetFriendlyName(%args);
+ $from =
+ sprintf(
+ RT->Config->Get('FriendlyFromLineFormat'),
+ $self->MIMEEncodeString(
+ $friendly_name, RT->Config->Get('EmailOutputEncoding')
+ ),
+ $args{From}
+ );
+ }
+
+ $self->SetHeader( 'From', $from );
+
+ #also set Sender:, otherwise MTAs add a nonsensical value like rt@machine,
+ #and then Outlook prepends "rt@machine on behalf of" to the From: header
+ $self->SetHeader( 'Sender', $from );
+}
+
+=head2 GetFriendlyName
+
+Calculate the proper Friendly Name based on the creator of the transaction
+
+=cut
+
+sub GetFriendlyName {
+ my $self = shift;
+ my %args = (
+ is_comment => 0,
+ friendly_name => '',
+ @_
+ );
+ my $friendly_name = $args{friendly_name};
+
+ unless ( $friendly_name ) {
+ $friendly_name = $self->TransactionObj->CreatorObj->FriendlyName;
+ if ( $friendly_name =~ /^"(.*)"$/ ) { # a quoted string
+ $friendly_name = $1;
+ }
+ }
+
+ $friendly_name =~ s/"/\\"/g;
+ return $friendly_name;
+
+}
+
+=head2 SetHeader FIELD, VALUE
+
+Set the FIELD of the current MIME object into VALUE.
+
+=cut
+
+sub SetHeader {
+ my $self = shift;
+ my $field = shift;
+ my $val = shift;
+
+ chomp $val;
+ chomp $field;
+ my $head = $self->TemplateObj->MIMEObj->head;
+ $head->fold_length( $field, 10000 );
+ $head->replace( $field, $val );
+ return $head->get($field);
+}
+
+=head2 SetSubject
+
+This routine sets the subject. it does not add the rt tag. That gets done elsewhere
+If subject is already defined via template, it uses that. otherwise, it tries to get
+the transaction's subject.
+
+=cut
+
+sub SetSubject {
+ my $self = shift;
+ my $subject;
+
+ if ( $self->TemplateObj->MIMEObj->head->get('Subject') ) {
+ return ();
+ }
+
+ # don't use Transaction->Attachments because it caches
+ # and anything which later calls ->Attachments will be hurt
+ # by our RowsPerPage() call. caching is hard.
+ my $message = RT::Attachments->new( $self->CurrentUser );
+ $message->Limit( FIELD => 'TransactionId', VALUE => $self->TransactionObj->id);
+ $message->OrderBy( FIELD => 'id', ORDER => 'ASC' );
+ $message->RowsPerPage(1);
+
+ if ( $self->{'Subject'} ) {
+ $subject = $self->{'Subject'};
+ } elsif ( my $first = $message->First ) {
+ my $tmp = $first->GetHeader('Subject');
+ $subject = defined $tmp ? $tmp : $self->TicketObj->Subject;
+ } else {
+ $subject = $self->TicketObj->Subject;
+ }
+ $subject = '' unless defined $subject;
+ chomp $subject;
+
+ $subject =~ s/(\r\n|\n|\s)/ /g;
+
+ $self->SetHeader( 'Subject', Encode::encode_utf8( $subject ) );
+
+}
+
+=head2 SetSubjectToken
+
+This routine fixes the RT tag in the subject. It's unlikely that you want to overwrite this.
+
+=cut
+
+sub SetSubjectToken {
+ my $self = shift;
+
+ my $head = $self->TemplateObj->MIMEObj->head;
+ $self->SetHeader(
+ Subject =>
+ Encode::encode_utf8(
+ RT::Interface::Email::AddSubjectTag(
+ Encode::decode_utf8( $head->get('Subject') ),
+ $self->TicketObj,
+ ),
+ ),
+ );
+}
+
+=head2 SetReferencesHeaders
+
+Set References and In-Reply-To headers for this message.
+
+=cut
+
+sub SetReferencesHeaders {
+ my $self = shift;
+
+ my $top = $self->TransactionObj->Message->First;
+ unless ( $top ) {
+ $self->SetHeader( References => $self->PseudoReference );
+ return (undef);
+ }
+
+ my @in_reply_to = split( /\s+/m, $top->GetHeader('In-Reply-To') || '' );
+ my @references = split( /\s+/m, $top->GetHeader('References') || '' );
+ my @msgid = split( /\s+/m, $top->GetHeader('Message-ID') || '' );
+
+ # There are two main cases -- this transaction was created with
+ # the RT Web UI, and hence we want to *not* append its Message-ID
+ # to the References and In-Reply-To. OR it came from an outside
+ # source, and we should treat it as per the RFC
+ my $org = RT->Config->Get('Organization');
+ if ( "@msgid" =~ /<(rt-.*?-\d+-\d+)\.(\d+)-0-0\@\Q$org\E>/ ) {
+
+ # Make all references which are internal be to version which we
+ # have sent out
+
+ for ( @references, @in_reply_to ) {
+ s/<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>$/
+ "<$1." . $self->TicketObj->id .
+ "-" . $self->ScripObj->id .
+ "-" . $self->ScripActionObj->{_Message_ID} .
+ "@" . $org . ">"/eg
+ }
+
+ # In reply to whatever the internal message was in reply to
+ $self->SetHeader( 'In-Reply-To', join( " ", (@in_reply_to) ) );
+
+ # Default the references to whatever we're in reply to
+ @references = @in_reply_to unless @references;
+
+ # References are unchanged from internal
+ } else {
+
+ # In reply to that message
+ $self->SetHeader( 'In-Reply-To', join( " ", (@msgid) ) );
+
+ # Default the references to whatever we're in reply to
+ @references = @in_reply_to unless @references;
+
+ # Push that message onto the end of the references
+ push @references, @msgid;
+ }
+
+ # Push pseudo-ref to the front
+ my $pseudo_ref = $self->PseudoReference;
+ @references = ( $pseudo_ref, grep { $_ ne $pseudo_ref } @references );
+
+ # If there are more than 10 references headers, remove all but the
+ # first four and the last six (Gotta keep this from growing
+ # forever)
+ splice( @references, 4, -6 ) if ( $#references >= 10 );
+
+ # Add on the references
+ $self->SetHeader( 'References', join( " ", @references ) );
+ $self->TemplateObj->MIMEObj->head->fold_length( 'References', 80 );
+
+}
+
+=head2 PseudoReference
+
+Returns a fake Message-ID: header for the ticket to allow a base level of threading
+
+=cut
+
+sub PseudoReference {
+
+ my $self = shift;
+ my $pseudo_ref
+ = '<RT-Ticket-'
+ . $self->TicketObj->id . '@'
+ . RT->Config->Get('Organization') . '>';
+ return $pseudo_ref;
+}
+
+=head2 SetHeaderAsEncoding($field_name, $charset_encoding)
+
+This routine converts the field into specified charset encoding.
+
+=cut
+
+sub SetHeaderAsEncoding {
+ my $self = shift;
+ my ( $field, $enc ) = ( shift, shift );
+
+ my $head = $self->TemplateObj->MIMEObj->head;
+
+ if ( lc($field) eq 'from' and RT->Config->Get('SMTPFrom') ) {
+ $head->replace( $field, RT->Config->Get('SMTPFrom') );
+ return;
+ }
+
+ my $value = $head->get( $field );
+ $value = $self->MIMEEncodeString( $value, $enc );
+ $head->replace( $field, $value );
+
+}
+
+=head2 MIMEEncodeString
+
+Takes a perl string and optional encoding pass it over
+L<RT::Interface::Email/EncodeToMIME>.
+
+Basicly encode a string using B encoding according to RFC2047.
+
+=cut
+
+sub MIMEEncodeString {
+ my $self = shift;
+ return RT::Interface::Email::EncodeToMIME( String => $_[0], Charset => $_[1] );
+}
+
+RT::Base->_ImportOverlays();
+
+1;
+
$Attachment->make_singlepart;
# Get the subject
- my $Subject = $Attachment->head->get( 'subject', 0 );
+ my $Subject = Encode::decode( 'UTF-8', $Attachment->head->get( 'subject' ) );
$Subject = '' unless defined $Subject;
chomp $Subject;
- utf8::decode( $Subject ) unless utf8::is_utf8( $Subject );
#Get the Message-ID
- my $MessageId = $Attachment->head->get( 'Message-ID', 0 );
+ my $MessageId = Encode::decode( "UTF-8", $Attachment->head->get( 'Message-ID' ) );
defined($MessageId) or $MessageId = '';
chomp ($MessageId);
$MessageId =~ s/^<(.*?)>$/$1/o;
#Get the filename
-
my $Filename = mime_recommended_filename($Attachment);
# remove path part.
# MIME::Head doesn't support perl strings well and can return
# octets which later will be double encoded in low-level code
- my $head = $Attachment->head->as_string;
- utf8::decode( $head ) unless utf8::is_utf8( $head );
+ my $head = Encode::decode( 'UTF-8', $Attachment->head->as_string );
# If a message has no bodyhandle, that means that it has subparts (or appears to)
# and we should act accordingly.
sub Content {
my $self = shift;
return $self->_DecodeLOB(
- $self->ContentType,
+ $self->GetHeader('Content-Type'), # Includes charset, unlike ->ContentType
$self->ContentEncoding,
$self->_Value('Content', decode_utf8 => 0),
);
}
return $self->Content unless RT::I18N::IsTextualContentType($self->ContentType);
- my $enc = $self->OriginalEncoding;
my $content;
if ( !$self->ContentEncoding || $self->ContentEncoding eq 'none' ) {
return( $self->loc("Unknown ContentEncoding [_1]", $self->ContentEncoding));
}
- # Turn *off* the SvUTF8 bits here so decode_utf8 and from_to below can work.
- local $@;
- Encode::_utf8_off($content);
+ my $entity = MIME::Entity->new();
+ $entity->head->add("Content-Type", $self->GetHeader("Content-Type"));
+ $entity->bodyhandle( MIME::Body::Scalar->new( $content ) );
+ my $from = RT::I18N::_FindOrGuessCharset($entity);
+ $from = 'utf-8' if not $from or not Encode::find_encoding($from);
- if (!$enc || $enc eq '' || $enc eq 'utf8' || $enc eq 'utf-8') {
- # If we somehow fail to do the decode, at least push out the raw bits
- eval { return( Encode::decode_utf8($content)) } || return ($content);
- }
+ my $to = RT::I18N::_CanonicalizeCharset(
+ $self->OriginalEncoding || 'utf-8'
+ );
- eval { Encode::from_to($content, 'utf8' => $enc) } if $enc;
+ local $@;
+ eval { Encode::from_to($content, $from => $to) };
if ($@) {
- $RT::Logger->error("Could not convert attachment from assumed utf8 to '$enc' :".$@);
+ $RT::Logger->error("Could not convert attachment from $from to $to: ".$@);
}
return $content;
}
my $res;
if ( $user && $user->id && $META{$name}->{'Overridable'} ) {
- $user = $user->UserObj if $user->isa('RT::CurrentUser');
my $prefs = $user->Preferences($RT::System);
$res = $prefs->{$name} if $prefs;
}
my $entity = $args{'Entity'};
if ( $args{'Sign'} && !defined $args{'Signer'} ) {
+ my @addresses = Email::Address->parse( Encode::decode("UTF-8",$entity->head->get( 'From' )));
$args{'Signer'} = UseKeyForSigning()
- || (Email::Address->parse( $entity->head->get( 'From' ) ))[0]->address;
+ || $addresses[0]->address;
}
if ( $args{'Encrypt'} && !$args{'Recipients'} ) {
my %seen;
$args{'Recipients'} = [
grep $_ && !$seen{ $_ }++, map $_->address,
- map Email::Address->parse( $entity->head->get( $_ ) ),
+ map Email::Address->parse( Encode::decode("UTF-8",$entity->head->get( $_ ) ) ),
qw(To Cc Bcc)
];
}
$gnupg->options->push_recipients( $_ ) foreach
map UseKeyForEncryption($_) || $_,
grep !$seen{ $_ }++, map $_->address,
- map Email::Address->parse( $entity->head->get( $_ ) ),
+ map Email::Address->parse( Encode::decode( "UTF-8", $entity->head->get( $_ ) ) ),
qw(To Cc Bcc);
my ($tmp_fh, $tmp_fn) = File::Temp::tempfile( UNLINK => 1 );
use RT::CurrentUser;
- # laod
+ # load
my $current_user = RT::CurrentUser->new;
$current_user->Load(...);
# or
my $self = shift;
return '' if !defined $_[0] || $_[0] eq '';
- # XXX: work around perl's deficiency when matching utf8 data
- return $_[0] if Encode::is_utf8($_[0]);
-
return $self->LanguageHandle->maketext_fuzzy( @_ );
}
$cid_of{$uri} = time() . $$ . int(rand(1e6));
my ($data, $filename, $mimetype, $encoding) = GetResource($uri);
- # downgrade non-text strings, because all strings are utf8 by
- # default, which is wrong for non-text strings.
- if ( $mimetype !~ m{text/} ) {
+ # Encode textual data in UTF-8, and downgrade (treat
+ # codepoints as codepoints, and ensure the UTF-8 flag is
+ # off) everything else.
+ my @extra;
+ if ( $mimetype =~ m{text/} ) {
+ $data = Encode::encode( "UTF-8", $data );
+ @extra = ( Charset => "UTF-8" );
+ } else {
utf8::downgrade( $data, 1 ) or $RT::Logger->warning("downgrade $data failed");
}
Disposition => 'inline',
Name => RT::Interface::Email::EncodeToMIME( String => $filename ),
'Content-Id' => $cid_of{$uri},
+ @extra,
);
return "cid:$cid_of{$uri}";
);
my $entity = MIME::Entity->build(
- From => Encode::encode_utf8($args{From}),
- To => Encode::encode_utf8($args{To}),
+ From => Encode::encode("UTF-8", $args{From}),
+ To => Encode::encode("UTF-8", $args{To}),
Subject => RT::Interface::Email::EncodeToMIME( String => $args{Subject} ),
Type => "multipart/mixed",
);
$entity->attach(
- Data => Encode::encode_utf8($content),
Type => 'text/html',
Charset => 'UTF-8',
+ Data => Encode::encode("UTF-8", $content),
Disposition => 'inline',
Encoding => "base64",
);
for ($k, $v) { s/%(..)/chr hex $1/ge }
+ # Decode from bytes to characters
+ $_ = Encode::decode( "UTF-8", $_ ) for $k, $v;
+
# no value yet, simple key=value
if (!exists $args{$k}) {
$args{$k} = $v;
my (@Addresses);
- my @ToObjs = Email::Address->parse( $self->Head->get('To') );
- my @CcObjs = Email::Address->parse( $self->Head->get('Cc') );
+ my @ToObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('To') ) );
+ my @CcObjs = Email::Address->parse( Encode::decode( "UTF-8", $self->Head->get('Cc') ) );
foreach my $AddrObj ( @ToObjs, @CcObjs ) {
my $Address = $AddrObj->address;
# Add base64 since we've seen examples of double newlines with
# this type too. Need an example of a multi-part base64 to
# handle that permutation if it exists.
- elsif ( $mime->head->get('Content-Transfer-Encoding') =~ m{base64} ) {
+ elsif ( ($mime->head->get('Content-Transfer-Encoding')||'') =~ m{base64} ) {
$text_part = $mime; # Assuming single part, already decoded.
}
use warnings;
use strict;
-our $VERSION = '4.0.21';
+our $VERSION = '4.0.22';
use Locale::Maketext::Lexicon 0.25;
use base 'Locale::Maketext::Fuzzy';
-use Encode;
use MIME::Entity;
use MIME::Head;
use File::Glob;
);
# If this is a textual entity, we'd need to preserve its original encoding
- $head->replace( "X-RT-Original-Encoding" => $charset )
+ $head->replace( "X-RT-Original-Encoding" => Encode::encode( "UTF-8", $charset ) )
if $head->mime_attr('content-type.charset') or IsTextualContentType($head->mime_type);
return unless IsTextualContentType($head->mime_type);
if ( $body && ($enc ne $charset || $enc =~ /^utf-?8(?:-strict)?$/i) ) {
my $string = $body->as_string or return;
+ RT::Util::assert_bytes($string);
$RT::Logger->debug( "Converting '$charset' to '$enc' for "
. $head->mime_type . " - "
- . ( $head->get('subject') || 'Subjectless message' ) );
+ . ( Encode::decode("UTF-8",$head->get('subject')) || 'Subjectless message' ) );
- # NOTE:: see the comments at the end of the sub.
- Encode::_utf8_off($string);
Encode::from_to( $string, $charset => $enc );
my $new_body = MIME::Body::InCore->new($string);
}
}
-# NOTES: Why Encode::_utf8_off before Encode::from_to
-#
-# All the strings in RT are utf-8 now. Quotes from Encode POD:
-#
-# [$length =] from_to($octets, FROM_ENC, TO_ENC [, CHECK])
-# ... The data in $octets must be encoded as octets and not as
-# characters in Perl's internal format. ...
-#
-# Not turning off the UTF-8 flag in the string will prevent the string
-# from conversion.
-
-
-
=head2 DecodeMIMEWordsToUTF8 $raw
An utility method which mimics MIME::Words::decode_mimewords, but only
-limited functionality. This function returns an utf-8 string.
-
-It returns the decoded string, or the original string if it's not
-encoded. Since the subroutine converts specified string into utf-8
-charset, it should not alter a subject written in English.
-
-Why not use MIME::Words directly? Because it fails in RT when I
-tried. Maybe it's ok now.
+limited functionality. Despite its name, this function returns the
+bytes of the string, in UTF-8.
=cut
return if $charset eq $enc and $preserve_words;
+ RT::Util::assert_bytes( $head->as_string );
foreach my $tag ( $head->tags ) {
next unless $tag; # seen in wild: headers with no name
my @values = $head->get_all($tag);
$head->delete($tag);
foreach my $value (@values) {
if ( $charset ne $enc || $enc =~ /^utf-?8(?:-strict)?$/i ) {
- Encode::_utf8_off($value);
Encode::from_to( $value, $charset => $enc );
}
$value = DecodeMIMEWordsToEncoding( $value, $enc, $tag )
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+use strict;
+use warnings;
+
+package RT::I18N::de;
+use base 'RT::I18N';
+
+sub init {
+ $_[0]->{numf_comma} = 1;
+}
+
+RT::Base->_ImportOverlays();
+
+1;
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+use strict;
+use warnings;
+
+package RT::I18N::fr;
+use base 'RT::I18N';
+
+use strict;
+use warnings;
+
+sub numf {
+ my ($handle, $num) = @_[0,1];
+ my $fr_num = $handle->SUPER::numf($num);
+ # French prefer to print 1000 as 1(nbsp)000 rather than 1,000
+ $fr_num =~ tr<.,><,\x{A0}>;
+ return $fr_num;
+}
+
+RT::Base->_ImportOverlays();
+
+1;
my $head = shift;
# If this instance of RT sent it our, we don't want to take it in
- my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
+ my $RTLoop = Encode::decode( "UTF-8", $head->get("X-RT-Loop-Prevention") || "" );
chomp ($RTLoop); # remove that newline
if ( $RTLoop eq RT->Config->Get('rtname') ) {
return 1;
# the colons are necessary to make ->build include non-standard headers
my %entity_args = (
Type => "multipart/mixed",
- From => $args{'From'},
- Bcc => $args{'Bcc'},
- To => $args{'To'},
- Subject => $args{'Subject'},
- 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
+ From => Encode::encode( "UTF-8", $args{'From'} ),
+ Bcc => Encode::encode( "UTF-8", $args{'Bcc'} ),
+ To => Encode::encode( "UTF-8", $args{'To'} ),
+ Subject => EncodeToMIME( String => $args{'Subject'} ),
+ 'X-RT-Loop-Prevention:' => Encode::encode( "UTF-8", RT->Config->Get('rtname') ),
);
# only set precedence if the sysadmin wants us to
if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
- $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
+ $entity_args{'Precedence:'} =
+ Encode::encode( "UTF-8", RT->Config->Get('DefaultErrorMailPrecedence') );
}
my $entity = MIME::Entity->build(%entity_args);
SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
- $entity->attach( Data => $args{'Explanation'} . "\n" );
+ $entity->attach(
+ Type => "text/plain",
+ Charset => "UTF-8",
+ Data => Encode::encode( "UTF-8", $args{'Explanation'} . "\n" ),
+ );
if ( $args{'MIMEObj'} ) {
$args{'MIMEObj'}->sync_headers;
}
if ( $args{'Attach'} ) {
- $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
+ $entity->attach( Data => Encode::encode( "UTF-8", $args{'Attach'} ), Type => 'message/rfc822' );
}
return 0;
}
- my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
+ my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
chomp $msgid;
# If we don't have any recipients to send to, don't send a message;
require RT::Date;
my $date = RT::Date->new( RT->SystemUser );
$date->SetToNow;
- $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
+ $args{'Entity'}->head->set( 'Date', Encode::encode( "UTF-8", $date->RFC2822( Timezone => 'server' ) ) );
}
my $mail_command = RT->Config->Get('MailCommand');
# duplicate head as we want drop Bcc field
my $head = $args{'Entity'}->head->dup;
- my @recipients = map $_->address, map
- Email::Address->parse($head->get($_)), qw(To Cc Bcc);
+ my @recipients = map $_->address, map
+ Email::Address->parse(Encode::decode("UTF-8", $head->get($_))),
+ qw(To Cc Bcc);
$head->delete('Bcc');
my $sender = RT->Config->Get('SMTPFrom')
- || $args{'Entity'}->head->get('From');
+ || Encode::decode( "UTF-8", $args{'Entity'}->head->get('From') );
chomp $sender;
my $status = $smtp->mail( $sender )
return -1;
}
- $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
+ $mail->head->set( $_ => Encode::encode( "UTF-8", $args{ $_ } ) )
foreach grep defined $args{$_}, qw(To Cc Bcc From);
- $mail->head->set( $_ => $args{ExtraHeaders}{$_} )
+ $mail->head->set( $_ => Encode::encode( "UTF-8", $args{ExtraHeaders}{$_} ) )
foreach keys %{ $args{ExtraHeaders} };
SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
. $txn->id ." of a ticket #". $txn->ObjectId;
}
$mail = MIME::Entity->build(
- Type => 'text/plain',
- Data => $description,
+ Type => 'text/plain',
+ Charset => "UTF-8",
+ Data => Encode::encode( "UTF-8", $description ),
);
}
);
return 1 unless $args{'Sign'} || $args{'Encrypt'};
- my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
+ my $msgid = Encode::decode( "UTF-8", $args{'Entity'}->head->get('Message-ID') || '' );
chomp $msgid;
$RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
$value =~ s/\s+$//;
- # we need perl string to split thing char by char
- Encode::_utf8_on($value) unless Encode::is_utf8($value);
-
my ( $tmp, @chunks ) = ( '', () );
while ( length $value ) {
my $char = substr( $value, 0, 1, '' );
&& !IgnoreCcAddress( $_ )
}
map lc $user->CanonicalizeEmailAddress( $_->address ),
- map RT::EmailParser->CleanupAddresses( Email::Address->parse( $args{'Head'}->get( $_ ) ) ),
+ map RT::EmailParser->CleanupAddresses( Email::Address->parse(
+ Encode::decode( "UTF-8", $args{'Head'}->get( $_ ) ) ) ),
qw(To Cc);
}
#Figure out who's sending this message.
foreach my $header ( @sender_headers ) {
- my $addr_line = $head->get($header) || next;
+ my $addr_line = Encode::decode( "UTF-8", $head->get($header) ) || next;
my ($addr, $name) = ParseAddressFromHeader( $addr_line );
# only return if the address is not empty
return ($addr, $name, @errors) if $addr;
foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
# If there's a header of that name
- my $headerobj = $head->get($header);
+ my $headerobj = Encode::decode( "UTF-8", $head->get($header) );
if ($headerobj) {
my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
my %skip = map { lc $_ => 1 } @_;
foreach my $field ( qw(To Cc Bcc) ) {
- $head->set( $field =>
+ $head->set( $field => Encode::encode( "UTF-8",
join ', ', map $_->format, grep !$skip{ lc $_->address },
- Email::Address->parse( $head->get( $field ) )
+ Email::Address->parse( Encode::decode( "UTF-8", $head->get( $field ) ) ) )
);
}
}
my $get_header = sub {
my @res;
if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
- @res = $args{'InReplyTo'}->head->get( shift );
+ @res = map {Encode::decode("UTF-8", $_)} $args{'InReplyTo'}->head->get( shift );
} else {
@res = $args{'InReplyTo'}->GetHeader( shift ) || '';
}
if @references > 10;
my $mail = $args{'Message'};
- $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
- $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) );
+ $mail->head->set( 'In-Reply-To' => Encode::encode( "UTF-8", join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
+ $mail->head->set( 'References' => Encode::encode( "UTF-8", join ' ', @references) );
}
sub ExtractTicketId {
my $entity = shift;
- my $subject = $entity->head->get('Subject') || '';
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') || '' );
chomp $subject;
return ParseTicketId( $subject );
}
my $head = $Message->head;
my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
my $Sender = (ParseSenderAddressFromHead( $head ))[0];
- my $From = $head->get("From");
+ my $From = Encode::decode( "UTF-8", $head->get("From") );
chomp $From if defined $From;
- my $MessageId = $head->get('Message-ID')
+ my $MessageId = Encode::decode( "UTF-8", $head->get('Message-ID') )
|| "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
#Pull apart the subject line
- my $Subject = $head->get('Subject') || '';
+ my $Subject = Encode::decode( "UTF-8", $head->get('Subject') || '');
chomp $Subject;
# Lets check for mail loops of various sorts.
$args{'ticket'} ||= ExtractTicketId( $Message );
# ExtractTicketId may have been overridden, and edited the Subject
- my $NewSubject = $Message->head->get('Subject');
+ my $NewSubject = Encode::decode( "UTF-8", $Message->head->get('Subject') );
chomp $NewSubject;
$SystemTicket = RT::Ticket->new( RT->SystemUser );
@_
);
- my $From = $args{Message}->head->get("From");
+ my $From = Encode::decode( "UTF-8", $args{Message}->head->get("From") );
if ( $args{'Action'} =~ /^take$/i ) {
my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
# to the scrip. We might want to notify nobody. Or just
# the RT Owner. Or maybe all Privileged watchers.
my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
- $head->replace( 'RT-Squelch-Replies-To', $Sender );
+ $head->replace( 'RT-Squelch-Replies-To', Encode::encode("UTF-8", $Sender ) );
$head->replace( 'RT-DetectedAutoGenerated', 'true' );
}
return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+package RT::Interface::Email;
+
+use strict;
+use warnings;
+
+use Email::Address;
+use MIME::Entity;
+use RT::EmailParser;
+use File::Temp;
+use UNIVERSAL::require;
+use Mail::Mailer ();
+use Text::ParseWords qw/shellwords/;
+
+BEGIN {
+ use base 'Exporter';
+ use vars qw ( @EXPORT_OK);
+
+ # set the version for version checking
+ our $VERSION = 2.0;
+
+ # your exported package globals go here,
+ # as well as any optionally exported functions
+ @EXPORT_OK = qw(
+ &CreateUser
+ &GetMessageContent
+ &CheckForLoops
+ &CheckForSuspiciousSender
+ &CheckForAutoGenerated
+ &CheckForBounce
+ &MailError
+ &ParseCcAddressesFromHead
+ &ParseSenderAddressFromHead
+ &ParseErrorsToAddressFromHead
+ &ParseAddressFromHeader
+ &Gateway);
+
+}
+
+=head1 NAME
+
+ RT::Interface::Email - helper functions for parsing email sent to RT
+
+=head1 SYNOPSIS
+
+ use lib "!!RT_LIB_PATH!!";
+ use lib "!!RT_ETC_PATH!!";
+
+ use RT::Interface::Email qw(Gateway CreateUser);
+
+=head1 DESCRIPTION
+
+
+
+
+=head1 METHODS
+
+=head2 CheckForLoops HEAD
+
+Takes a HEAD object of L<MIME::Head> class and returns true if the
+message's been sent by this RT instance. Uses "X-RT-Loop-Prevention"
+field of the head for test.
+
+=cut
+
+sub CheckForLoops {
+ my $head = shift;
+
+ # If this instance of RT sent it our, we don't want to take it in
+ my $RTLoop = $head->get("X-RT-Loop-Prevention") || "";
+ chomp ($RTLoop); # remove that newline
+ if ( $RTLoop eq RT->Config->Get('rtname') ) {
+ return 1;
+ }
+
+ # TODO: We might not trap the case where RT instance A sends a mail
+ # to RT instance B which sends a mail to ...
+ return undef;
+}
+
+=head2 CheckForSuspiciousSender HEAD
+
+Takes a HEAD object of L<MIME::Head> class and returns true if sender
+is suspicious. Suspicious means mailer daemon.
+
+See also L</ParseSenderAddressFromHead>.
+
+=cut
+
+sub CheckForSuspiciousSender {
+ my $head = shift;
+
+ #if it's from a postmaster or mailer daemon, it's likely a bounce.
+
+ #TODO: better algorithms needed here - there is no standards for
+ #bounces, so it's very difficult to separate them from anything
+ #else. At the other hand, the Return-To address is only ment to be
+ #used as an error channel, we might want to put up a separate
+ #Return-To address which is treated differently.
+
+ #TODO: search through the whole email and find the right Ticket ID.
+
+ my ( $From, $junk ) = ParseSenderAddressFromHead($head);
+
+ # If unparseable (non-ASCII), $From can come back undef
+ return undef if not defined $From;
+
+ if ( ( $From =~ /^mailer-daemon\@/i )
+ or ( $From =~ /^postmaster\@/i )
+ or ( $From eq "" ))
+ {
+ return (1);
+
+ }
+
+ return undef;
+}
+
+=head2 CheckForAutoGenerated HEAD
+
+Takes a HEAD object of L<MIME::Head> class and returns true if message
+is autogenerated. Checks 'Precedence' and 'X-FC-Machinegenerated'
+fields of the head in tests.
+
+=cut
+
+sub CheckForAutoGenerated {
+ my $head = shift;
+
+ my $Precedence = $head->get("Precedence") || "";
+ if ( $Precedence =~ /^(bulk|junk)/i ) {
+ return (1);
+ }
+
+ # Per RFC3834, any Auto-Submitted header which is not "no" means
+ # it is auto-generated.
+ my $AutoSubmitted = $head->get("Auto-Submitted") || "";
+ if ( length $AutoSubmitted and $AutoSubmitted ne "no" ) {
+ return (1);
+ }
+
+ # First Class mailer uses this as a clue.
+ my $FCJunk = $head->get("X-FC-Machinegenerated") || "";
+ if ( $FCJunk =~ /^true/i ) {
+ return (1);
+ }
+
+ return (0);
+}
+
+
+sub CheckForBounce {
+ my $head = shift;
+
+ my $ReturnPath = $head->get("Return-path") || "";
+ return ( $ReturnPath =~ /<>/ );
+}
+
+
+=head2 MailError PARAM HASH
+
+Sends an error message. Takes a param hash:
+
+=over 4
+
+=item From - sender's address, by default is 'CorrespondAddress';
+
+=item To - recipient, by default is 'OwnerEmail';
+
+=item Bcc - optional Bcc recipients;
+
+=item Subject - subject of the message, default is 'There has been an error';
+
+=item Explanation - main content of the error, default value is 'Unexplained error';
+
+=item MIMEObj - optional MIME entity that's attached to the error mail, as well we
+add 'In-Reply-To' field to the error that points to this message.
+
+=item Attach - optional text that attached to the error as 'message/rfc822' part.
+
+=item LogLevel - log level under which we should write the subject and
+explanation message into the log, by default we log it as critical.
+
+=back
+
+=cut
+
+sub MailError {
+ my %args = (
+ To => RT->Config->Get('OwnerEmail'),
+ Bcc => undef,
+ From => RT->Config->Get('CorrespondAddress'),
+ Subject => 'There has been an error',
+ Explanation => 'Unexplained error',
+ MIMEObj => undef,
+ Attach => undef,
+ LogLevel => 'crit',
+ @_
+ );
+
+ $RT::Logger->log(
+ level => $args{'LogLevel'},
+ message => "$args{Subject}: $args{'Explanation'}",
+ ) if $args{'LogLevel'};
+
+ # the colons are necessary to make ->build include non-standard headers
+ my %entity_args = (
+ Type => "multipart/mixed",
+ From => $args{'From'},
+ Bcc => $args{'Bcc'},
+ To => $args{'To'},
+ Subject => $args{'Subject'},
+ 'X-RT-Loop-Prevention:' => RT->Config->Get('rtname'),
+ );
+
+ # only set precedence if the sysadmin wants us to
+ if (defined(RT->Config->Get('DefaultErrorMailPrecedence'))) {
+ $entity_args{'Precedence:'} = RT->Config->Get('DefaultErrorMailPrecedence');
+ }
+
+ my $entity = MIME::Entity->build(%entity_args);
+ SetInReplyTo( Message => $entity, InReplyTo => $args{'MIMEObj'} );
+
+ $entity->attach( Data => $args{'Explanation'} . "\n" );
+
+ if ( $args{'MIMEObj'} ) {
+ $args{'MIMEObj'}->sync_headers;
+ $entity->add_part( $args{'MIMEObj'} );
+ }
+
+ if ( $args{'Attach'} ) {
+ $entity->attach( Data => $args{'Attach'}, Type => 'message/rfc822' );
+
+ }
+
+ SendEmail( Entity => $entity, Bounce => 1 );
+}
+
+
+=head2 SendEmail Entity => undef, [ Bounce => 0, Ticket => undef, Transaction => undef ]
+
+Sends an email (passed as a L<MIME::Entity> object C<ENTITY>) using
+RT's outgoing mail configuration. If C<BOUNCE> is passed, and is a
+true value, the message will be marked as an autogenerated error, if
+possible. Sets Date field of the head to now if it's not set.
+
+If the C<X-RT-Squelch> header is set to any true value, the mail will
+not be sent. One use is to let extensions easily cancel outgoing mail.
+
+Ticket and Transaction arguments are optional. If Transaction is
+specified and Ticket is not then ticket of the transaction is
+used, but only if the transaction belongs to a ticket.
+
+Returns 1 on success, 0 on error or -1 if message has no recipients
+and hasn't been sent.
+
+=head3 Signing and Encrypting
+
+This function as well signs and/or encrypts the message according to
+headers of a transaction's attachment or properties of a ticket's queue.
+To get full access to the configuration Ticket and/or Transaction
+arguments must be provided, but you can force behaviour using Sign
+and/or Encrypt arguments.
+
+The following precedence of arguments are used to figure out if
+the message should be encrypted and/or signed:
+
+* if Sign or Encrypt argument is defined then its value is used
+
+* else if Transaction's first attachment has X-RT-Sign or X-RT-Encrypt
+header field then it's value is used
+
+* else properties of a queue of the Ticket are used.
+
+=cut
+
+sub WillSignEncrypt {
+ my %args = @_;
+ my $attachment = delete $args{Attachment};
+ my $ticket = delete $args{Ticket};
+
+ if ( not RT->Config->Get('GnuPG')->{'Enable'} ) {
+ $args{Sign} = $args{Encrypt} = 0;
+ return wantarray ? %args : 0;
+ }
+
+ for my $argument ( qw(Sign Encrypt) ) {
+ next if defined $args{ $argument };
+
+ if ( $attachment and defined $attachment->GetHeader("X-RT-$argument") ) {
+ $args{$argument} = $attachment->GetHeader("X-RT-$argument");
+ } elsif ( $ticket and $argument eq "Encrypt" ) {
+ $args{Encrypt} = $ticket->QueueObj->Encrypt();
+ } elsif ( $ticket and $argument eq "Sign" ) {
+ # Note that $queue->Sign is UI-only, and that all
+ # UI-generated messages explicitly set the X-RT-Crypt header
+ # to 0 or 1; thus this path is only taken for messages
+ # generated _not_ via the web UI.
+ $args{Sign} = $ticket->QueueObj->SignAuto();
+ }
+ }
+
+ return wantarray ? %args : ($args{Sign} || $args{Encrypt});
+}
+
+sub SendEmail {
+ my (%args) = (
+ Entity => undef,
+ Bounce => 0,
+ Ticket => undef,
+ Transaction => undef,
+ @_,
+ );
+
+ my $TicketObj = $args{'Ticket'};
+ my $TransactionObj = $args{'Transaction'};
+
+ foreach my $arg( qw(Entity Bounce) ) {
+ next unless defined $args{ lc $arg };
+
+ $RT::Logger->warning("'". lc($arg) ."' argument is deprecated, use '$arg' instead");
+ $args{ $arg } = delete $args{ lc $arg };
+ }
+
+ unless ( $args{'Entity'} ) {
+ $RT::Logger->crit( "Could not send mail without 'Entity' object" );
+ return 0;
+ }
+
+ my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
+ chomp $msgid;
+
+ # If we don't have any recipients to send to, don't send a message;
+ unless ( $args{'Entity'}->head->get('To')
+ || $args{'Entity'}->head->get('Cc')
+ || $args{'Entity'}->head->get('Bcc') )
+ {
+ $RT::Logger->info( $msgid . " No recipients found. Not sending." );
+ return -1;
+ }
+
+ if ($args{'Entity'}->head->get('X-RT-Squelch')) {
+ $RT::Logger->info( $msgid . " Squelch header found. Not sending." );
+ return -1;
+ }
+
+ if ( $TransactionObj && !$TicketObj
+ && $TransactionObj->ObjectType eq 'RT::Ticket' )
+ {
+ $TicketObj = $TransactionObj->Object;
+ }
+
+ if ( RT->Config->Get('GnuPG')->{'Enable'} ) {
+ %args = WillSignEncrypt(
+ %args,
+ Attachment => $TransactionObj ? $TransactionObj->Attachments->First : undef,
+ Ticket => $TicketObj,
+ );
+ my $res = SignEncrypt( %args );
+ return $res unless $res > 0;
+ }
+
+ unless ( $args{'Entity'}->head->get('Date') ) {
+ require RT::Date;
+ my $date = RT::Date->new( RT->SystemUser );
+ $date->SetToNow;
+ $args{'Entity'}->head->set( 'Date', $date->RFC2822( Timezone => 'server' ) );
+ }
+
+ my $mail_command = RT->Config->Get('MailCommand');
+
+ if ($mail_command eq 'testfile' and not $Mail::Mailer::testfile::config{outfile}) {
+ $Mail::Mailer::testfile::config{outfile} = File::Temp->new;
+ $RT::Logger->info("Storing outgoing emails in $Mail::Mailer::testfile::config{outfile}");
+ }
+
+ # if it is a sub routine, we just return it;
+ return $mail_command->($args{'Entity'}) if UNIVERSAL::isa( $mail_command, 'CODE' );
+
+ if ( $mail_command eq 'sendmailpipe' ) {
+ my $path = RT->Config->Get('SendmailPath');
+ my @args = shellwords(RT->Config->Get('SendmailArguments'));
+
+ # SetOutgoingMailFrom and bounces conflict, since they both want -f
+ if ( $args{'Bounce'} ) {
+ push @args, shellwords(RT->Config->Get('SendmailBounceArguments'));
+ } elsif ( my $MailFrom = RT->Config->Get('SetOutgoingMailFrom') ) {
+ my $OutgoingMailAddress = $MailFrom =~ /\@/ ? $MailFrom : undef;
+ my $Overrides = RT->Config->Get('OverrideOutgoingMailFrom') || {};
+
+ if ($TicketObj) {
+ my $QueueName = $TicketObj->QueueObj->Name;
+ my $QueueAddressOverride = $Overrides->{$QueueName};
+
+ if ($QueueAddressOverride) {
+ $OutgoingMailAddress = $QueueAddressOverride;
+ } else {
+ $OutgoingMailAddress ||= $TicketObj->QueueObj->CorrespondAddress
+ || RT->Config->Get('CorrespondAddress');
+ }
+ }
+ elsif ($Overrides->{'Default'}) {
+ $OutgoingMailAddress = $Overrides->{'Default'};
+ }
+
+ push @args, "-f", $OutgoingMailAddress
+ if $OutgoingMailAddress;
+ }
+
+ # VERP
+ if ( $TransactionObj and
+ my $prefix = RT->Config->Get('VERPPrefix') and
+ my $domain = RT->Config->Get('VERPDomain') )
+ {
+ my $from = $TransactionObj->CreatorObj->EmailAddress;
+ $from =~ s/@/=/g;
+ $from =~ s/\s//g;
+ push @args, "-f", "$prefix$from\@$domain";
+ }
+
+ eval {
+ # don't ignore CHLD signal to get proper exit code
+ local $SIG{'CHLD'} = 'DEFAULT';
+
+ # if something wrong with $mail->print we will get PIPE signal, handle it
+ local $SIG{'PIPE'} = sub { die "program unexpectedly closed pipe" };
+
+ require IPC::Open2;
+ my ($mail, $stdout);
+ my $pid = IPC::Open2::open2( $stdout, $mail, $path, @args )
+ or die "couldn't execute program: $!";
+
+ $args{'Entity'}->print($mail);
+ close $mail or die "close pipe failed: $!";
+
+ waitpid($pid, 0);
+ if ($?) {
+ # sendmail exit statuses mostly errors with data not software
+ # TODO: status parsing: core dump, exit on signal or EX_*
+ my $msg = "$msgid: `$path @args` exited with code ". ($?>>8);
+ $msg = ", interrupted by signal ". ($?&127) if $?&127;
+ $RT::Logger->error( $msg );
+ die $msg;
+ }
+ };
+ if ( $@ ) {
+ $RT::Logger->crit( "$msgid: Could not send mail with command `$path @args`: " . $@ );
+ if ( $TicketObj ) {
+ _RecordSendEmailFailure( $TicketObj );
+ }
+ return 0;
+ }
+ }
+ elsif ( $mail_command eq 'smtp' ) {
+ require Net::SMTP;
+ my $smtp = do { local $@; eval { Net::SMTP->new(
+ Host => RT->Config->Get('SMTPServer'),
+ Debug => RT->Config->Get('SMTPDebug'),
+ ) } };
+ unless ( $smtp ) {
+ $RT::Logger->crit( "Could not connect to SMTP server.");
+ if ($TicketObj) {
+ _RecordSendEmailFailure( $TicketObj );
+ }
+ return 0;
+ }
+
+ # duplicate head as we want drop Bcc field
+ my $head = $args{'Entity'}->head->dup;
+ my @recipients = map $_->address, map
+ Email::Address->parse($head->get($_)), qw(To Cc Bcc);
+ $head->delete('Bcc');
+
+ my $sender = RT->Config->Get('SMTPFrom')
+ || $args{'Entity'}->head->get('From');
+ chomp $sender;
+
+ my $status = $smtp->mail( $sender )
+ && $smtp->recipient( @recipients );
+
+ if ( $status ) {
+ $smtp->data;
+ my $fh = $smtp->tied_fh;
+ $head->print( $fh );
+ print $fh "\n";
+ $args{'Entity'}->print_body( $fh );
+ $smtp->dataend;
+ }
+ $smtp->quit;
+
+ unless ( $status ) {
+ $RT::Logger->crit( "$msgid: Could not send mail via SMTP." );
+ if ( $TicketObj ) {
+ _RecordSendEmailFailure( $TicketObj );
+ }
+ return 0;
+ }
+ }
+ else {
+ local ($ENV{'MAILADDRESS'}, $ENV{'PERL_MAILERS'});
+
+ my @mailer_args = ($mail_command);
+ if ( $mail_command eq 'sendmail' ) {
+ $ENV{'PERL_MAILERS'} = RT->Config->Get('SendmailPath');
+ push @mailer_args, split(/\s+/, RT->Config->Get('SendmailArguments'));
+ }
+ else {
+ push @mailer_args, RT->Config->Get('MailParams');
+ }
+
+ unless ( $args{'Entity'}->send( @mailer_args ) ) {
+ $RT::Logger->crit( "$msgid: Could not send mail." );
+ if ( $TicketObj ) {
+ _RecordSendEmailFailure( $TicketObj );
+ }
+ return 0;
+ }
+ }
+ return 1;
+}
+
+=head2 PrepareEmailUsingTemplate Template => '', Arguments => {}
+
+Loads a template. Parses it using arguments if it's not empty.
+Returns a tuple (L<RT::Template> object, error message).
+
+Note that even if a template object is returned MIMEObj method
+may return undef for empty templates.
+
+=cut
+
+sub PrepareEmailUsingTemplate {
+ my %args = (
+ Template => '',
+ Arguments => {},
+ @_
+ );
+
+ my $template = RT::Template->new( RT->SystemUser );
+ $template->LoadGlobalTemplate( $args{'Template'} );
+ unless ( $template->id ) {
+ return (undef, "Couldn't load template '". $args{'Template'} ."'");
+ }
+ return $template if $template->IsEmpty;
+
+ my ($status, $msg) = $template->Parse( %{ $args{'Arguments'} } );
+ return (undef, $msg) unless $status;
+
+ return $template;
+}
+
+=head2 SendEmailUsingTemplate Template => '', Arguments => {}, From => CorrespondAddress, To => '', Cc => '', Bcc => ''
+
+Sends email using a template, takes name of template, arguments for it and recipients.
+
+=cut
+
+sub SendEmailUsingTemplate {
+ my %args = (
+ Template => '',
+ Arguments => {},
+ To => undef,
+ Cc => undef,
+ Bcc => undef,
+ From => RT->Config->Get('CorrespondAddress'),
+ InReplyTo => undef,
+ ExtraHeaders => {},
+ @_
+ );
+
+ my ($template, $msg) = PrepareEmailUsingTemplate( %args );
+ return (0, $msg) unless $template;
+
+ my $mail = $template->MIMEObj;
+ unless ( $mail ) {
+ $RT::Logger->info("Message is not sent as template #". $template->id ." is empty");
+ return -1;
+ }
+
+ $mail->head->set( $_ => Encode::encode_utf8( $args{ $_ } ) )
+ foreach grep defined $args{$_}, qw(To Cc Bcc From);
+
+ $mail->head->set( $_ => $args{ExtraHeaders}{$_} )
+ foreach keys %{ $args{ExtraHeaders} };
+
+ SetInReplyTo( Message => $mail, InReplyTo => $args{'InReplyTo'} );
+
+ return SendEmail( Entity => $mail );
+}
+
+=head2 ForwardTransaction TRANSACTION, To => '', Cc => '', Bcc => ''
+
+Forwards transaction with all attachments as 'message/rfc822'.
+
+=cut
+
+sub ForwardTransaction {
+ my $txn = shift;
+ my %args = ( To => '', Cc => '', Bcc => '', @_ );
+
+ my $entity = $txn->ContentAsMIME;
+
+ my ( $ret, $msg ) = SendForward( %args, Entity => $entity, Transaction => $txn );
+ if ($ret) {
+ my $ticket = $txn->TicketObj;
+ my ( $ret, $msg ) = $ticket->_NewTransaction(
+ Type => 'Forward Transaction',
+ Field => $txn->id,
+ Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
+ );
+ unless ($ret) {
+ $RT::Logger->error("Failed to create transaction: $msg");
+ }
+ }
+ return ( $ret, $msg );
+}
+
+=head2 ForwardTicket TICKET, To => '', Cc => '', Bcc => ''
+
+Forwards a ticket's Create and Correspond Transactions and their Attachments as 'message/rfc822'.
+
+=cut
+
+sub ForwardTicket {
+ my $ticket = shift;
+ my %args = ( To => '', Cc => '', Bcc => '', @_ );
+
+ my $txns = $ticket->Transactions;
+ $txns->Limit(
+ FIELD => 'Type',
+ VALUE => $_,
+ ) for qw(Create Correspond);
+
+ my $entity = MIME::Entity->build(
+ Type => 'multipart/mixed',
+ Description => 'forwarded ticket',
+ );
+ $entity->add_part( $_ ) foreach
+ map $_->ContentAsMIME,
+ @{ $txns->ItemsArrayRef };
+
+ my ( $ret, $msg ) = SendForward(
+ %args,
+ Entity => $entity,
+ Ticket => $ticket,
+ Template => 'Forward Ticket',
+ );
+
+ if ($ret) {
+ my ( $ret, $msg ) = $ticket->_NewTransaction(
+ Type => 'Forward Ticket',
+ Field => $ticket->id,
+ Data => join ', ', grep { length } $args{To}, $args{Cc}, $args{Bcc},
+ );
+ unless ($ret) {
+ $RT::Logger->error("Failed to create transaction: $msg");
+ }
+ }
+
+ return ( $ret, $msg );
+
+}
+
+=head2 SendForward Entity => undef, Ticket => undef, Transaction => undef, Template => undef, To => '', Cc => '', Bcc => ''
+
+Forwards an Entity representing Ticket or Transaction as 'message/rfc822'. Entity is wrapped into Template.
+
+=cut
+
+sub SendForward {
+ my (%args) = (
+ Entity => undef,
+ Ticket => undef,
+ Transaction => undef,
+ Template => 'Forward',
+ To => '', Cc => '', Bcc => '',
+ @_
+ );
+
+ my $txn = $args{'Transaction'};
+ my $ticket = $args{'Ticket'};
+ $ticket ||= $txn->Object if $txn;
+
+ my $entity = $args{'Entity'};
+ unless ( $entity ) {
+ require Carp;
+ $RT::Logger->error(Carp::longmess("No entity provided"));
+ return (0, $ticket->loc("Couldn't send email"));
+ }
+
+ my ($template, $msg) = PrepareEmailUsingTemplate(
+ Template => $args{'Template'},
+ Arguments => {
+ Ticket => $ticket,
+ Transaction => $txn,
+ },
+ );
+
+ my $mail;
+ if ( $template ) {
+ $mail = $template->MIMEObj;
+ } else {
+ $RT::Logger->warning($msg);
+ }
+ unless ( $mail ) {
+ $RT::Logger->warning("Couldn't generate email using template '$args{Template}'");
+
+ my $description;
+ unless ( $args{'Transaction'} ) {
+ $description = 'This is forward of ticket #'. $ticket->id;
+ } else {
+ $description = 'This is forward of transaction #'
+ . $txn->id ." of a ticket #". $txn->ObjectId;
+ }
+ $mail = MIME::Entity->build(
+ Type => 'text/plain',
+ Data => $description,
+ );
+ }
+
+ $mail->head->set( $_ => EncodeToMIME( String => $args{$_} ) )
+ foreach grep defined $args{$_}, qw(To Cc Bcc);
+
+ $mail->make_multipart unless $mail->is_multipart;
+ $mail->add_part( $entity );
+
+ my $from;
+ unless (defined $mail->head->get('Subject')) {
+ my $subject = '';
+ $subject = $txn->Subject if $txn;
+ $subject ||= $ticket->Subject if $ticket;
+
+ unless ( RT->Config->Get('ForwardFromUser') ) {
+ # XXX: what if want to forward txn of other object than ticket?
+ $subject = AddSubjectTag( $subject, $ticket );
+ }
+
+ $mail->head->set( Subject => EncodeToMIME( String => "Fwd: $subject" ) );
+ }
+
+ $mail->head->set(
+ From => EncodeToMIME(
+ String => GetForwardFrom( Transaction => $txn, Ticket => $ticket )
+ )
+ );
+
+ my $status = RT->Config->Get('ForwardFromUser')
+ # never sign if we forward from User
+ ? SendEmail( %args, Entity => $mail, Sign => 0 )
+ : SendEmail( %args, Entity => $mail );
+ return (0, $ticket->loc("Couldn't send email")) unless $status;
+ return (1, $ticket->loc("Sent email successfully"));
+}
+
+=head2 GetForwardFrom Ticket => undef, Transaction => undef
+
+Resolve the From field to use in forward mail
+
+=cut
+
+sub GetForwardFrom {
+ my %args = ( Ticket => undef, Transaction => undef, @_ );
+ my $txn = $args{Transaction};
+ my $ticket = $args{Ticket} || $txn->Object;
+
+ if ( RT->Config->Get('ForwardFromUser') ) {
+ return ( $txn || $ticket )->CurrentUser->EmailAddress;
+ }
+ else {
+ return $ticket->QueueObj->CorrespondAddress
+ || RT->Config->Get('CorrespondAddress');
+ }
+}
+
+=head2 SignEncrypt Entity => undef, Sign => 0, Encrypt => 0
+
+Signs and encrypts message using L<RT::Crypt::GnuPG>, but as well
+handle errors with users' keys.
+
+If a recipient has no key or has other problems with it, then the
+unction sends a error to him using 'Error: public key' template.
+Also, notifies RT's owner using template 'Error to RT owner: public key'
+to inform that there are problems with users' keys. Then we filter
+all bad recipients and retry.
+
+Returns 1 on success, 0 on error and -1 if all recipients are bad and
+had been filtered out.
+
+=cut
+
+sub SignEncrypt {
+ my %args = (
+ Entity => undef,
+ Sign => 0,
+ Encrypt => 0,
+ @_
+ );
+ return 1 unless $args{'Sign'} || $args{'Encrypt'};
+
+ my $msgid = $args{'Entity'}->head->get('Message-ID') || '';
+ chomp $msgid;
+
+ $RT::Logger->debug("$msgid Signing message") if $args{'Sign'};
+ $RT::Logger->debug("$msgid Encrypting message") if $args{'Encrypt'};
+
+ require RT::Crypt::GnuPG;
+ my %res = RT::Crypt::GnuPG::SignEncrypt( %args );
+ return 1 unless $res{'exit_code'};
+
+ my @status = RT::Crypt::GnuPG::ParseStatus( $res{'status'} );
+
+ my @bad_recipients;
+ foreach my $line ( @status ) {
+ # if the passphrase fails, either you have a bad passphrase
+ # or gpg-agent has died. That should get caught in Create and
+ # Update, but at least throw an error here
+ if (($line->{'Operation'}||'') eq 'PassphraseCheck'
+ && $line->{'Status'} =~ /^(?:BAD|MISSING)$/ ) {
+ $RT::Logger->error( "$line->{'Status'} PASSPHRASE: $line->{'Message'}" );
+ return 0;
+ }
+ next unless ($line->{'Operation'}||'') eq 'RecipientsCheck';
+ next if $line->{'Status'} eq 'DONE';
+ $RT::Logger->error( $line->{'Message'} );
+ push @bad_recipients, $line;
+ }
+ return 0 unless @bad_recipients;
+
+ $_->{'AddressObj'} = (Email::Address->parse( $_->{'Recipient'} ))[0]
+ foreach @bad_recipients;
+
+ foreach my $recipient ( @bad_recipients ) {
+ my $status = SendEmailUsingTemplate(
+ To => $recipient->{'AddressObj'}->address,
+ Template => 'Error: public key',
+ Arguments => {
+ %$recipient,
+ TicketObj => $args{'Ticket'},
+ TransactionObj => $args{'Transaction'},
+ },
+ );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't send 'Error: public key'");
+ }
+ }
+
+ my $status = SendEmailUsingTemplate(
+ To => RT->Config->Get('OwnerEmail'),
+ Template => 'Error to RT owner: public key',
+ Arguments => {
+ BadRecipients => \@bad_recipients,
+ TicketObj => $args{'Ticket'},
+ TransactionObj => $args{'Transaction'},
+ },
+ );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't send 'Error to RT owner: public key'");
+ }
+
+ DeleteRecipientsFromHead(
+ $args{'Entity'}->head,
+ map $_->{'AddressObj'}->address, @bad_recipients
+ );
+
+ unless ( $args{'Entity'}->head->get('To')
+ || $args{'Entity'}->head->get('Cc')
+ || $args{'Entity'}->head->get('Bcc') )
+ {
+ $RT::Logger->debug("$msgid No recipients that have public key, not sending");
+ return -1;
+ }
+
+ # redo without broken recipients
+ %res = RT::Crypt::GnuPG::SignEncrypt( %args );
+ return 0 if $res{'exit_code'};
+
+ return 1;
+}
+
+use MIME::Words ();
+
+=head2 EncodeToMIME
+
+Takes a hash with a String and a Charset. Returns the string encoded
+according to RFC2047, using B (base64 based) encoding.
+
+String must be a perl string, octets are returned.
+
+If Charset is not provided then $EmailOutputEncoding config option
+is used, or "latin-1" if that is not set.
+
+=cut
+
+sub EncodeToMIME {
+ my %args = (
+ String => undef,
+ Charset => undef,
+ @_
+ );
+ my $value = $args{'String'};
+ return $value unless $value; # 0 is perfect ascii
+ my $charset = $args{'Charset'} || RT->Config->Get('EmailOutputEncoding');
+ my $encoding = 'B';
+
+ # using RFC2047 notation, sec 2.
+ # encoded-word = "=?" charset "?" encoding "?" encoded-text "?="
+
+ # An 'encoded-word' may not be more than 75 characters long
+ #
+ # MIME encoding increases 4/3*(number of bytes), and always in multiples
+ # of 4. Thus we have to find the best available value of bytes available
+ # for each chunk.
+ #
+ # First we get the integer max which max*4/3 would fit on space.
+ # Then we find the greater multiple of 3 lower or equal than $max.
+ my $max = int(
+ ( ( 75 - length( '=?' . $charset . '?' . $encoding . '?' . '?=' ) )
+ * 3
+ ) / 4
+ );
+ $max = int( $max / 3 ) * 3;
+
+ chomp $value;
+
+ if ( $max <= 0 ) {
+
+ # gives an error...
+ $RT::Logger->crit("Can't encode! Charset or encoding too big.");
+ return ($value);
+ }
+
+ return ($value) if $value =~ /^(?:[\t\x20-\x7e]|\x0D*\x0A[ \t])+$/s;
+
+ $value =~ s/\s+$//;
+
+ # we need perl string to split thing char by char
+ Encode::_utf8_on($value) unless Encode::is_utf8($value);
+
+ my ( $tmp, @chunks ) = ( '', () );
+ while ( length $value ) {
+ my $char = substr( $value, 0, 1, '' );
+ my $octets = Encode::encode( $charset, $char );
+ if ( length($tmp) + length($octets) > $max ) {
+ push @chunks, $tmp;
+ $tmp = '';
+ }
+ $tmp .= $octets;
+ }
+ push @chunks, $tmp if length $tmp;
+
+ # encode an join chuncks
+ $value = join "\n ",
+ map MIME::Words::encode_mimeword( $_, $encoding, $charset ),
+ @chunks;
+ return ($value);
+}
+
+sub CreateUser {
+ my ( $Username, $Address, $Name, $ErrorsTo, $entity ) = @_;
+
+ my $NewUser = RT::User->new( RT->SystemUser );
+
+ my ( $Val, $Message ) = $NewUser->Create(
+ Name => ( $Username || $Address ),
+ EmailAddress => $Address,
+ RealName => $Name,
+ Password => undef,
+ Privileged => 0,
+ Comments => 'Autocreated on ticket submission',
+ );
+
+ unless ($Val) {
+
+ # Deal with the race condition of two account creations at once
+ if ($Username) {
+ $NewUser->LoadByName($Username);
+ }
+
+ unless ( $NewUser->Id ) {
+ $NewUser->LoadByEmail($Address);
+ }
+
+ unless ( $NewUser->Id ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "User could not be created",
+ Explanation =>
+ "User creation failed in mailgateway: $Message",
+ MIMEObj => $entity,
+ LogLevel => 'crit',
+ );
+ }
+ }
+
+ #Load the new user object
+ my $CurrentUser = RT::CurrentUser->new;
+ $CurrentUser->LoadByEmail( $Address );
+
+ unless ( $CurrentUser->id ) {
+ $RT::Logger->warning(
+ "Couldn't load user '$Address'." . "giving up" );
+ MailError(
+ To => $ErrorsTo,
+ Subject => "User could not be loaded",
+ Explanation =>
+ "User '$Address' could not be loaded in the mail gateway",
+ MIMEObj => $entity,
+ LogLevel => 'crit'
+ );
+ }
+
+ return $CurrentUser;
+}
+
+
+
+=head2 ParseCcAddressesFromHead HASH
+
+Takes a hash containing QueueObj, Head and CurrentUser objects.
+Returns a list of all email addresses in the To and Cc
+headers b<except> the current Queue's email addresses, the CurrentUser's
+email address and anything that the configuration sub RT::IsRTAddress matches.
+
+=cut
+
+sub ParseCcAddressesFromHead {
+ my %args = (
+ Head => undef,
+ QueueObj => undef,
+ CurrentUser => undef,
+ @_
+ );
+
+ my $current_address = lc $args{'CurrentUser'}->EmailAddress;
+ my $user = $args{'CurrentUser'}->UserObj;
+
+ return
+ grep { $_ ne $current_address
+ && !RT::EmailParser->IsRTAddress( $_ )
+ && !IgnoreCcAddress( $_ )
+ }
+ map lc $user->CanonicalizeEmailAddress( $_->address ),
+ map RT::EmailParser->CleanupAddresses( Email::Address->parse( $args{'Head'}->get( $_ ) ) ),
+ qw(To Cc);
+}
+
+=head2 IgnoreCcAddress ADDRESS
+
+Returns true if ADDRESS matches the $IgnoreCcRegexp config variable.
+
+=cut
+
+sub IgnoreCcAddress {
+ my $address = shift;
+ if ( my $address_re = RT->Config->Get('IgnoreCcRegexp') ) {
+ return 1 if $address =~ /$address_re/i;
+ }
+ return undef;
+}
+
+=head2 ParseSenderAddressFromHead HEAD
+
+Takes a MIME::Header object. Returns (user@host, friendly name, errors)
+where the first two values are the From (evaluated in order of
+Reply-To:, From:, Sender).
+
+A list of error messages may be returned even when a Sender value is
+found, since it could be a parse error for another (checked earlier)
+sender field. In this case, the errors aren't fatal, but may be useful
+to investigate the parse failure.
+
+=cut
+
+sub ParseSenderAddressFromHead {
+ my $head = shift;
+ my @sender_headers = ('Reply-To', 'From', 'Sender');
+ my @errors; # Accumulate any errors
+
+ #Figure out who's sending this message.
+ foreach my $header ( @sender_headers ) {
+ my $addr_line = $head->get($header) || next;
+ my ($addr, $name) = ParseAddressFromHeader( $addr_line );
+ # only return if the address is not empty
+ return ($addr, $name, @errors) if $addr;
+
+ chomp $addr_line;
+ push @errors, "$header: $addr_line";
+ }
+
+ return (undef, undef, @errors);
+}
+
+=head2 ParseErrorsToAddressFromHead HEAD
+
+Takes a MIME::Header object. Return a single value : user@host
+of the From (evaluated in order of Return-path:,Errors-To:,Reply-To:,
+From:, Sender)
+
+=cut
+
+sub ParseErrorsToAddressFromHead {
+ my $head = shift;
+
+ #Figure out who's sending this message.
+
+ foreach my $header ( 'Errors-To', 'Reply-To', 'From', 'Sender' ) {
+
+ # If there's a header of that name
+ my $headerobj = $head->get($header);
+ if ($headerobj) {
+ my ( $addr, $name ) = ParseAddressFromHeader($headerobj);
+
+ # If it's got actual useful content...
+ return ($addr) if ($addr);
+ }
+ }
+}
+
+
+
+=head2 ParseAddressFromHeader ADDRESS
+
+Takes an address from C<$head->get('Line')> and returns a tuple: user@host, friendly name
+
+=cut
+
+sub ParseAddressFromHeader {
+ my $Addr = shift;
+
+ # Some broken mailers send: ""Vincent, Jesse"" <jesse@fsck.com>. Hate
+ $Addr =~ s/\"\"(.*?)\"\"/\"$1\"/g;
+ my @Addresses = RT::EmailParser->ParseEmailAddress($Addr);
+
+ my ($AddrObj) = grep ref $_, @Addresses;
+ unless ( $AddrObj ) {
+ return ( undef, undef );
+ }
+
+ return ( $AddrObj->address, $AddrObj->phrase );
+}
+
+=head2 DeleteRecipientsFromHead HEAD RECIPIENTS
+
+Gets a head object and list of addresses.
+Deletes addresses from To, Cc or Bcc fields.
+
+=cut
+
+sub DeleteRecipientsFromHead {
+ my $head = shift;
+ my %skip = map { lc $_ => 1 } @_;
+
+ foreach my $field ( qw(To Cc Bcc) ) {
+ $head->set( $field =>
+ join ', ', map $_->format, grep !$skip{ lc $_->address },
+ Email::Address->parse( $head->get( $field ) )
+ );
+ }
+}
+
+sub GenMessageId {
+ my %args = (
+ Ticket => undef,
+ Scrip => undef,
+ ScripAction => undef,
+ @_
+ );
+ my $org = RT->Config->Get('Organization');
+ my $ticket_id = ( ref $args{'Ticket'}? $args{'Ticket'}->id : $args{'Ticket'} ) || 0;
+ my $scrip_id = ( ref $args{'Scrip'}? $args{'Scrip'}->id : $args{'Scrip'} ) || 0;
+ my $sent = ( ref $args{'ScripAction'}? $args{'ScripAction'}->{'_Message_ID'} : 0 ) || 0;
+
+ return "<rt-". $RT::VERSION ."-". $$ ."-". CORE::time() ."-". int(rand(2000)) .'.'
+ . $ticket_id ."-". $scrip_id ."-". $sent ."@". $org .">" ;
+}
+
+sub SetInReplyTo {
+ my %args = (
+ Message => undef,
+ InReplyTo => undef,
+ Ticket => undef,
+ @_
+ );
+ return unless $args{'Message'} && $args{'InReplyTo'};
+
+ my $get_header = sub {
+ my @res;
+ if ( $args{'InReplyTo'}->isa('MIME::Entity') ) {
+ @res = $args{'InReplyTo'}->head->get( shift );
+ } else {
+ @res = $args{'InReplyTo'}->GetHeader( shift ) || '';
+ }
+ return grep length, map { split /\s+/m, $_ } grep defined, @res;
+ };
+
+ my @id = $get_header->('Message-ID');
+ #XXX: custom header should begin with X- otherwise is violation of the standard
+ my @rtid = $get_header->('RT-Message-ID');
+ my @references = $get_header->('References');
+ unless ( @references ) {
+ @references = $get_header->('In-Reply-To');
+ }
+ push @references, @id, @rtid;
+ if ( $args{'Ticket'} ) {
+ my $pseudo_ref = '<RT-Ticket-'. $args{'Ticket'}->id .'@'. RT->Config->Get('Organization') .'>';
+ push @references, $pseudo_ref unless grep $_ eq $pseudo_ref, @references;
+ }
+ @references = splice @references, 4, -6
+ if @references > 10;
+
+ my $mail = $args{'Message'};
+ $mail->head->set( 'In-Reply-To' => Encode::encode_utf8(join ' ', @rtid? (@rtid) : (@id)) ) if @id || @rtid;
+ $mail->head->set( 'References' => Encode::encode_utf8(join ' ', @references) );
+}
+
+sub ExtractTicketId {
+ my $entity = shift;
+
+ my $subject = $entity->head->get('Subject') || '';
+ chomp $subject;
+ return ParseTicketId( $subject );
+}
+
+sub ParseTicketId {
+ my $Subject = shift;
+
+ my $rtname = RT->Config->Get('rtname');
+ my $test_name = RT->Config->Get('EmailSubjectTagRegex') || qr/\Q$rtname\E/i;
+
+ my $id;
+ if ( $Subject =~ s/\[$test_name\s+\#(\d+)\s*\]//i ) {
+ $id = $1;
+ } else {
+ foreach my $tag ( RT->System->SubjectTag ) {
+ next unless $Subject =~ s/\[\Q$tag\E\s+\#(\d+)\s*\]//i;
+ $id = $1;
+ last;
+ }
+ }
+ return undef unless $id;
+
+ $RT::Logger->debug("Found a ticket ID. It's $id");
+ return $id;
+}
+
+sub AddSubjectTag {
+ my $subject = shift;
+ my $ticket = shift;
+ unless ( ref $ticket ) {
+ my $tmp = RT::Ticket->new( RT->SystemUser );
+ $tmp->Load( $ticket );
+ $ticket = $tmp;
+ }
+ my $id = $ticket->id;
+ my $queue_tag = $ticket->QueueObj->SubjectTag;
+
+ my $tag_re = RT->Config->Get('EmailSubjectTagRegex');
+ unless ( $tag_re ) {
+ my $tag = $queue_tag || RT->Config->Get('rtname');
+ $tag_re = qr/\Q$tag\E/;
+ } elsif ( $queue_tag ) {
+ $tag_re = qr/$tag_re|\Q$queue_tag\E/;
+ }
+ return $subject if $subject =~ /\[$tag_re\s+#$id\]/;
+
+ $subject =~ s/(\r\n|\n|\s)/ /g;
+ chomp $subject;
+ return "[". ($queue_tag || RT->Config->Get('rtname')) ." #$id] $subject";
+}
+
+
+=head2 Gateway ARGSREF
+
+
+Takes parameters:
+
+ action
+ queue
+ message
+
+
+This performs all the "guts" of the mail rt-mailgate program, and is
+designed to be called from the web interface with a message, user
+object, and so on.
+
+Can also take an optional 'ticket' parameter; this ticket id overrides
+any ticket id found in the subject.
+
+Returns:
+
+ An array of:
+
+ (status code, message, optional ticket object)
+
+ status code is a numeric value.
+
+ for temporary failures, the status code should be -75
+
+ for permanent failures which are handled by RT, the status code
+ should be 0
+
+ for succces, the status code should be 1
+
+
+
+=cut
+
+sub _LoadPlugins {
+ my @mail_plugins = @_;
+
+ my @res;
+ foreach my $plugin (@mail_plugins) {
+ if ( ref($plugin) eq "CODE" ) {
+ push @res, $plugin;
+ } elsif ( !ref $plugin ) {
+ my $Class = $plugin;
+ $Class = "RT::Interface::Email::" . $Class
+ unless $Class =~ /^RT::/;
+ $Class->require or
+ do { $RT::Logger->error("Couldn't load $Class: $@"); next };
+
+ no strict 'refs';
+ unless ( defined *{ $Class . "::GetCurrentUser" }{CODE} ) {
+ $RT::Logger->crit( "No GetCurrentUser code found in $Class module");
+ next;
+ }
+ push @res, $Class;
+ } else {
+ $RT::Logger->crit( "$plugin - is not class name or code reference");
+ }
+ }
+ return @res;
+}
+
+sub Gateway {
+ my $argsref = shift;
+ my %args = (
+ action => 'correspond',
+ queue => '1',
+ ticket => undef,
+ message => undef,
+ %$argsref
+ );
+
+ my $SystemTicket;
+ my $Right;
+
+ # Validate the action
+ my ( $status, @actions ) = IsCorrectAction( $args{'action'} );
+ unless ($status) {
+ return (
+ -75,
+ "Invalid 'action' parameter "
+ . $actions[0]
+ . " for queue "
+ . $args{'queue'},
+ undef
+ );
+ }
+
+ my $parser = RT::EmailParser->new();
+ $parser->SmartParseMIMEEntityFromScalar(
+ Message => $args{'message'},
+ Decode => 0,
+ Exact => 1,
+ );
+
+ my $Message = $parser->Entity();
+ unless ($Message) {
+ MailError(
+ Subject => "RT Bounce: Unparseable message",
+ Explanation => "RT couldn't process the message below",
+ Attach => $args{'message'}
+ );
+
+ return ( 0,
+ "Failed to parse this message. Something is likely badly wrong with the message"
+ );
+ }
+
+ my @mail_plugins = grep $_, RT->Config->Get('MailPlugins');
+ push @mail_plugins, "Auth::MailFrom" unless @mail_plugins;
+ @mail_plugins = _LoadPlugins( @mail_plugins );
+
+ my %skip_plugin;
+ foreach my $class( grep !ref, @mail_plugins ) {
+ # check if we should apply filter before decoding
+ my $check_cb = do {
+ no strict 'refs';
+ *{ $class . "::ApplyBeforeDecode" }{CODE};
+ };
+ next unless defined $check_cb;
+ next unless $check_cb->(
+ Message => $Message,
+ RawMessageRef => \$args{'message'},
+ );
+
+ $skip_plugin{ $class }++;
+
+ my $Code = do {
+ no strict 'refs';
+ *{ $class . "::GetCurrentUser" }{CODE};
+ };
+ my ($status, $msg) = $Code->(
+ Message => $Message,
+ RawMessageRef => \$args{'message'},
+ );
+ next if $status > 0;
+
+ if ( $status == -2 ) {
+ return (1, $msg, undef);
+ } elsif ( $status == -1 ) {
+ return (0, $msg, undef);
+ }
+ }
+ @mail_plugins = grep !$skip_plugin{"$_"}, @mail_plugins;
+ $parser->_DecodeBodies;
+ $parser->RescueOutlook;
+ $parser->_PostProcessNewEntity;
+
+ my $head = $Message->head;
+ my $ErrorsTo = ParseErrorsToAddressFromHead( $head );
+ my $Sender = (ParseSenderAddressFromHead( $head ))[0];
+ my $From = $head->get("From");
+ chomp $From if defined $From;
+
+ my $MessageId = $head->get('Message-ID')
+ || "<no-message-id-". time . rand(2000) .'@'. RT->Config->Get('Organization') .'>';
+
+ #Pull apart the subject line
+ my $Subject = $head->get('Subject') || '';
+ chomp $Subject;
+
+ # Lets check for mail loops of various sorts.
+ my ($should_store_machine_generated_message, $IsALoop, $result);
+ ( $should_store_machine_generated_message, $ErrorsTo, $result, $IsALoop ) =
+ _HandleMachineGeneratedMail(
+ Message => $Message,
+ ErrorsTo => $ErrorsTo,
+ Subject => $Subject,
+ MessageId => $MessageId
+ );
+
+ # Do not pass loop messages to MailPlugins, to make sure the loop
+ # is broken, unless $RT::StoreLoops is set.
+ if ($IsALoop && !$should_store_machine_generated_message) {
+ return ( 0, $result, undef );
+ }
+ # }}}
+
+ $args{'ticket'} ||= ExtractTicketId( $Message );
+
+ # ExtractTicketId may have been overridden, and edited the Subject
+ my $NewSubject = $Message->head->get('Subject');
+ chomp $NewSubject;
+
+ $SystemTicket = RT::Ticket->new( RT->SystemUser );
+ $SystemTicket->Load( $args{'ticket'} ) if ( $args{'ticket'} ) ;
+ if ( $SystemTicket->id ) {
+ $Right = 'ReplyToTicket';
+ } else {
+ $Right = 'CreateTicket';
+ }
+
+ #Set up a queue object
+ my $SystemQueueObj = RT::Queue->new( RT->SystemUser );
+ $SystemQueueObj->Load( $args{'queue'} );
+
+ # We can safely have no queue of we have a known-good ticket
+ unless ( $SystemTicket->id || $SystemQueueObj->id ) {
+ return ( -75, "RT couldn't find the queue: " . $args{'queue'}, undef );
+ }
+
+ my ($AuthStat, $CurrentUser, $error) = GetAuthenticationLevel(
+ MailPlugins => \@mail_plugins,
+ Actions => \@actions,
+ Message => $Message,
+ RawMessageRef => \$args{message},
+ SystemTicket => $SystemTicket,
+ SystemQueue => $SystemQueueObj,
+ );
+
+ # If authentication fails and no new user was created, get out.
+ if ( !$CurrentUser || !$CurrentUser->id || $AuthStat == -1 ) {
+
+ # If the plugins refused to create one, they lose.
+ unless ( $AuthStat == -1 ) {
+ _NoAuthorizedUserFound(
+ Right => $Right,
+ Message => $Message,
+ Requestor => $ErrorsTo,
+ Queue => $args{'queue'}
+ );
+
+ }
+ return ( 0, "Could not load a valid user", undef );
+ }
+
+ # If we got a user, but they don't have the right to say things
+ if ( $AuthStat == 0 ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Permission Denied",
+ Explanation =>
+ "You do not have permission to communicate with RT",
+ MIMEObj => $Message
+ );
+ return (
+ 0,
+ ($CurrentUser->EmailAddress || $CurrentUser->Name)
+ . " ($Sender) tried to submit a message to "
+ . $args{'Queue'}
+ . " without permission.",
+ undef
+ );
+ }
+
+
+ unless ($should_store_machine_generated_message) {
+ return ( 0, $result, undef );
+ }
+
+ # if plugin's updated SystemTicket then update arguments
+ $args{'ticket'} = $SystemTicket->Id if $SystemTicket && $SystemTicket->Id;
+
+ my $Ticket = RT::Ticket->new($CurrentUser);
+
+ if ( !$args{'ticket'} && grep /^(comment|correspond)$/, @actions )
+ {
+
+ my @Cc;
+ my @Requestors = ( $CurrentUser->id );
+
+ if (RT->Config->Get('ParseNewMessageForTicketCcs')) {
+ @Cc = ParseCcAddressesFromHead(
+ Head => $head,
+ CurrentUser => $CurrentUser,
+ QueueObj => $SystemQueueObj
+ );
+ }
+
+ $head->replace('X-RT-Interface' => 'Email');
+
+ my ( $id, $Transaction, $ErrStr ) = $Ticket->Create(
+ Queue => $SystemQueueObj->Id,
+ Subject => $NewSubject,
+ Requestor => \@Requestors,
+ Cc => \@Cc,
+ MIMEObj => $Message
+ );
+ if ( $id == 0 ) {
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Ticket creation failed: $Subject",
+ Explanation => $ErrStr,
+ MIMEObj => $Message
+ );
+ return ( 0, "Ticket creation From: $From failed: $ErrStr", $Ticket );
+ }
+
+ # strip comments&corresponds from the actions we don't need
+ # to record them if we've created the ticket just now
+ @actions = grep !/^(comment|correspond)$/, @actions;
+ $args{'ticket'} = $id;
+
+ } elsif ( $args{'ticket'} ) {
+
+ $Ticket->Load( $args{'ticket'} );
+ unless ( $Ticket->Id ) {
+ my $error = "Could not find a ticket with id " . $args{'ticket'};
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Message not recorded: $Subject",
+ Explanation => $error,
+ MIMEObj => $Message
+ );
+
+ return ( 0, $error );
+ }
+ $args{'ticket'} = $Ticket->id;
+ } else {
+ return ( 1, "Success", $Ticket );
+ }
+
+ # }}}
+
+ my $unsafe_actions = RT->Config->Get('UnsafeEmailCommands');
+ foreach my $action (@actions) {
+
+ # If the action is comment, add a comment.
+ if ( $action =~ /^(?:comment|correspond)$/i ) {
+ my $method = ucfirst lc $action;
+ my ( $status, $msg ) = $Ticket->$method( MIMEObj => $Message );
+ unless ($status) {
+
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError(
+ To => $ErrorsTo,
+ Subject => "Message not recorded ($method): $Subject",
+ Explanation => $msg,
+ MIMEObj => $Message
+ );
+ return ( 0, "Message From: $From not recorded: $msg", $Ticket );
+ }
+ } elsif ($unsafe_actions) {
+ my ( $status, $msg ) = _RunUnsafeAction(
+ Action => $action,
+ ErrorsTo => $ErrorsTo,
+ Message => $Message,
+ Ticket => $Ticket,
+ CurrentUser => $CurrentUser,
+ );
+ return ($status, $msg, $Ticket) unless $status == 1;
+ }
+ }
+ return ( 1, "Success", $Ticket );
+}
+
+=head2 GetAuthenticationLevel
+
+ # Authentication Level
+ # -1 - Get out. this user has been explicitly declined
+ # 0 - User may not do anything (Not used at the moment)
+ # 1 - Normal user
+ # 2 - User is allowed to specify status updates etc. a la enhanced-mailgate
+
+=cut
+
+sub GetAuthenticationLevel {
+ my %args = (
+ MailPlugins => [],
+ Actions => [],
+ Message => undef,
+ RawMessageRef => undef,
+ SystemTicket => undef,
+ SystemQueue => undef,
+ @_,
+ );
+
+ my ( $CurrentUser, $AuthStat, $error );
+
+ # Initalize AuthStat so comparisons work correctly
+ $AuthStat = -9999999;
+
+ # if plugin returns AuthStat -2 we skip action
+ # NOTE: this is experimental API and it would be changed
+ my %skip_action = ();
+
+ # Since this needs loading, no matter what
+ foreach (@{ $args{MailPlugins} }) {
+ my ($Code, $NewAuthStat);
+ if ( ref($_) eq "CODE" ) {
+ $Code = $_;
+ } else {
+ no strict 'refs';
+ $Code = *{ $_ . "::GetCurrentUser" }{CODE};
+ }
+
+ foreach my $action (@{ $args{Actions} }) {
+ ( $CurrentUser, $NewAuthStat ) = $Code->(
+ Message => $args{Message},
+ RawMessageRef => $args{RawMessageRef},
+ CurrentUser => $CurrentUser,
+ AuthLevel => $AuthStat,
+ Action => $action,
+ Ticket => $args{SystemTicket},
+ Queue => $args{SystemQueue},
+ );
+
+# You get the highest level of authentication you were assigned, unless you get the magic -1
+# If a module returns a "-1" then we discard the ticket, so.
+ $AuthStat = $NewAuthStat
+ if ( $NewAuthStat > $AuthStat or $NewAuthStat == -1 or $NewAuthStat == -2 );
+
+ last if $AuthStat == -1;
+ $skip_action{$action}++ if $AuthStat == -2;
+ }
+
+ # strip actions we should skip
+ @{$args{Actions}} = grep !$skip_action{$_}, @{$args{Actions}}
+ if $AuthStat == -2;
+ last unless @{$args{Actions}};
+
+ last if $AuthStat == -1;
+ }
+
+ return $AuthStat if !wantarray;
+
+ return ($AuthStat, $CurrentUser, $error);
+}
+
+sub _RunUnsafeAction {
+ my %args = (
+ Action => undef,
+ ErrorsTo => undef,
+ Message => undef,
+ Ticket => undef,
+ CurrentUser => undef,
+ @_
+ );
+
+ my $From = $args{Message}->head->get("From");
+
+ if ( $args{'Action'} =~ /^take$/i ) {
+ my ( $status, $msg ) = $args{'Ticket'}->SetOwner( $args{'CurrentUser'}->id );
+ unless ($status) {
+ MailError(
+ To => $args{'ErrorsTo'},
+ Subject => "Ticket not taken",
+ Explanation => $msg,
+ MIMEObj => $args{'Message'}
+ );
+ return ( 0, "Ticket not taken, by email From: $From" );
+ }
+ } elsif ( $args{'Action'} =~ /^resolve$/i ) {
+ my $new_status = $args{'Ticket'}->FirstInactiveStatus;
+ if ($new_status) {
+ my ( $status, $msg ) = $args{'Ticket'}->SetStatus($new_status);
+ unless ($status) {
+
+ #Warn the sender that we couldn't actually submit the comment.
+ MailError(
+ To => $args{'ErrorsTo'},
+ Subject => "Ticket not resolved",
+ Explanation => $msg,
+ MIMEObj => $args{'Message'}
+ );
+ return ( 0, "Ticket not resolved, by email From: $From" );
+ }
+ }
+ } else {
+ return ( 0, "Not supported unsafe action $args{'Action'}, by email From: $From", $args{'Ticket'} );
+ }
+ return ( 1, "Success" );
+}
+
+=head2 _NoAuthorizedUserFound
+
+Emails the RT Owner and the requestor when the auth plugins return "No auth user found"
+
+=cut
+
+sub _NoAuthorizedUserFound {
+ my %args = (
+ Right => undef,
+ Message => undef,
+ Requestor => undef,
+ Queue => undef,
+ @_
+ );
+
+ # Notify the RT Admin of the failure.
+ MailError(
+ To => RT->Config->Get('OwnerEmail'),
+ Subject => "Could not load a valid user",
+ Explanation => <<EOT,
+RT could not load a valid user, and RT's configuration does not allow
+for the creation of a new user for this email (@{[$args{Requestor}]}).
+
+You might need to grant 'Everyone' the right '@{[$args{Right}]}' for the
+queue @{[$args{'Queue'}]}.
+
+EOT
+ MIMEObj => $args{'Message'},
+ LogLevel => 'error'
+ );
+
+ # Also notify the requestor that his request has been dropped.
+ if ($args{'Requestor'} ne RT->Config->Get('OwnerEmail')) {
+ MailError(
+ To => $args{'Requestor'},
+ Subject => "Could not load a valid user",
+ Explanation => <<EOT,
+RT could not load a valid user, and RT's configuration does not allow
+for the creation of a new user for your email.
+
+EOT
+ MIMEObj => $args{'Message'},
+ LogLevel => 'error'
+ );
+ }
+}
+
+=head2 _HandleMachineGeneratedMail
+
+Takes named params:
+ Message
+ ErrorsTo
+ Subject
+
+Checks the message to see if it's a bounce, if it looks like a loop, if it's autogenerated, etc.
+Returns a triple of ("Should we continue (boolean)", "New value for $ErrorsTo", "Status message",
+"This message appears to be a loop (boolean)" );
+
+=cut
+
+sub _HandleMachineGeneratedMail {
+ my %args = ( Message => undef, ErrorsTo => undef, Subject => undef, MessageId => undef, @_ );
+ my $head = $args{'Message'}->head;
+ my $ErrorsTo = $args{'ErrorsTo'};
+
+ my $IsBounce = CheckForBounce($head);
+
+ my $IsAutoGenerated = CheckForAutoGenerated($head);
+
+ my $IsSuspiciousSender = CheckForSuspiciousSender($head);
+
+ my $IsALoop = CheckForLoops($head);
+
+ my $SquelchReplies = 0;
+
+ my $owner_mail = RT->Config->Get('OwnerEmail');
+
+ #If the message is autogenerated, we need to know, so we can not
+ # send mail to the sender
+ if ( $IsBounce || $IsSuspiciousSender || $IsAutoGenerated || $IsALoop ) {
+ $SquelchReplies = 1;
+ $ErrorsTo = $owner_mail;
+ }
+
+ # Warn someone if it's a loop, before we drop it on the ground
+ if ($IsALoop) {
+ $RT::Logger->crit("RT Received mail (".$args{MessageId}.") from itself.");
+
+ #Should we mail it to RTOwner?
+ if ( RT->Config->Get('LoopsToRTOwner') ) {
+ MailError(
+ To => $owner_mail,
+ Subject => "RT Bounce: ".$args{'Subject'},
+ Explanation => "RT thinks this message may be a bounce",
+ MIMEObj => $args{Message}
+ );
+ }
+
+ #Do we actually want to store it?
+ return ( 0, $ErrorsTo, "Message Bounced", $IsALoop )
+ unless RT->Config->Get('StoreLoops');
+ }
+
+ # Squelch replies if necessary
+ # Don't let the user stuff the RT-Squelch-Replies-To header.
+ if ( $head->get('RT-Squelch-Replies-To') ) {
+ $head->replace(
+ 'RT-Relocated-Squelch-Replies-To',
+ $head->get('RT-Squelch-Replies-To')
+ );
+ $head->delete('RT-Squelch-Replies-To');
+ }
+
+ if ($SquelchReplies) {
+
+ # Squelch replies to the sender, and also leave a clue to
+ # allow us to squelch ALL outbound messages. This way we
+ # can punt the logic of "what to do when we get a bounce"
+ # to the scrip. We might want to notify nobody. Or just
+ # the RT Owner. Or maybe all Privileged watchers.
+ my ( $Sender, $junk ) = ParseSenderAddressFromHead($head);
+ $head->replace( 'RT-Squelch-Replies-To', $Sender );
+ $head->replace( 'RT-DetectedAutoGenerated', 'true' );
+ }
+ return ( 1, $ErrorsTo, "Handled machine detection", $IsALoop );
+}
+
+=head2 IsCorrectAction
+
+Returns a list of valid actions we've found for this message
+
+=cut
+
+sub IsCorrectAction {
+ my $action = shift;
+ my @actions = grep $_, split /-/, $action;
+ return ( 0, '(no value)' ) unless @actions;
+ foreach ( @actions ) {
+ return ( 0, $_ ) unless /^(?:comment|correspond|take|resolve)$/;
+ }
+ return ( 1, @actions );
+}
+
+sub _RecordSendEmailFailure {
+ my $ticket = shift;
+ if ($ticket) {
+ $ticket->_RecordNote(
+ NoteType => 'SystemError',
+ Content => "Sending the previous mail has failed. Please contact your admin, they can find more details in the logs.",
+ );
+ return 1;
+ }
+ else {
+ $RT::Logger->error( "Can't record send email failure as ticket is missing" );
+ return;
+ }
+}
+
+RT::Base->_ImportOverlays();
+
+1;
foreach my $part ( $args{'Message'}->parts_DFS ) {
my $decrypted;
- my $status = $part->head->get( 'X-RT-GnuPG-Status' );
+ my $status = Encode::decode( "UTF-8", $part->head->get( 'X-RT-GnuPG-Status' ) );
if ( $status ) {
for ( RT::Crypt::GnuPG::ParseStatus( $status ) ) {
if ( $_->{Operation} eq 'Decrypt' && $_->{Status} eq 'DONE' ) {
}
if ( $_->{Operation} eq 'Verify' && $_->{Status} eq 'DONE' ) {
$part->head->replace(
- 'X-RT-Incoming-Signature' => $_->{UserString}
+ 'X-RT-Incoming-Signature' => Encode::encode( "UTF-8", $_->{UserString} )
);
}
}
use RT::Interface::Web::Menu;
use RT::Interface::Web::Session;
use Digest::MD5 ();
-use Encode qw();
use List::MoreUtils qw();
use JSON qw();
sub DecodeARGS {
my $ARGS = shift;
+ # Later in the code we use
+ # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
+ # instead of $m->call_next to avoid problems with UTF8 keys in
+ # arguments. Specifically, the call_next method pass through
+ # original arguments, which are still the encoded bytes, not
+ # characters. "{ base_comp => $m->request_comp }" is copied from
+ # mason's source to get the same results as we get from call_next
+ # method; this feature is not documented.
%{$ARGS} = map {
# if they've passed multiple values, they'll be an array. if they've
# passed just one, a scalar whatever they are, mark them as utf8
my $type = ref($_);
( !$type )
- ? Encode::is_utf8($_)
- ? $_
- : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
+ ? Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ )
: ( $type eq 'ARRAY' )
- ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
- @$_ ]
+ ? [ map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } @$_ ]
: ( $type eq 'HASH' )
- ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
- %$_ }
+ ? { map { ref($_) ? $_ : Encode::decode( 'UTF-8', $_, Encode::FB_PERLQQ ) } %$_ }
: $_
} %$ARGS;
}
sub PreprocessTimeUpdates {
my $ARGS = shift;
- # Later in the code we use
- # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
- # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
- # The call_next method pass through original arguments and if you have
- # an argument with unicode key then in a next component you'll get two
- # records in the args hash: one with key without UTF8 flag and another
- # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
- # is copied from mason's source to get the same results as we get from
- # call_next method, this feature is not documented, so we just leave it
- # here to avoid possible side effects.
-
# This code canonicalizes time inputs in hours into minutes
foreach my $field ( keys %$ARGS ) {
next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
if ($ARGS->{Attach}) {
my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
my $file_path = delete $ARGS->{'Attach'};
+
+ # This needs to be decoded because the value is a reference;
+ # hence it was not decoded along with all of the standard
+ # arguments in DecodeARGS
$data->{attach} = {
- filename => Encode::decode_utf8("$file_path"),
+ filename => Encode::decode("UTF-8", "$file_path"),
mime => $attachment,
};
}
Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
);
- $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
+ $Message->head->replace( 'Message-ID' => Encode::encode( "UTF-8",
RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
) );
my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
{ # attachment?
my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
- my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
+ # This needs to be decoded because the value is a reference;
+ # hence it was not decoded along with all of the standard
+ # arguments in DecodeARGS
+ my $file_path = Encode::decode("UTF-8", "$ARGSRef->{'Attach'}");
$session{'Attachments'} =
{ %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
}
);
my $Message = MIME::Entity->build(
Type => 'multipart/mixed',
- "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
+ "Message-Id" => Encode::encode( "UTF-8", RT::Interface::Email::GenMessageId ),
"X-RT-Interface" => $args{Interface},
- map { $_ => Encode::encode_utf8( $args{ $_} ) }
+ map { $_ => Encode::encode( "UTF-8", $args{ $_} ) }
grep defined $args{$_}, qw(Subject From Cc)
);
$Message->attach(
Type => $args{'Type'} || 'text/plain',
Charset => 'UTF-8',
- Data => $args{'Body'},
+ Data => Encode::encode( "UTF-8", $args{'Body'} ),
);
}
my $uploadinfo = $cgi_object->uploadInfo($filehandle);
- my $filename = "$filehandle";
+ my $filename = Encode::decode("UTF-8","$filehandle");
$filename =~ s{^.*[\\/]}{};
$Message->attach(
Type => $uploadinfo->{'Content-Type'},
- Filename => $filename,
- Data => \@content,
+ Filename => Encode::encode("UTF-8",$filename),
+ Data => \@content, # Bytes, as read directly from the file, above
);
if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
- $Message->head->set( 'Subject' => $filename );
+ $Message->head->set( 'Subject' => Encode::encode( "UTF-8", $filename ) );
}
# Attachment parts really shouldn't get a Message-ID or "interface"
--- /dev/null
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2014 Best Practical Solutions, LLC
+# <sales@bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
+
+## This is a library of static subs to be used by the Mason web
+## interface to RT
+
+=head1 NAME
+
+RT::Interface::Web
+
+
+=cut
+
+use strict;
+use warnings;
+
+package RT::Interface::Web;
+
+use RT::SavedSearches;
+use URI qw();
+use RT::Interface::Web::Menu;
+use RT::Interface::Web::Session;
+use Digest::MD5 ();
+use Encode qw();
+use List::MoreUtils qw();
+use JSON qw();
+
+=head2 SquishedCSS $style
+
+=cut
+
+my %SQUISHED_CSS;
+sub SquishedCSS {
+ my $style = shift or die "need name";
+ return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
+ require RT::Squish::CSS;
+ my $css = RT::Squish::CSS->new( Style => $style );
+ $SQUISHED_CSS{ $css->Style } = $css;
+ return $css;
+}
+
+=head2 SquishedJS
+
+=cut
+
+my $SQUISHED_JS;
+sub SquishedJS {
+ return $SQUISHED_JS if $SQUISHED_JS;
+
+ require RT::Squish::JS;
+ my $js = RT::Squish::JS->new();
+ $SQUISHED_JS = $js;
+ return $js;
+}
+
+=head2 ClearSquished
+
+Removes the cached CSS and JS entries, forcing them to be regenerated
+on next use.
+
+=cut
+
+sub ClearSquished {
+ undef $SQUISHED_JS;
+ %SQUISHED_CSS = ();
+}
+
+=head2 EscapeUTF8 SCALARREF
+
+does a css-busting but minimalist escaping of whatever html you're passing in.
+
+=cut
+
+sub EscapeUTF8 {
+ my $ref = shift;
+ return unless defined $$ref;
+
+ $$ref =~ s/&/&/g;
+ $$ref =~ s/</</g;
+ $$ref =~ s/>/>/g;
+ $$ref =~ s/\(/(/g;
+ $$ref =~ s/\)/)/g;
+ $$ref =~ s/"/"/g;
+ $$ref =~ s/'/'/g;
+}
+
+
+
+=head2 EscapeURI SCALARREF
+
+Escapes URI component according to RFC2396
+
+=cut
+
+sub EscapeURI {
+ my $ref = shift;
+ return unless defined $$ref;
+
+ use bytes;
+ $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
+}
+
+=head2 EncodeJSON SCALAR
+
+Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
+value or a reference.
+
+=cut
+
+sub EncodeJSON {
+ JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
+}
+
+sub _encode_surrogates {
+ my $uni = $_[0] - 0x10000;
+ return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
+}
+
+sub EscapeJS {
+ my $ref = shift;
+ return unless defined $$ref;
+
+ $$ref = "'" . join('',
+ map {
+ chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
+ $_ <= 255 ? sprintf("\\x%02X", $_) :
+ $_ <= 65535 ? sprintf("\\u%04X", $_) :
+ sprintf("\\u%X\\u%X", _encode_surrogates($_))
+ } unpack('U*', $$ref))
+ . "'";
+}
+
+=head2 WebCanonicalizeInfo();
+
+Different web servers set different environmental varibles. This
+function must return something suitable for REMOTE_USER. By default,
+just downcase $ENV{'REMOTE_USER'}
+
+=cut
+
+sub WebCanonicalizeInfo {
+ return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
+}
+
+
+
+=head2 WebExternalAutoInfo($user);
+
+Returns a hash of user attributes, used when WebExternalAuto is set.
+
+=cut
+
+sub WebExternalAutoInfo {
+ my $user = shift;
+
+ my %user_info;
+
+ # default to making Privileged users, even if they specify
+ # some other default Attributes
+ if ( !$RT::AutoCreate
+ || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
+ {
+ $user_info{'Privileged'} = 1;
+ }
+
+ if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
+
+ # Populate fields with information from Unix /etc/passwd
+
+ my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
+ $user_info{'Comments'} = $comments if defined $comments;
+ $user_info{'RealName'} = $realname if defined $realname;
+ } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
+
+ # Populate fields with information from NT domain controller
+ }
+
+ # and return the wad of stuff
+ return {%user_info};
+}
+
+
+sub HandleRequest {
+ my $ARGS = shift;
+
+ if (RT->Config->Get('DevelMode')) {
+ require Module::Refresh;
+ Module::Refresh->refresh;
+ }
+
+ $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
+
+ $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
+
+ # Roll back any dangling transactions from a previous failed connection
+ $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
+
+ MaybeEnableSQLStatementLog();
+
+ # avoid reentrancy, as suggested by masonbook
+ local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
+
+ $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
+ if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
+
+ ValidateWebConfig();
+
+ DecodeARGS($ARGS);
+ local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
+ PreprocessTimeUpdates($ARGS);
+
+ InitializeMenu();
+ MaybeShowInstallModePage();
+
+ $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
+ SendSessionCookie();
+
+ if ( _UserLoggedIn() ) {
+ # make user info up to date
+ $HTML::Mason::Commands::session{'CurrentUser'}
+ ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
+ undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
+ }
+ else {
+ $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
+ }
+
+ # Process session-related callbacks before any auth attempts
+ $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
+
+ MaybeRejectPrivateComponentRequest();
+
+ MaybeShowNoAuthPage($ARGS);
+
+ AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
+
+ _ForceLogout() unless _UserLoggedIn();
+
+ # Process per-page authentication callbacks
+ $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
+
+ if ( $ARGS->{'NotMobile'} ) {
+ $HTML::Mason::Commands::session{'NotMobile'} = 1;
+ }
+
+ unless ( _UserLoggedIn() ) {
+ _ForceLogout();
+
+ # Authenticate if the user is trying to login via user/pass query args
+ my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
+
+ unless ($authed) {
+ my $m = $HTML::Mason::Commands::m;
+
+ # REST urls get a special 401 response
+ if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
+ $HTML::Mason::Commands::r->content_type("text/plain");
+ $m->error_format("text");
+ $m->out("RT/$RT::VERSION 401 Credentials required\n");
+ $m->out("\n$msg\n") if $msg;
+ $m->abort;
+ }
+ # Specially handle /index.html and /m/index.html so that we get a nicer URL
+ elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
+ my $mobile = $1 ? 1 : 0;
+ my $next = SetNextPage($ARGS);
+ $m->comp('/NoAuth/Login.html',
+ next => $next,
+ actions => [$msg],
+ mobile => $mobile);
+ $m->abort;
+ }
+ else {
+ TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
+ }
+ }
+ }
+
+ MaybeShowInterstitialCSRFPage($ARGS);
+
+ # now it applies not only to home page, but any dashboard that can be used as a workspace
+ $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
+ if ( $ARGS->{'HomeRefreshInterval'} );
+
+ # Process per-page global callbacks
+ $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
+
+ ShowRequestedPage($ARGS);
+ LogRecordedSQLStatements(RequestData => {
+ Path => $HTML::Mason::Commands::m->request_path,
+ });
+
+ # Process per-page final cleanup callbacks
+ $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
+
+ $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
+ unless $HTML::Mason::Commands::r->content_type
+ =~ qr<^(text|application)/(x-)?(css|javascript)>;
+}
+
+sub _ForceLogout {
+
+ delete $HTML::Mason::Commands::session{'CurrentUser'};
+}
+
+sub _UserLoggedIn {
+ if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
+ return 1;
+ } else {
+ return undef;
+ }
+
+}
+
+=head2 LoginError ERROR
+
+Pushes a login error into the Actions session store and returns the hash key.
+
+=cut
+
+sub LoginError {
+ my $new = shift;
+ my $key = Digest::MD5::md5_hex( rand(1024) );
+ push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
+ $HTML::Mason::Commands::session{'i'}++;
+ return $key;
+}
+
+=head2 SetNextPage ARGSRef [PATH]
+
+Intuits and stashes the next page in the sesssion hash. If PATH is
+specified, uses that instead of the value of L<IntuitNextPage()>. Returns
+the hash value.
+
+=cut
+
+sub SetNextPage {
+ my $ARGS = shift;
+ my $next = $_[0] ? $_[0] : IntuitNextPage();
+ my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
+ my $page = { url => $next };
+
+ # If an explicit URL was passed and we didn't IntuitNextPage, then
+ # IsPossibleCSRF below is almost certainly unrelated to the actual
+ # destination. Currently explicit next pages aren't used in RT, but the
+ # API is available.
+ if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
+ # This isn't really CSRF, but the CSRF heuristics are useful for catching
+ # requests which may have unintended side-effects.
+ my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
+ if ($is_csrf) {
+ RT->Logger->notice(
+ "Marking original destination as having side-effects before redirecting for login.\n"
+ ."Request: $next\n"
+ ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
+ );
+ $page->{'HasSideEffects'} = [$msg, @loc];
+ }
+ }
+
+ $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
+ $HTML::Mason::Commands::session{'i'}++;
+ return $hash;
+}
+
+=head2 FetchNextPage HASHKEY
+
+Returns the stashed next page hashref for the given hash.
+
+=cut
+
+sub FetchNextPage {
+ my $hash = shift || "";
+ return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
+}
+
+=head2 RemoveNextPage HASHKEY
+
+Removes the stashed next page for the given hash and returns it.
+
+=cut
+
+sub RemoveNextPage {
+ my $hash = shift || "";
+ return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
+}
+
+=head2 TangentForLogin ARGSRef [HASH]
+
+Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
+the next page. Takes a hashref of request %ARGS as the first parameter.
+Optionally takes all other parameters as a hash which is dumped into query
+params.
+
+=cut
+
+sub TangentForLogin {
+ my $ARGS = shift;
+ my $hash = SetNextPage($ARGS);
+ my %query = (@_, next => $hash);
+
+ $query{mobile} = 1
+ if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
+
+ my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
+ $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
+ Redirect($login);
+}
+
+=head2 TangentForLoginWithError ERROR
+
+Localizes the passed error message, stashes it with L<LoginError> and then
+calls L<TangentForLogin> with the appropriate results key.
+
+=cut
+
+sub TangentForLoginWithError {
+ my $ARGS = shift;
+ my $key = LoginError(HTML::Mason::Commands::loc(@_));
+ TangentForLogin( $ARGS, results => $key );
+}
+
+=head2 IntuitNextPage
+
+Attempt to figure out the path to which we should return the user after a
+tangent. The current request URL is used, or failing that, the C<WebURL>
+configuration variable.
+
+=cut
+
+sub IntuitNextPage {
+ my $req_uri;
+
+ # This includes any query parameters. Redirect will take care of making
+ # it an absolute URL.
+ if ($ENV{'REQUEST_URI'}) {
+ $req_uri = $ENV{'REQUEST_URI'};
+
+ # collapse multiple leading slashes so the first part doesn't look like
+ # a hostname of a schema-less URI
+ $req_uri =~ s{^/+}{/};
+ }
+
+ my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
+
+ # sanitize $next
+ my $uri = URI->new($next);
+
+ # You get undef scheme with a relative uri like "/Search/Build.html"
+ unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
+ $next = RT->Config->Get('WebURL');
+ }
+
+ # Make sure we're logging in to the same domain
+ # You can get an undef authority with a relative uri like "index.html"
+ my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
+ unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
+ $next = RT->Config->Get('WebURL');
+ }
+
+ return $next;
+}
+
+=head2 MaybeShowInstallModePage
+
+This function, called exclusively by RT's autohandler, dispatches
+a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
+
+If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
+
+=cut
+
+sub MaybeShowInstallModePage {
+ return unless RT->InstallMode;
+
+ my $m = $HTML::Mason::Commands::m;
+ if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
+ $m->call_next();
+ } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
+ RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
+ } else {
+ $m->call_next();
+ }
+ $m->abort();
+}
+
+=head2 MaybeShowNoAuthPage \%ARGS
+
+This function, called exclusively by RT's autohandler, dispatches
+a request to the page a user requested (but only if it matches the "noauth" regex.
+
+If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
+
+=cut
+
+sub MaybeShowNoAuthPage {
+ my $ARGS = shift;
+
+ my $m = $HTML::Mason::Commands::m;
+
+ return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
+
+ # Don't show the login page to logged in users
+ Redirect(RT->Config->Get('WebURL'))
+ if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
+
+ # If it's a noauth file, don't ask for auth.
+ $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
+ $m->abort;
+}
+
+=head2 MaybeRejectPrivateComponentRequest
+
+This function will reject calls to private components, like those under
+C</Elements>. If the requested path is a private component then we will
+abort with a C<403> error.
+
+=cut
+
+sub MaybeRejectPrivateComponentRequest {
+ my $m = $HTML::Mason::Commands::m;
+ my $path = $m->request_comp->path;
+
+ # We do not check for dhandler here, because requesting our dhandlers
+ # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
+ # 'dhandler'.
+
+ if ($path =~ m{
+ / # leading slash
+ ( Elements |
+ _elements | # mobile UI
+ Callbacks |
+ Widgets |
+ autohandler | # requesting this directly is suspicious
+ l (_unsafe)? ) # loc component
+ ( $ | / ) # trailing slash or end of path
+ }xi
+ && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
+ )
+ {
+ warn "rejecting private component $path\n";
+ $m->abort(403);
+ }
+
+ return;
+}
+
+sub InitializeMenu {
+ $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
+ $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
+ $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
+
+}
+
+
+=head2 ShowRequestedPage \%ARGS
+
+This function, called exclusively by RT's autohandler, dispatches
+a request to the page a user requested (making sure that unpriviled users
+can only see self-service pages.
+
+=cut
+
+sub ShowRequestedPage {
+ my $ARGS = shift;
+
+ my $m = $HTML::Mason::Commands::m;
+
+ # Ensure that the cookie that we send is up-to-date, in case the
+ # session-id has been modified in any way
+ SendSessionCookie();
+
+ # precache all system level rights for the current user
+ $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
+
+ # If the user isn't privileged, they can only see SelfService
+ unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
+
+ # if the user is trying to access a ticket, redirect them
+ if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
+ RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
+ }
+
+ # otherwise, drop the user at the SelfService default page
+ elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
+ RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
+ }
+
+ # if user is in SelfService dir let him do anything
+ else {
+ $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
+ }
+ } else {
+ $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
+ }
+
+}
+
+sub AttemptExternalAuth {
+ my $ARGS = shift;
+
+ return unless ( RT->Config->Get('WebExternalAuth') );
+
+ my $user = $ARGS->{user};
+ my $m = $HTML::Mason::Commands::m;
+
+ # If RT is configured for external auth, let's go through and get REMOTE_USER
+
+ # do we actually have a REMOTE_USER equivlent?
+ if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
+ my $orig_user = $user;
+
+ $user = RT::Interface::Web::WebCanonicalizeInfo();
+ my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
+
+ if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
+ my $NodeName = Win32::NodeName();
+ $user =~ s/^\Q$NodeName\E\\//i;
+ }
+
+ my $next = RemoveNextPage($ARGS->{'next'});
+ $next = $next->{'url'} if ref $next;
+ InstantiateNewSession() unless _UserLoggedIn;
+ $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
+ $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
+
+ if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
+
+ # Create users on-the-fly
+ my $UserObj = RT::User->new(RT->SystemUser);
+ my ( $val, $msg ) = $UserObj->Create(
+ %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
+ Name => $user,
+ Gecos => $user,
+ );
+
+ if ($val) {
+
+ # now get user specific information, to better create our user.
+ my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
+
+ # set the attributes that have been defined.
+ foreach my $attribute ( $UserObj->WritableAttributes ) {
+ $m->callback(
+ Attribute => $attribute,
+ User => $user,
+ UserInfo => $new_user_info,
+ CallbackName => 'NewUser',
+ CallbackPage => '/autohandler'
+ );
+ my $method = "Set$attribute";
+ $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
+ }
+ $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
+ } else {
+
+ # we failed to successfully create the user. abort abort abort.
+ delete $HTML::Mason::Commands::session{'CurrentUser'};
+
+ if (RT->Config->Get('WebFallbackToInternalAuth')) {
+ TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
+ } else {
+ $m->abort();
+ }
+ }
+ }
+
+ if ( _UserLoggedIn() ) {
+ $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
+ # It is possible that we did a redirect to the login page,
+ # if the external auth allows lack of auth through with no
+ # REMOTE_USER set, instead of forcing a "permission
+ # denied" message. Honor the $next.
+ Redirect($next) if $next;
+ # Unlike AttemptPasswordAuthentication below, we do not
+ # force a redirect to / if $next is not set -- otherwise,
+ # straight-up external auth would always redirect to /
+ # when you first hit it.
+ } else {
+ delete $HTML::Mason::Commands::session{'CurrentUser'};
+ $user = $orig_user;
+
+ unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
+ TangentForLoginWithError($ARGS, 'You are not an authorized user');
+ }
+ }
+ } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
+ unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
+ # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
+ TangentForLoginWithError($ARGS, 'You are not an authorized user');
+ }
+ } else {
+
+ # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
+ # XXX: we must return AUTH_REQUIRED status or we fallback to
+ # internal auth here too.
+ delete $HTML::Mason::Commands::session{'CurrentUser'}
+ if defined $HTML::Mason::Commands::session{'CurrentUser'};
+ }
+}
+
+sub AttemptPasswordAuthentication {
+ my $ARGS = shift;
+ return unless defined $ARGS->{user} && defined $ARGS->{pass};
+
+ my $user_obj = RT::CurrentUser->new();
+ $user_obj->Load( $ARGS->{user} );
+
+ my $m = $HTML::Mason::Commands::m;
+
+ unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
+ $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
+ $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
+ return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
+ }
+ else {
+ $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
+
+ # It's important to nab the next page from the session before we blow
+ # the session away
+ my $next = RemoveNextPage($ARGS->{'next'});
+ $next = $next->{'url'} if ref $next;
+
+ InstantiateNewSession();
+ $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
+
+ $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
+
+ # Really the only time we don't want to redirect here is if we were
+ # passed user and pass as query params in the URL.
+ if ($next) {
+ Redirect($next);
+ }
+ elsif ($ARGS->{'next'}) {
+ # Invalid hash, but still wants to go somewhere, take them to /
+ Redirect(RT->Config->Get('WebURL'));
+ }
+
+ return (1, HTML::Mason::Commands::loc('Logged in'));
+ }
+}
+
+=head2 LoadSessionFromCookie
+
+Load or setup a session cookie for the current user.
+
+=cut
+
+sub _SessionCookieName {
+ my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
+ $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
+ return $cookiename;
+}
+
+sub LoadSessionFromCookie {
+
+ my %cookies = CGI::Cookie->fetch;
+ my $cookiename = _SessionCookieName();
+ my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
+ tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
+ unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
+ InstantiateNewSession();
+ }
+ if ( int RT->Config->Get('AutoLogoff') ) {
+ my $now = int( time / 60 );
+ my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
+
+ if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
+ InstantiateNewSession();
+ }
+
+ # save session on each request when AutoLogoff is turned on
+ $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
+ }
+}
+
+sub InstantiateNewSession {
+ tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
+ tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
+ SendSessionCookie();
+}
+
+sub SendSessionCookie {
+ my $cookie = CGI::Cookie->new(
+ -name => _SessionCookieName(),
+ -value => $HTML::Mason::Commands::session{_session_id},
+ -path => RT->Config->Get('WebPath'),
+ -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
+ -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
+ );
+
+ $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
+}
+
+=head2 Redirect URL
+
+This routine ells the current user's browser to redirect to URL.
+Additionally, it unties the user's currently active session, helping to avoid
+A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
+a cached DBI statement handle twice at the same time.
+
+=cut
+
+sub Redirect {
+ my $redir_to = shift;
+ untie $HTML::Mason::Commands::session;
+ my $uri = URI->new($redir_to);
+ my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
+
+ # Make relative URIs absolute from the server host and scheme
+ $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
+ if (not defined $uri->host) {
+ $uri->host($server_uri->host);
+ $uri->port($server_uri->port);
+ }
+
+ # If the user is coming in via a non-canonical
+ # hostname, don't redirect them to the canonical host,
+ # it will just upset them (and invalidate their credentials)
+ # don't do this if $RT::CanonicalizeRedirectURLs is true
+ if ( !RT->Config->Get('CanonicalizeRedirectURLs')
+ && $uri->host eq $server_uri->host
+ && $uri->port eq $server_uri->port )
+ {
+ if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
+ $uri->scheme('https');
+ } else {
+ $uri->scheme('http');
+ }
+
+ # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
+ $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
+ $uri->port( $ENV{'SERVER_PORT'} );
+ }
+
+ # not sure why, but on some systems without this call mason doesn't
+ # set status to 302, but 200 instead and people see blank pages
+ $HTML::Mason::Commands::r->status(302);
+
+ # Perlbal expects a status message, but Mason's default redirect status
+ # doesn't provide one. See also rt.cpan.org #36689.
+ $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
+
+ $HTML::Mason::Commands::m->abort;
+}
+
+=head2 CacheControlExpiresHeaders
+
+set both Cache-Control and Expires http headers
+
+=cut
+
+sub CacheControlExpiresHeaders {
+ my %args = @_;
+
+ my $Visibility = 'private';
+ if ( ! defined $args{Time} ) {
+ $args{Time} = 0;
+ } elsif ( $args{Time} eq 'no-cache' ) {
+ $args{Time} = 0;
+ } elsif ( $args{Time} eq 'forever' ) {
+ $args{Time} = 30 * 24 * 60 * 60;
+ $Visibility = 'public';
+ }
+
+ my $CacheControl = $args{Time}
+ ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
+ : 'no-cache'
+ ;
+ $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
+
+ my $expires = RT::Date->new(RT->SystemUser);
+ $expires->SetToNow;
+ $expires->AddSeconds( $args{Time} ) if $args{Time};
+
+ $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
+}
+
+=head2 StaticFileHeaders
+
+Send the browser a few headers to try to get it to (somewhat agressively)
+cache RT's static Javascript and CSS files.
+
+This routine could really use _accurate_ heuristics. (XXX TODO)
+
+=cut
+
+sub StaticFileHeaders {
+ my $date = RT::Date->new(RT->SystemUser);
+
+ # remove any cookie headers -- if it is cached publicly, it
+ # shouldn't include anyone's cookie!
+ delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
+
+ # Expire things in a month.
+ CacheControlExpiresHeaders( Time => 'forever' );
+
+ # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
+ # request, but we don't handle it and generate full reply again
+ # Last modified at server start time
+ # $date->Set( Value => $^T );
+ # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
+}
+
+=head2 ComponentPathIsSafe PATH
+
+Takes C<PATH> and returns a boolean indicating that the user-specified partial
+component path is safe.
+
+Currently "safe" means that the path does not start with a dot (C<.>), does
+not contain a slash-dot C</.>, and does not contain any nulls.
+
+=cut
+
+sub ComponentPathIsSafe {
+ my $self = shift;
+ my $path = shift;
+ return($path !~ m{(?:^|/)\.} and $path !~ m{\0});
+}
+
+=head2 PathIsSafe
+
+Takes a C<< Path => path >> and returns a boolean indicating that
+the path is safely within RT's control or not. The path I<must> be
+relative.
+
+This function does not consult the filesystem at all; it is merely
+a logical sanity checking of the path. This explicitly does not handle
+symlinks; if you have symlinks in RT's webroot pointing outside of it,
+then we assume you know what you are doing.
+
+=cut
+
+sub PathIsSafe {
+ my $self = shift;
+ my %args = @_;
+ my $path = $args{Path};
+
+ # Get File::Spec to clean up extra /s, ./, etc
+ my $cleaned_up = File::Spec->canonpath($path);
+
+ if (!defined($cleaned_up)) {
+ $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
+ return 0;
+ }
+
+ # Forbid too many ..s. We can't just sum then check because
+ # "../foo/bar/baz" should be illegal even though it has more
+ # downdirs than updirs. So as soon as we get a negative score
+ # (which means "breaking out" of the top level) we reject the path.
+
+ my @components = split '/', $cleaned_up;
+ my $score = 0;
+ for my $component (@components) {
+ if ($component eq '..') {
+ $score--;
+ if ($score < 0) {
+ $RT::Logger->info("Rejecting unsafe path: $path");
+ return 0;
+ }
+ }
+ elsif ($component eq '.' || $component eq '') {
+ # these two have no effect on $score
+ }
+ else {
+ $score++;
+ }
+ }
+
+ return 1;
+}
+
+=head2 SendStaticFile
+
+Takes a File => path and a Type => Content-type
+
+If Type isn't provided and File is an image, it will
+figure out a sane Content-type, otherwise it will
+send application/octet-stream
+
+Will set caching headers using StaticFileHeaders
+
+=cut
+
+sub SendStaticFile {
+ my $self = shift;
+ my %args = @_;
+ my $file = $args{File};
+ my $type = $args{Type};
+ my $relfile = $args{RelativeFile};
+
+ if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
+ $HTML::Mason::Commands::r->status(400);
+ $HTML::Mason::Commands::m->abort;
+ }
+
+ $self->StaticFileHeaders();
+
+ unless ($type) {
+ if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
+ $type = "image/$1";
+ $type =~ s/jpg/jpeg/gi;
+ }
+ $type ||= "application/octet-stream";
+ }
+ $HTML::Mason::Commands::r->content_type($type);
+ open( my $fh, '<', $file ) or die "couldn't open file: $!";
+ binmode($fh);
+ {
+ local $/ = \16384;
+ $HTML::Mason::Commands::m->out($_) while (<$fh>);
+ $HTML::Mason::Commands::m->flush_buffer;
+ }
+ close $fh;
+}
+
+
+
+sub MobileClient {
+ my $self = shift;
+
+
+if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
+ return 1;
+} else {
+ return undef;
+}
+
+}
+
+
+sub StripContent {
+ my %args = @_;
+ my $content = $args{Content};
+ return '' unless $content;
+
+ # Make the content have no 'weird' newlines in it
+ $content =~ s/\r+\n/\n/g;
+
+ my $return_content = $content;
+
+ my $html = $args{ContentType} && $args{ContentType} eq "text/html";
+ my $sigonly = $args{StripSignature};
+
+ # massage content to easily detect if there's any real content
+ $content =~ s/\s+//g; # yes! remove all the spaces
+ if ( $html ) {
+ # remove html version of spaces and newlines
+ $content =~ s! !!g;
+ $content =~ s!<br/?>!!g;
+ }
+
+ # Filter empty content when type is text/html
+ return '' if $html && $content !~ /\S/;
+
+ # If we aren't supposed to strip the sig, just bail now.
+ return $return_content unless $sigonly;
+
+ # Find the signature
+ my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
+ $sig =~ s/\s+//g;
+
+ # Check for plaintext sig
+ return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
+
+ # Check for html-formatted sig; we don't use EscapeUTF8 here
+ # because we want to precisely match the escapting that FCKEditor
+ # uses.
+ $sig =~ s/&/&/g;
+ $sig =~ s/</</g;
+ $sig =~ s/>/>/g;
+ $sig =~ s/"/"/g;
+ $sig =~ s/'/'/g;
+ return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
+
+ # Pass it through
+ return $return_content;
+}
+
+sub DecodeARGS {
+ my $ARGS = shift;
+
+ %{$ARGS} = map {
+
+ # if they've passed multiple values, they'll be an array. if they've
+ # passed just one, a scalar whatever they are, mark them as utf8
+ my $type = ref($_);
+ ( !$type )
+ ? Encode::is_utf8($_)
+ ? $_
+ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
+ : ( $type eq 'ARRAY' )
+ ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
+ @$_ ]
+ : ( $type eq 'HASH' )
+ ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
+ %$_ }
+ : $_
+ } %$ARGS;
+}
+
+sub PreprocessTimeUpdates {
+ my $ARGS = shift;
+
+ # Later in the code we use
+ # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
+ # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
+ # The call_next method pass through original arguments and if you have
+ # an argument with unicode key then in a next component you'll get two
+ # records in the args hash: one with key without UTF8 flag and another
+ # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
+ # is copied from mason's source to get the same results as we get from
+ # call_next method, this feature is not documented, so we just leave it
+ # here to avoid possible side effects.
+
+ # This code canonicalizes time inputs in hours into minutes
+ foreach my $field ( keys %$ARGS ) {
+ next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
+ my $local = $1;
+ $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
+ {($1 || 0) + $3 ? $2 / $3 : 0}xe;
+ if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
+ $ARGS->{$local} *= 60;
+ }
+ delete $ARGS->{$field};
+ }
+
+}
+
+sub MaybeEnableSQLStatementLog {
+
+ my $log_sql_statements = RT->Config->Get('StatementLog');
+
+ if ($log_sql_statements) {
+ $RT::Handle->ClearSQLStatementLog;
+ $RT::Handle->LogSQLStatements(1);
+ }
+
+}
+
+sub LogRecordedSQLStatements {
+ my %args = @_;
+
+ my $log_sql_statements = RT->Config->Get('StatementLog');
+
+ return unless ($log_sql_statements);
+
+ my @log = $RT::Handle->SQLStatementLog;
+ $RT::Handle->ClearSQLStatementLog;
+
+ $RT::Handle->AddRequestToHistory({
+ %{ $args{RequestData} },
+ Queries => \@log,
+ });
+
+ for my $stmt (@log) {
+ my ( $time, $sql, $bind, $duration ) = @{$stmt};
+ my @bind;
+ if ( ref $bind ) {
+ @bind = @{$bind};
+ } else {
+
+ # Older DBIx-SB
+ $duration = $bind;
+ }
+ $RT::Logger->log(
+ level => $log_sql_statements,
+ message => "SQL("
+ . sprintf( "%.6f", $duration )
+ . "s): $sql;"
+ . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
+ );
+ }
+
+}
+
+my $_has_validated_web_config = 0;
+sub ValidateWebConfig {
+ my $self = shift;
+
+ # do this once per server instance, not once per request
+ return if $_has_validated_web_config;
+ $_has_validated_web_config = 1;
+
+ my $port = $ENV{SERVER_PORT};
+ my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
+ || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
+
+ if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
+ $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
+ ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+
+ if ( $host ne RT->Config->Get('WebDomain') ) {
+ $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
+ ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+
+ return; #next warning flooding our logs, doesn't seem applicable to our use
+ # (SCRIPT_NAME is the full path, WebPath is just the beginning)
+ #in vanilla RT does something eat the local part of SCRIPT_NAME 1st?
+
+ # Unfortunately, there is no reliable way to get the _path_ that was
+ # requested at the proxy level; simply disable this warning if we're
+ # proxied and there's a mismatch.
+ my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
+ if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
+ $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
+ ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+}
+
+sub ComponentRoots {
+ my $self = shift;
+ my %args = ( Names => 0, @_ );
+ my @roots;
+ if (defined $HTML::Mason::Commands::m) {
+ @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
+ } else {
+ @roots = (
+ [ local => $RT::MasonLocalComponentRoot ],
+ (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
+ [ standard => $RT::MasonComponentRoot ]
+ );
+ }
+ @roots = map { $_->[1] } @roots unless $args{Names};
+ return @roots;
+}
+
+our %is_whitelisted_component = (
+ # The RSS feed embeds an auth token in the path, but query
+ # information for the search. Because it's a straight-up read, in
+ # addition to embedding its own auth, it's fine.
+ '/NoAuth/rss/dhandler' => 1,
+
+ # While these can be used for denial-of-service against RT
+ # (construct a very inefficient query and trick lots of users into
+ # running them against RT) it's incredibly useful to be able to link
+ # to a search result (or chart) or bookmark a result page.
+ '/Search/Results.html' => 1,
+ '/Search/Simple.html' => 1,
+ '/m/tickets/search' => 1,
+ '/Search/Chart.html' => 1,
+
+ # This page takes Attachment and Transaction argument to figure
+ # out what to show, but it's read only and will deny information if you
+ # don't have ShowOutgoingEmail.
+ '/Ticket/ShowEmailRecord.html' => 1,
+);
+
+# Components which are blacklisted from automatic, argument-based whitelisting.
+# These pages are not idempotent when called with just an id.
+our %is_blacklisted_component = (
+ # Takes only id and toggles bookmark state
+ '/Helpers/Toggle/TicketBookmark' => 1,
+);
+
+sub IsCompCSRFWhitelisted {
+ my $comp = shift;
+ my $ARGS = shift;
+
+ return 1 if $is_whitelisted_component{$comp};
+
+ my %args = %{ $ARGS };
+
+ # If the user specifies a *correct* user and pass then they are
+ # golden. This acts on the presumption that external forms may
+ # hardcode a username and password -- if a malicious attacker knew
+ # both already, CSRF is the least of your problems.
+ my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
+ if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
+ my $user_obj = RT::CurrentUser->new();
+ $user_obj->Load($args{user});
+ return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
+
+ delete $args{user};
+ delete $args{pass};
+ }
+
+ # Some pages aren't idempotent even with safe args like id; blacklist
+ # them from the automatic whitelisting below.
+ return 0 if $is_blacklisted_component{$comp};
+
+ # Eliminate arguments that do not indicate an effectful request.
+ # For example, "id" is acceptable because that is how RT retrieves a
+ # record.
+ delete $args{id};
+
+ # If they have a results= from MaybeRedirectForResults, that's also fine.
+ delete $args{results};
+
+ # The homepage refresh, which uses the Refresh header, doesn't send
+ # a referer in most browsers; whitelist the one parameter it reloads
+ # with, HomeRefreshInterval, which is safe
+ delete $args{HomeRefreshInterval};
+
+ # The NotMobile flag is fine for any page; it's only used to toggle a flag
+ # in the session related to which interface you get.
+ delete $args{NotMobile};
+
+ # If there are no arguments, then it's likely to be an idempotent
+ # request, which are not susceptible to CSRF
+ return 1 if !%args;
+
+ return 0;
+}
+
+sub IsRefererCSRFWhitelisted {
+ my $referer = _NormalizeHost(shift);
+ my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
+ $base_url = $base_url->host_port;
+
+ my $configs;
+ for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
+ push @$configs,$config;
+
+ my $host_port = $referer->host_port;
+ if ($config =~ /\*/) {
+ # Turn a literal * into a domain component or partial component match.
+ # Refer to http://tools.ietf.org/html/rfc2818#page-5
+ my $regex = join "[a-zA-Z0-9\-]*",
+ map { quotemeta($_) }
+ split /\*/, $config;
+
+ return 1 if $host_port =~ /^$regex$/i;
+ } else {
+ return 1 if $host_port eq $config;
+ }
+ }
+
+ return (0,$referer,$configs);
+}
+
+=head3 _NormalizeHost
+
+Takes a URI and creates a URI object that's been normalized
+to handle common problems such as localhost vs 127.0.0.1
+
+=cut
+
+sub _NormalizeHost {
+ my $s = shift;
+ $s = "http://$s" unless $s =~ /^http/i;
+ my $uri= URI->new($s);
+ $uri->host('127.0.0.1') if $uri->host eq 'localhost';
+
+ return $uri;
+
+}
+
+sub IsPossibleCSRF {
+ my $ARGS = shift;
+
+ # If first request on this session is to a REST endpoint, then
+ # whitelist the REST endpoints -- and explicitly deny non-REST
+ # endpoints. We do this because using a REST cookie in a browser
+ # would open the user to CSRF attacks to the REST endpoints.
+ my $path = $HTML::Mason::Commands::r->path_info;
+ $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
+ unless defined $HTML::Mason::Commands::session{'REST'};
+
+ if ($HTML::Mason::Commands::session{'REST'}) {
+ return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
+ my $why = <<EOT;
+This login session belongs to a REST client, and cannot be used to
+access non-REST interfaces of RT for security reasons.
+EOT
+ my $details = <<EOT;
+Please log out and back in to obtain a session for normal browsing. If
+you understand the security implications, disabling RT's CSRF protection
+will remove this restriction.
+EOT
+ chomp $details;
+ HTML::Mason::Commands::Abort( $why, Details => $details );
+ }
+
+ return 0 if IsCompCSRFWhitelisted(
+ $HTML::Mason::Commands::m->request_comp->path,
+ $ARGS
+ );
+
+ # if there is no Referer header then assume the worst
+ return (1,
+ "your browser did not supply a Referrer header", # loc
+ ) if !$ENV{HTTP_REFERER};
+
+ my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
+ return 0 if $whitelisted;
+
+ if ( @$configs > 1 ) {
+ return (1,
+ "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
+ $browser->host_port,
+ shift @$configs,
+ join(', ', @$configs) );
+ }
+
+ return (1,
+ "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
+ $browser->host_port,
+ $configs->[0]);
+}
+
+sub ExpandCSRFToken {
+ my $ARGS = shift;
+
+ my $token = delete $ARGS->{CSRF_Token};
+ return unless $token;
+
+ my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
+ return unless $data;
+ return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
+
+ my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
+ return unless $user->ValidateAuthString( $data->{auth}, $token );
+
+ %{$ARGS} = %{$data->{args}};
+ $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
+
+ # We explicitly stored file attachments with the request, but not in
+ # the session yet, as that would itself be an attack. Put them into
+ # the session now, so they'll be visible.
+ if ($data->{attach}) {
+ my $filename = $data->{attach}{filename};
+ my $mime = $data->{attach}{mime};
+ $HTML::Mason::Commands::session{'Attachments'}{$filename}
+ = $mime;
+ }
+
+ return 1;
+}
+
+sub StoreRequestToken {
+ my $ARGS = shift;
+
+ my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
+ my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
+ my $data = {
+ auth => $user->GenerateAuthString( $token ),
+ path => $HTML::Mason::Commands::r->path_info,
+ args => $ARGS,
+ };
+ if ($ARGS->{Attach}) {
+ my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
+ my $file_path = delete $ARGS->{'Attach'};
+ $data->{attach} = {
+ filename => Encode::decode_utf8("$file_path"),
+ mime => $attachment,
+ };
+ }
+
+ $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
+ $HTML::Mason::Commands::session{'i'}++;
+ return $token;
+}
+
+sub MaybeShowInterstitialCSRFPage {
+ my $ARGS = shift;
+
+ return unless RT->Config->Get('RestrictReferrer');
+
+ # Deal with the form token provided by the interstitial, which lets
+ # browsers which never set referer headers still use RT, if
+ # painfully. This blows values into ARGS
+ return if ExpandCSRFToken($ARGS);
+
+ my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
+ return if !$is_csrf;
+
+ $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
+
+ my $token = StoreRequestToken($ARGS);
+ $HTML::Mason::Commands::m->comp(
+ '/Elements/CSRF',
+ OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
+ Reason => HTML::Mason::Commands::loc( $msg, @loc ),
+ Token => $token,
+ );
+ # Calls abort, never gets here
+}
+
+our @POTENTIAL_PAGE_ACTIONS = (
+ qr'/Ticket/Create.html' => "create a ticket", # loc
+ qr'/Ticket/' => "update a ticket", # loc
+ qr'/Admin/' => "modify RT's configuration", # loc
+ qr'/Approval/' => "update an approval", # loc
+ qr'/Articles/' => "update an article", # loc
+ qr'/Dashboards/' => "modify a dashboard", # loc
+ qr'/m/ticket/' => "update a ticket", # loc
+ qr'Prefs' => "modify your preferences", # loc
+ qr'/Search/' => "modify or access a search", # loc
+ qr'/SelfService/Create' => "create a ticket", # loc
+ qr'/SelfService/' => "update a ticket", # loc
+);
+
+sub PotentialPageAction {
+ my $page = shift;
+ my @potentials = @POTENTIAL_PAGE_ACTIONS;
+ while (my ($pattern, $result) = splice @potentials, 0, 2) {
+ return HTML::Mason::Commands::loc($result)
+ if $page =~ $pattern;
+ }
+ return "";
+}
+
+package HTML::Mason::Commands;
+
+use vars qw/$r $m %session/;
+
+sub Menu {
+ return $HTML::Mason::Commands::m->notes('menu');
+}
+
+sub PageMenu {
+ return $HTML::Mason::Commands::m->notes('page-menu');
+}
+
+sub PageWidgets {
+ return $HTML::Mason::Commands::m->notes('page-widgets');
+}
+
+
+
+=head2 loc ARRAY
+
+loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
+with whatever it's called with. If there is no $session{'CurrentUser'},
+it creates a temporary user, so we have something to get a localisation handle
+through
+
+=cut
+
+sub loc {
+
+ if ( $session{'CurrentUser'}
+ && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
+ {
+ return ( $session{'CurrentUser'}->loc(@_) );
+ } elsif (
+ my $u = eval {
+ RT::CurrentUser->new();
+ }
+ )
+ {
+ return ( $u->loc(@_) );
+ } else {
+
+ # pathetic case -- SystemUser is gone.
+ return $_[0];
+ }
+}
+
+
+
+=head2 loc_fuzzy STRING
+
+loc_fuzzy is for handling localizations of messages that may already
+contain interpolated variables, typically returned from libraries
+outside RT's control. It takes the message string and extracts the
+variable array automatically by matching against the candidate entries
+inside the lexicon file.
+
+=cut
+
+sub loc_fuzzy {
+ my $msg = shift;
+
+ if ( $session{'CurrentUser'}
+ && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
+ {
+ return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
+ } else {
+ my $u = RT::CurrentUser->new( RT->SystemUser->Id );
+ return ( $u->loc_fuzzy($msg) );
+ }
+}
+
+
+# Error - calls Error and aborts
+sub Abort {
+ my $why = shift;
+ my %args = @_;
+
+ if ( $session{'ErrorDocument'}
+ && $session{'ErrorDocumentType'} )
+ {
+ $r->content_type( $session{'ErrorDocumentType'} );
+ $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
+ $m->abort;
+ } else {
+ $m->comp( "/Elements/Error", Why => $why, %args );
+ $m->abort;
+ }
+}
+
+sub MaybeRedirectForResults {
+ my %args = (
+ Path => $HTML::Mason::Commands::m->request_comp->path,
+ Arguments => {},
+ Anchor => undef,
+ Actions => undef,
+ Force => 0,
+ @_
+ );
+ my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
+ return unless $has_actions || $args{'Force'};
+
+ my %arguments = %{ $args{'Arguments'} };
+
+ if ( $has_actions ) {
+ my $key = Digest::MD5::md5_hex( rand(1024) );
+ push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
+ $session{'i'}++;
+ $arguments{'results'} = $key;
+ }
+
+ $args{'Path'} =~ s!^/+!!;
+ my $url = RT->Config->Get('WebURL') . $args{Path};
+
+ if ( keys %arguments ) {
+ $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
+ }
+ if ( $args{'Anchor'} ) {
+ $url .= "#". $args{'Anchor'};
+ }
+ return RT::Interface::Web::Redirect($url);
+}
+
+=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
+
+If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
+redirect to the approvals display page, preserving any arguments.
+
+C<Path>s matching C<Whitelist> are let through.
+
+This is a no-op if the C<ForceApprovalsView> option isn't enabled.
+
+=cut
+
+sub MaybeRedirectToApproval {
+ my %args = (
+ Path => $HTML::Mason::Commands::m->request_comp->path,
+ ARGSRef => {},
+ Whitelist => undef,
+ @_
+ );
+
+ return unless $ENV{REQUEST_METHOD} eq 'GET';
+
+ my $id = $args{ARGSRef}->{id};
+
+ if ( $id
+ and RT->Config->Get('ForceApprovalsView')
+ and not $args{Path} =~ /$args{Whitelist}/)
+ {
+ my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
+ $ticket->Load($id);
+
+ if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
+ MaybeRedirectForResults(
+ Path => "/Approvals/Display.html",
+ Force => 1,
+ Anchor => $args{ARGSRef}->{Anchor},
+ Arguments => $args{ARGSRef},
+ );
+ }
+ }
+}
+
+=head2 CreateTicket ARGS
+
+Create a new ticket, using Mason's %ARGS. returns @results.
+
+=cut
+
+sub CreateTicket {
+ my %ARGS = (@_);
+
+ my (@Actions);
+
+ my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
+
+ my $Queue = RT::Queue->new( $session{'CurrentUser'} );
+ unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
+ Abort('Queue not found');
+ }
+
+ unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
+ Abort('You have no permission to create tickets in that queue.');
+ }
+
+ my $due;
+ if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
+ $due = RT::Date->new( $session{'CurrentUser'} );
+ $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
+ }
+ my $starts;
+ if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
+ $starts = RT::Date->new( $session{'CurrentUser'} );
+ $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
+ }
+
+ my $sigless = RT::Interface::Web::StripContent(
+ Content => $ARGS{Content},
+ ContentType => $ARGS{ContentType},
+ StripSignature => 1,
+ CurrentUser => $session{'CurrentUser'},
+ );
+
+ my $MIMEObj = MakeMIMEEntity(
+ Subject => $ARGS{'Subject'},
+ From => $ARGS{'From'},
+ Cc => $ARGS{'Cc'},
+ Body => $sigless,
+ Type => $ARGS{'ContentType'},
+ Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
+ );
+
+ if ( $ARGS{'Attachments'} ) {
+ my $rv = $MIMEObj->make_multipart;
+ $RT::Logger->error("Couldn't make multipart message")
+ if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
+
+ foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
+ unless ($_) {
+ $RT::Logger->error("Couldn't add empty attachemnt");
+ next;
+ }
+ $MIMEObj->add_part($_);
+ }
+ }
+
+ for my $argument (qw(Encrypt Sign)) {
+ $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
+ }
+
+ my %create_args = (
+ Type => $ARGS{'Type'} || 'ticket',
+ Queue => $ARGS{'Queue'},
+ Owner => $ARGS{'Owner'},
+
+ # note: name change
+ Requestor => $ARGS{'Requestors'},
+ Cc => $ARGS{'Cc'},
+ AdminCc => $ARGS{'AdminCc'},
+ InitialPriority => $ARGS{'InitialPriority'},
+ FinalPriority => $ARGS{'FinalPriority'},
+ TimeLeft => $ARGS{'TimeLeft'},
+ TimeEstimated => $ARGS{'TimeEstimated'},
+ TimeWorked => $ARGS{'TimeWorked'},
+ Subject => $ARGS{'Subject'},
+ Status => $ARGS{'Status'},
+ Due => $due ? $due->ISO : undef,
+ Starts => $starts ? $starts->ISO : undef,
+ MIMEObj => $MIMEObj
+ );
+
+ my @txn_squelch;
+ foreach my $type (qw(Requestor Cc AdminCc)) {
+ push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
+ if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
+ }
+ $create_args{TransSquelchMailTo} = \@txn_squelch
+ if @txn_squelch;
+
+ if ( $ARGS{'AttachTickets'} ) {
+ require RT::Action::SendEmail;
+ RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
+ ref $ARGS{'AttachTickets'}
+ ? @{ $ARGS{'AttachTickets'} }
+ : ( $ARGS{'AttachTickets'} ) );
+ }
+
+ foreach my $arg ( keys %ARGS ) {
+ next if $arg =~ /-(?:Magic|Category)$/;
+
+ if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
+ $create_args{$arg} = $ARGS{$arg};
+ }
+
+ # Object-RT::Ticket--CustomField-3-Values
+ elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
+ my $cfid = $1;
+
+ my $cf = RT::CustomField->new( $session{'CurrentUser'} );
+ $cf->SetContextObject( $Queue );
+ $cf->Load($cfid);
+ unless ( $cf->id ) {
+ $RT::Logger->error( "Couldn't load custom field #" . $cfid );
+ next;
+ }
+
+ if ( $arg =~ /-Upload$/ ) {
+ $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
+ next;
+ }
+
+ my $type = $cf->Type;
+
+ my @values = ();
+ if ( ref $ARGS{$arg} eq 'ARRAY' ) {
+ @values = @{ $ARGS{$arg} };
+ } elsif ( $type =~ /text/i ) {
+ @values = ( $ARGS{$arg} );
+ } else {
+ no warnings 'uninitialized';
+ @values = split /\r*\n/, $ARGS{$arg};
+ }
+ @values = grep length, map {
+ s/\r+\n/\n/g;
+ s/^\s+//;
+ s/\s+$//;
+ $_;
+ }
+ grep defined, @values;
+
+ $create_args{"CustomField-$cfid"} = \@values;
+ }
+ }
+
+ # turn new link lists into arrays, and pass in the proper arguments
+ my %map = (
+ 'new-DependsOn' => 'DependsOn',
+ 'DependsOn-new' => 'DependedOnBy',
+ 'new-MemberOf' => 'Parents',
+ 'MemberOf-new' => 'Children',
+ 'new-RefersTo' => 'RefersTo',
+ 'RefersTo-new' => 'ReferredToBy',
+ );
+ foreach my $key ( keys %map ) {
+ next unless $ARGS{$key};
+ $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
+
+ }
+
+ my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
+ unless ($id) {
+ Abort($ErrMsg);
+ }
+
+ push( @Actions, split( "\n", $ErrMsg ) );
+ unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
+ Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
+ }
+ return ( $Ticket, @Actions );
+
+}
+
+
+
+=head2 LoadTicket id
+
+Takes a ticket id as its only variable. if it's handed an array, it takes
+the first value.
+
+Returns an RT::Ticket object as the current user.
+
+=cut
+
+sub LoadTicket {
+ my $id = shift;
+
+ if ( ref($id) eq "ARRAY" ) {
+ $id = $id->[0];
+ }
+
+ unless ($id) {
+ Abort("No ticket specified");
+ }
+
+ my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
+ $Ticket->Load($id);
+ unless ( $Ticket->id ) {
+ Abort("Could not load ticket $id");
+ }
+ return $Ticket;
+}
+
+
+
+=head2 ProcessUpdateMessage
+
+Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
+
+Don't write message if it only contains current user's signature and
+SkipSignatureOnly argument is true. Function anyway adds attachments
+and updates time worked field even if skips message. The default value
+is true.
+
+=cut
+
+# change from stock: if txn custom fields are set but there's no content
+# or attachment, create a Touch txn instead of doing nothing
+
+sub ProcessUpdateMessage {
+
+ my %args = (
+ ARGSRef => undef,
+ TicketObj => undef,
+ SkipSignatureOnly => 1,
+ @_
+ );
+
+ if ( $args{ARGSRef}->{'UpdateAttachments'}
+ && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
+ {
+ delete $args{ARGSRef}->{'UpdateAttachments'};
+ }
+
+ # Strip the signature
+ $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
+ Content => $args{ARGSRef}->{UpdateContent},
+ ContentType => $args{ARGSRef}->{UpdateContentType},
+ StripSignature => $args{SkipSignatureOnly},
+ CurrentUser => $args{'TicketObj'}->CurrentUser,
+ );
+
+ my %txn_customfields;
+
+ foreach my $key ( keys %{ $args{ARGSRef} } ) {
+ if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
+ next if $key =~ /(TimeUnits|Magic)$/;
+ $txn_customfields{$key} = $args{ARGSRef}->{$key};
+ }
+ }
+
+ # If, after stripping the signature, we have no message, create a
+ # Touch transaction if necessary
+ if ( not $args{ARGSRef}->{'UpdateAttachments'}
+ and not length $args{ARGSRef}->{'UpdateContent'} )
+ {
+ #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
+ # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
+ # delete $args{ARGSRef}->{'UpdateTimeWorked'};
+ # }
+
+ my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
+ if ( $timetaken or grep {length $_} values %txn_customfields ) {
+ my ( $Transaction, $Description, $Object ) =
+ $args{TicketObj}->Touch(
+ CustomFields => \%txn_customfields,
+ TimeTaken => $timetaken
+ );
+ return $Description;
+ }
+ return;
+ }
+
+ if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
+ $args{ARGSRef}->{'UpdateSubject'} = undef;
+ }
+
+ my $Message = MakeMIMEEntity(
+ Subject => $args{ARGSRef}->{'UpdateSubject'},
+ Body => $args{ARGSRef}->{'UpdateContent'},
+ Type => $args{ARGSRef}->{'UpdateContentType'},
+ Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
+ );
+
+ $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
+ RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
+ ) );
+ my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
+ if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
+ $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
+ } else {
+ $old_txn = $args{TicketObj}->Transactions->First();
+ }
+
+ if ( my $msg = $old_txn->Message->First ) {
+ RT::Interface::Email::SetInReplyTo(
+ Message => $Message,
+ InReplyTo => $msg
+ );
+ }
+
+ if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
+ $Message->make_multipart;
+ $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
+ sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
+ }
+
+ if ( $args{ARGSRef}->{'AttachTickets'} ) {
+ require RT::Action::SendEmail;
+ RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
+ ref $args{ARGSRef}->{'AttachTickets'}
+ ? @{ $args{ARGSRef}->{'AttachTickets'} }
+ : ( $args{ARGSRef}->{'AttachTickets'} ) );
+ }
+
+ my %message_args = (
+ Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
+ Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
+ MIMEObj => $Message,
+ TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
+ CustomFields => \%txn_customfields,
+ );
+
+ _ProcessUpdateMessageRecipients(
+ MessageArgs => \%message_args,
+ %args,
+ );
+
+ my @results;
+ if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
+ my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
+ push( @results, $Description );
+ $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
+ } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
+ my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
+ push( @results, $Description );
+ $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
+ } else {
+ push( @results,
+ loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
+ }
+ return @results;
+}
+
+sub _ProcessUpdateMessageRecipients {
+ my %args = (
+ ARGSRef => undef,
+ TicketObj => undef,
+ MessageArgs => undef,
+ @_,
+ );
+
+ my $bcc = $args{ARGSRef}->{'UpdateBcc'};
+ my $cc = $args{ARGSRef}->{'UpdateCc'};
+
+ my $message_args = $args{MessageArgs};
+
+ $message_args->{CcMessageTo} = $cc;
+ $message_args->{BccMessageTo} = $bcc;
+
+ my @txn_squelch;
+ foreach my $type (qw(Cc AdminCc)) {
+ if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
+ push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
+ push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
+ push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
+ }
+ }
+ if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
+ push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
+ push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
+ }
+
+ push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
+ $message_args->{SquelchMailTo} = \@txn_squelch
+ if @txn_squelch;
+
+ unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
+ foreach my $key ( keys %{ $args{ARGSRef} } ) {
+ next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
+
+ my $var = ucfirst($1) . 'MessageTo';
+ my $value = $2;
+ if ( $message_args->{$var} ) {
+ $message_args->{$var} .= ", $value";
+ } else {
+ $message_args->{$var} = $value;
+ }
+ }
+ }
+}
+
+sub ProcessAttachments {
+ my %args = (
+ ARGSRef => {},
+ @_
+ );
+
+ my $ARGSRef = $args{ARGSRef} || {};
+ # deal with deleting uploaded attachments
+ foreach my $key ( keys %$ARGSRef ) {
+ if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
+ delete $session{'Attachments'}{$1};
+ }
+ $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
+ }
+
+ # store the uploaded attachment in session
+ if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
+ { # attachment?
+ my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
+
+ my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
+ $session{'Attachments'} =
+ { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
+ }
+
+ # delete temporary storage entry to make WebUI clean
+ unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
+ {
+ delete $session{'Attachments'};
+ }
+}
+
+
+=head2 MakeMIMEEntity PARAMHASH
+
+Takes a paramhash Subject, Body and AttachmentFieldName.
+
+Also takes Form, Cc and Type as optional paramhash keys.
+
+ Returns a MIME::Entity.
+
+=cut
+
+sub MakeMIMEEntity {
+
+ #TODO document what else this takes.
+ my %args = (
+ Subject => undef,
+ From => undef,
+ Cc => undef,
+ Body => undef,
+ AttachmentFieldName => undef,
+ Type => undef,
+ Interface => 'API',
+ @_,
+ );
+ my $Message = MIME::Entity->build(
+ Type => 'multipart/mixed',
+ "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
+ "X-RT-Interface" => $args{Interface},
+ map { $_ => Encode::encode_utf8( $args{ $_} ) }
+ grep defined $args{$_}, qw(Subject From Cc)
+ );
+
+ if ( defined $args{'Body'} && length $args{'Body'} ) {
+
+ # Make the update content have no 'weird' newlines in it
+ $args{'Body'} =~ s/\r\n/\n/gs;
+
+ $Message->attach(
+ Type => $args{'Type'} || 'text/plain',
+ Charset => 'UTF-8',
+ Data => $args{'Body'},
+ );
+ }
+
+ if ( $args{'AttachmentFieldName'} ) {
+
+ my $cgi_object = $m->cgi_object;
+ my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
+ if ( defined $filehandle && length $filehandle ) {
+
+ my ( @content, $buffer );
+ while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
+ push @content, $buffer;
+ }
+
+ my $uploadinfo = $cgi_object->uploadInfo($filehandle);
+
+ my $filename = "$filehandle";
+ $filename =~ s{^.*[\\/]}{};
+
+ $Message->attach(
+ Type => $uploadinfo->{'Content-Type'},
+ Filename => $filename,
+ Data => \@content,
+ );
+ if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
+ $Message->head->set( 'Subject' => $filename );
+ }
+
+ # Attachment parts really shouldn't get a Message-ID or "interface"
+ $Message->head->delete('Message-ID');
+ $Message->head->delete('X-RT-Interface');
+ }
+ }
+
+ $Message->make_singlepart;
+
+ RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
+
+ return ($Message);
+
+}
+
+
+
+=head2 ParseDateToISO
+
+Takes a date in an arbitrary format.
+Returns an ISO date and time in GMT
+
+=cut
+
+sub ParseDateToISO {
+ my $date = shift;
+
+ my $date_obj = RT::Date->new( $session{'CurrentUser'} );
+ $date_obj->Set(
+ Format => 'unknown',
+ Value => $date
+ );
+ return ( $date_obj->ISO );
+}
+
+
+
+sub ProcessACLChanges {
+ my $ARGSref = shift;
+
+ my @results;
+
+ foreach my $arg ( keys %$ARGSref ) {
+ next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
+
+ my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
+
+ my @rights;
+ if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
+ @rights = @{ $ARGSref->{$arg} };
+ } else {
+ @rights = $ARGSref->{$arg};
+ }
+ @rights = grep $_, @rights;
+ next unless @rights;
+
+ my $principal = RT::Principal->new( $session{'CurrentUser'} );
+ $principal->Load($principal_id);
+
+ my $obj;
+ if ( $object_type eq 'RT::System' ) {
+ $obj = $RT::System;
+ } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
+ $obj = $object_type->new( $session{'CurrentUser'} );
+ $obj->Load($object_id);
+ unless ( $obj->id ) {
+ $RT::Logger->error("couldn't load $object_type #$object_id");
+ next;
+ }
+ } else {
+ $RT::Logger->error("object type '$object_type' is incorrect");
+ push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
+ next;
+ }
+
+ foreach my $right (@rights) {
+ my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
+ push( @results, $msg );
+ }
+ }
+
+ return (@results);
+}
+
+
+=head2 ProcessACLs
+
+ProcessACLs expects values from a series of checkboxes that describe the full
+set of rights a principal should have on an object.
+
+It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
+instead of with the prefixes Grant/RevokeRight. Each input should be an array
+listing the rights the principal should have, and ProcessACLs will modify the
+current rights to match. Additionally, the previously unused CheckACL input
+listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
+rights are removed from a principal and as such no SetRights input is
+submitted.
+
+=cut
+
+sub ProcessACLs {
+ my $ARGSref = shift;
+ my (%state, @results);
+
+ my $CheckACL = $ARGSref->{'CheckACL'};
+ my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
+
+ # Check if we want to grant rights to a previously rights-less user
+ for my $type (qw(user group)) {
+ my $principal = _ParseACLNewPrincipal($ARGSref, $type)
+ or next;
+
+ unless ($principal->PrincipalId) {
+ push @results, loc("Couldn't load the specified principal");
+ next;
+ }
+
+ my $principal_id = $principal->PrincipalId;
+
+ # Turn our addprincipal rights spec into a real one
+ for my $arg (keys %$ARGSref) {
+ next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
+
+ my $tuple = "$principal_id-$1";
+ my $key = "SetRights-$tuple";
+
+ # If we have it already, that's odd, but merge them
+ if (grep { $_ eq $tuple } @check) {
+ $ARGSref->{$key} = [
+ (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
+ (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
+ ];
+ } else {
+ $ARGSref->{$key} = $ARGSref->{$arg};
+ push @check, $tuple;
+ }
+ }
+ }
+
+ # Build our rights state for each Principal-Object tuple
+ foreach my $arg ( keys %$ARGSref ) {
+ next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
+
+ my $tuple = $1;
+ my $value = $ARGSref->{$arg};
+ my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
+ next unless @rights;
+
+ $state{$tuple} = { map { $_ => 1 } @rights };
+ }
+
+ foreach my $tuple (List::MoreUtils::uniq @check) {
+ next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
+
+ my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
+
+ my $principal = RT::Principal->new( $session{'CurrentUser'} );
+ $principal->Load($principal_id);
+
+ my $obj;
+ if ( $object_type eq 'RT::System' ) {
+ $obj = $RT::System;
+ } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
+ $obj = $object_type->new( $session{'CurrentUser'} );
+ $obj->Load($object_id);
+ unless ( $obj->id ) {
+ $RT::Logger->error("couldn't load $object_type #$object_id");
+ next;
+ }
+ } else {
+ $RT::Logger->error("object type '$object_type' is incorrect");
+ push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
+ next;
+ }
+
+ my $acls = RT::ACL->new($session{'CurrentUser'});
+ $acls->LimitToObject( $obj );
+ $acls->LimitToPrincipal( Id => $principal_id );
+
+ while ( my $ace = $acls->Next ) {
+ my $right = $ace->RightName;
+
+ # Has right and should have right
+ next if delete $state{$tuple}->{$right};
+
+ # Has right and shouldn't have right
+ my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
+ push @results, $msg;
+ }
+
+ # For everything left, they don't have the right but they should
+ for my $right (keys %{ $state{$tuple} || {} }) {
+ delete $state{$tuple}->{$right};
+ my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
+ push @results, $msg;
+ }
+
+ # Check our state for leftovers
+ if ( keys %{ $state{$tuple} || {} } ) {
+ my $missed = join '|', %{$state{$tuple} || {}};
+ $RT::Logger->warn(
+ "Uh-oh, it looks like we somehow missed a right in "
+ ."ProcessACLs. Here's what was leftover: $missed"
+ );
+ }
+ }
+
+ return (@results);
+}
+
+=head2 _ParseACLNewPrincipal
+
+Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
+for the presence of rights being added on a principal of the specified type,
+and returns undef if no new principal is being granted rights. Otherwise loads
+up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
+may not be successfully loaded, and you should check C<->id> yourself.
+
+=cut
+
+sub _ParseACLNewPrincipal {
+ my $ARGSref = shift;
+ my $type = lc shift;
+ my $key = "AddPrincipalForRights-$type";
+
+ return unless $ARGSref->{$key};
+
+ my $principal;
+ if ( $type eq 'user' ) {
+ $principal = RT::User->new( $session{'CurrentUser'} );
+ $principal->LoadByCol( Name => $ARGSref->{$key} );
+ }
+ elsif ( $type eq 'group' ) {
+ $principal = RT::Group->new( $session{'CurrentUser'} );
+ $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
+ }
+ return $principal;
+}
+
+
+=head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
+
+@attribs is a list of ticket fields to check and update if they differ from the B<Object>'s current values. ARGSRef is a ref to HTML::Mason's %ARGS.
+
+Returns an array of success/failure messages
+
+=cut
+
+sub UpdateRecordObject {
+ my %args = (
+ ARGSRef => undef,
+ AttributesRef => undef,
+ Object => undef,
+ AttributePrefix => undef,
+ @_
+ );
+
+ my $Object = $args{'Object'};
+ my @results = $Object->Update(
+ AttributesRef => $args{'AttributesRef'},
+ ARGSRef => $args{'ARGSRef'},
+ AttributePrefix => $args{'AttributePrefix'},
+ );
+
+ return (@results);
+}
+
+
+
+sub ProcessCustomFieldUpdates {
+ my %args = (
+ CustomFieldObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $Object = $args{'CustomFieldObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ my @attribs = qw(Name Type Description Queue SortOrder);
+ my @results = UpdateRecordObject(
+ AttributesRef => \@attribs,
+ Object => $Object,
+ ARGSRef => $ARGSRef
+ );
+
+ my $prefix = "CustomField-" . $Object->Id;
+ if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
+ my ( $addval, $addmsg ) = $Object->AddValue(
+ Name => $ARGSRef->{"$prefix-AddValue-Name"},
+ Description => $ARGSRef->{"$prefix-AddValue-Description"},
+ SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
+ );
+ push( @results, $addmsg );
+ }
+
+ my @delete_values
+ = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
+ ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
+ : ( $ARGSRef->{"$prefix-DeleteValue"} );
+
+ foreach my $id (@delete_values) {
+ next unless defined $id;
+ my ( $err, $msg ) = $Object->DeleteValue($id);
+ push( @results, $msg );
+ }
+
+ my $vals = $Object->Values();
+ while ( my $cfv = $vals->Next() ) {
+ if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
+ if ( $cfv->SortOrder != $so ) {
+ my ( $err, $msg ) = $cfv->SetSortOrder($so);
+ push( @results, $msg );
+ }
+ }
+ }
+
+ return (@results);
+}
+
+
+
+=head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
+
+Returns an array of results messages.
+
+=cut
+
+sub ProcessTicketBasics {
+
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $TicketObj = $args{'TicketObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ my $OrigOwner = $TicketObj->Owner;
+
+ # Set basic fields
+ my @attribs = qw(
+ Subject
+ FinalPriority
+ Priority
+ TimeEstimated
+ TimeWorked
+ TimeLeft
+ Type
+ Status
+ Queue
+ );
+
+ # Canonicalize Queue and Owner to their IDs if they aren't numeric
+ for my $field (qw(Queue Owner)) {
+ if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
+ my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
+ my $temp = $class->new(RT->SystemUser);
+ $temp->Load( $ARGSRef->{$field} );
+ if ( $temp->id ) {
+ $ARGSRef->{$field} = $temp->id;
+ }
+ }
+ }
+
+ # Status isn't a field that can be set to a null value.
+ # RT core complains if you try
+ delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
+
+ my @results = UpdateRecordObject(
+ AttributesRef => \@attribs,
+ Object => $TicketObj,
+ ARGSRef => $ARGSRef,
+ );
+
+ # We special case owner changing, so we can use ForceOwnerChange
+ if ( $ARGSRef->{'Owner'}
+ && $ARGSRef->{'Owner'} !~ /\D/
+ && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
+ my ($ChownType);
+ if ( $ARGSRef->{'ForceOwnerChange'} ) {
+ $ChownType = "Force";
+ }
+ else {
+ $ChownType = "Set";
+ }
+
+ my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
+ push( @results, $msg );
+ }
+
+ # }}}
+
+ return (@results);
+}
+
+sub ProcessTicketReminders {
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $Ticket = $args{'TicketObj'};
+ my $args = $args{'ARGSRef'};
+ my @results;
+
+ my $reminder_collection = $Ticket->Reminders->Collection;
+
+ if ( $args->{'update-reminders'} ) {
+ while ( my $reminder = $reminder_collection->Next ) {
+ my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
+ if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
+ my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
+ push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
+
+ }
+ elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
+ my ($status, $msg) = $Ticket->Reminders->Open($reminder);
+ push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
+ }
+
+ if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
+ my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
+ push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
+ }
+
+ if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
+ my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
+ push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
+ }
+
+ if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
+ my $DateObj = RT::Date->new( $session{'CurrentUser'} );
+ $DateObj->Set(
+ Format => 'unknown',
+ Value => $args->{ 'Reminder-Due-' . $reminder->id }
+ );
+ if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
+ my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
+ push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
+ }
+ }
+ }
+ }
+
+ if ( $args->{'NewReminder-Subject'} ) {
+ my $due_obj = RT::Date->new( $session{'CurrentUser'} );
+ $due_obj->Set(
+ Format => 'unknown',
+ Value => $args->{'NewReminder-Due'}
+ );
+ my ( $add_id, $msg ) = $Ticket->Reminders->Add(
+ Subject => $args->{'NewReminder-Subject'},
+ Owner => $args->{'NewReminder-Owner'},
+ Due => $due_obj->ISO
+ );
+ if ( $add_id ) {
+ push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
+ }
+ else {
+ push @results, $msg;
+ }
+ }
+ return @results;
+}
+
+sub ProcessTicketCustomFieldUpdates {
+ my %args = @_;
+ $args{'Object'} = delete $args{'TicketObj'};
+ my $ARGSRef = { %{ $args{'ARGSRef'} } };
+
+ # Build up a list of objects that we want to work with
+ my %custom_fields_to_mod;
+ foreach my $arg ( keys %$ARGSRef ) {
+ if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
+ $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
+ } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
+ $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
+ } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
+ delete $ARGSRef->{$arg}; # don't try to update transaction fields
+ }
+ }
+
+ return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
+}
+
+sub ProcessObjectCustomFieldUpdates {
+ my %args = @_;
+ my $ARGSRef = $args{'ARGSRef'};
+ my @results;
+
+ # Build up a list of objects that we want to work with
+ my %custom_fields_to_mod;
+ foreach my $arg ( keys %$ARGSRef ) {
+
+ # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
+ next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
+
+ # For each of those objects, find out what custom fields we want to work with.
+ $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
+ }
+
+ # For each of those objects
+ foreach my $class ( keys %custom_fields_to_mod ) {
+ foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
+ my $Object = $args{'Object'};
+ $Object = $class->new( $session{'CurrentUser'} )
+ unless $Object && ref $Object eq $class;
+
+ $Object->Load($id) unless ( $Object->id || 0 ) == $id;
+ unless ( $Object->id ) {
+ $RT::Logger->warning("Couldn't load object $class #$id");
+ next;
+ }
+
+ foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
+ my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
+ $CustomFieldObj->SetContextObject($Object);
+ $CustomFieldObj->LoadById($cf);
+ unless ( $CustomFieldObj->id ) {
+ $RT::Logger->warning("Couldn't load custom field #$cf");
+ next;
+ }
+ push @results,
+ _ProcessObjectCustomFieldUpdates(
+ Prefix => "Object-$class-$id-CustomField-$cf-",
+ Object => $Object,
+ CustomField => $CustomFieldObj,
+ ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
+ );
+ }
+ }
+ }
+ return @results;
+}
+
+sub _ProcessObjectCustomFieldUpdates {
+ my %args = @_;
+ my $cf = $args{'CustomField'};
+ my $cf_type = $cf->Type || '';
+
+ # Remove blank Values since the magic field will take care of this. Sometimes
+ # the browser gives you a blank value which causes CFs to be processed twice
+ if ( defined $args{'ARGS'}->{'Values'}
+ && !length $args{'ARGS'}->{'Values'}
+ && $args{'ARGS'}->{'Values-Magic'} )
+ {
+ delete $args{'ARGS'}->{'Values'};
+ }
+
+ my @results;
+ foreach my $arg ( keys %{ $args{'ARGS'} } ) {
+
+ # skip category argument
+ next if $arg eq 'Category';
+
+ # and TimeUnits
+ next if $arg eq 'Value-TimeUnits';
+
+ # since http won't pass in a form element with a null value, we need
+ # to fake it
+ if ( $arg eq 'Values-Magic' ) {
+
+ # We don't care about the magic, if there's really a values element;
+ next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
+ next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
+
+ # "Empty" values does not mean anything for Image and Binary fields
+ next if $cf_type =~ /^(?:Image|Binary)$/;
+
+ $arg = 'Values';
+ $args{'ARGS'}->{'Values'} = undef;
+ }
+
+ my @values = ();
+ if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
+ @values = @{ $args{'ARGS'}->{$arg} };
+ } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
+ @values = ( $args{'ARGS'}->{$arg} );
+ } else {
+ @values = split /\r*\n/, $args{'ARGS'}->{$arg}
+ if defined $args{'ARGS'}->{$arg};
+ }
+ @values = grep length, map {
+ s/\r+\n/\n/g;
+ s/^\s+//;
+ s/\s+$//;
+ $_;
+ }
+ grep defined, @values;
+
+ if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
+ foreach my $value (@values) {
+ my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
+ Field => $cf->id,
+ Value => $value
+ );
+ push( @results, $msg );
+ }
+ } elsif ( $arg eq 'Upload' ) {
+ my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
+ my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
+ push( @results, $msg );
+ } elsif ( $arg eq 'DeleteValues' ) {
+ foreach my $value (@values) {
+ my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
+ Field => $cf,
+ Value => $value,
+ );
+ push( @results, $msg );
+ }
+ } elsif ( $arg eq 'DeleteValueIds' ) {
+ foreach my $value (@values) {
+ my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
+ Field => $cf,
+ ValueId => $value,
+ );
+ push( @results, $msg );
+ }
+ } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
+ my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
+
+ my %values_hash;
+ foreach my $value (@values) {
+ if ( my $entry = $cf_values->HasEntry($value) ) {
+ $values_hash{ $entry->id } = 1;
+ next;
+ }
+
+ my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push( @results, $msg );
+ $values_hash{$val} = 1 if $val;
+ }
+
+ # For Date Cfs, @values is empty when there is no changes (no datas in form input)
+ return @results if ( $cf->Type eq 'Date' && ! @values );
+
+ # For Date Cfs, @values is empty when there is no changes (no datas in form input)
+ return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
+
+ $cf_values->RedoSearch;
+ while ( my $cf_value = $cf_values->Next ) {
+ next if $values_hash{ $cf_value->id };
+
+ my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
+ Field => $cf,
+ ValueId => $cf_value->id
+ );
+ push( @results, $msg );
+ }
+ } elsif ( $arg eq 'Values' ) {
+ my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
+
+ # keep everything up to the point of difference, delete the rest
+ my $delete_flag;
+ foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
+ if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
+ shift @values;
+ next;
+ }
+
+ $delete_flag ||= 1;
+ $old_cf->Delete;
+ }
+
+ # now add/replace extra things, if any
+ foreach my $value (@values) {
+ my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
+ Field => $cf,
+ Value => $value
+ );
+ push( @results, $msg );
+ }
+ } else {
+ push(
+ @results,
+ loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
+ $cf->Name, ref $args{'Object'},
+ $args{'Object'}->id
+ )
+ );
+ }
+ }
+ return @results;
+}
+
+
+=head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
+
+Returns an array of results messages.
+
+=cut
+
+sub ProcessTicketWatchers {
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+ my (@results);
+
+ my $Ticket = $args{'TicketObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ # Munge watchers
+
+ foreach my $key ( keys %$ARGSRef ) {
+
+ # Delete deletable watchers
+ if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
+ my ( $code, $msg ) = $Ticket->DeleteWatcher(
+ PrincipalId => $2,
+ Type => $1
+ );
+ push @results, $msg;
+ }
+
+ # Delete watchers in the simple style demanded by the bulk manipulator
+ elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
+ my ( $code, $msg ) = $Ticket->DeleteWatcher(
+ Email => $ARGSRef->{$key},
+ Type => $1
+ );
+ push @results, $msg;
+ }
+
+ # Add new wathchers by email address
+ elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
+ and $key =~ /^WatcherTypeEmail(\d*)$/ )
+ {
+
+ #They're in this order because otherwise $1 gets clobbered :/
+ my ( $code, $msg ) = $Ticket->AddWatcher(
+ Type => $ARGSRef->{$key},
+ Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
+ );
+ push @results, $msg;
+ }
+
+ #Add requestors in the simple style demanded by the bulk manipulator
+ elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
+ my ( $code, $msg ) = $Ticket->AddWatcher(
+ Type => $1,
+ Email => $ARGSRef->{$key}
+ );
+ push @results, $msg;
+ }
+
+ # Add new watchers by owner
+ elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
+ my $principal_id = $1;
+ my $form = $ARGSRef->{$key};
+ foreach my $value ( ref($form) ? @{$form} : ($form) ) {
+ next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
+
+ my ( $code, $msg ) = $Ticket->AddWatcher(
+ Type => $value,
+ PrincipalId => $principal_id
+ );
+ push @results, $msg;
+ }
+ }
+
+ }
+ return (@results);
+}
+
+
+
+=head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
+
+Returns an array of results messages.
+
+=cut
+
+sub ProcessTicketDates {
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $Ticket = $args{'TicketObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ my (@results);
+
+ # Set date fields
+ my @date_fields = qw(
+ Told
+ Resolved
+ Starts
+ Started
+ Due
+ WillResolve
+ );
+
+ #Run through each field in this list. update the value if apropriate
+ foreach my $field (@date_fields) {
+ next unless exists $ARGSRef->{ $field . '_Date' };
+ next if $ARGSRef->{ $field . '_Date' } eq '';
+
+ my ( $code, $msg );
+
+ my $DateObj = RT::Date->new( $session{'CurrentUser'} );
+ $DateObj->Set(
+ Format => 'unknown',
+ Value => $ARGSRef->{ $field . '_Date' }
+ );
+
+ my $obj = $field . "Obj";
+ if ( ( defined $DateObj->Unix )
+ and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
+ {
+ my $method = "Set$field";
+ my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
+ push @results, "$msg";
+ }
+ }
+
+ # }}}
+ return (@results);
+}
+
+
+
+=head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
+
+Returns an array of results messages.
+
+=cut
+
+sub ProcessTicketLinks {
+ my %args = (
+ TicketObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $Ticket = $args{'TicketObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
+
+ #Merge if we need to
+ if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
+ $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
+ my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
+ push @results, $msg;
+ }
+
+ return (@results);
+}
+
+
+sub ProcessRecordLinks {
+ my %args = (
+ RecordObj => undef,
+ ARGSRef => undef,
+ @_
+ );
+
+ my $Record = $args{'RecordObj'};
+ my $ARGSRef = $args{'ARGSRef'};
+
+ my (@results);
+
+ # Delete links that are gone gone gone.
+ foreach my $arg ( keys %$ARGSRef ) {
+ if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
+ my $base = $1;
+ my $type = $2;
+ my $target = $3;
+
+ my ( $val, $msg ) = $Record->DeleteLink(
+ Base => $base,
+ Type => $type,
+ Target => $target
+ );
+
+ push @results, $msg;
+
+ }
+
+ }
+
+ my @linktypes = qw( DependsOn MemberOf RefersTo );
+
+ foreach my $linktype (@linktypes) {
+ if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
+ $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
+ if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
+
+ for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
+ next unless $luri;
+ $luri =~ s/\s+$//; # Strip trailing whitespace
+ my ( $val, $msg ) = $Record->AddLink(
+ Target => $luri,
+ Type => $linktype
+ );
+ push @results, $msg;
+ }
+ }
+ if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
+ $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
+ if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
+
+ for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
+ next unless $luri;
+ my ( $val, $msg ) = $Record->AddLink(
+ Base => $luri,
+ Type => $linktype
+ );
+
+ push @results, $msg;
+ }
+ }
+ }
+
+ return (@results);
+}
+
+=head2 ProcessTransactionSquelching
+
+Takes a hashref of the submitted form arguments, C<%ARGS>.
+
+Returns a hash of squelched addresses.
+
+=cut
+
+sub ProcessTransactionSquelching {
+ my $args = shift;
+ my %checked = map { $_ => 1 } grep { defined }
+ ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
+ defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
+ () );
+ my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
+ return %squelched;
+}
+
+=head2 _UploadedFile ( $arg );
+
+Takes a CGI parameter name; if a file is uploaded under that name,
+return a hash reference suitable for AddCustomFieldValue's use:
+C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
+
+Returns C<undef> if no files were uploaded in the C<$arg> field.
+
+=cut
+
+sub _UploadedFile {
+ my $arg = shift;
+ my $cgi_object = $m->cgi_object;
+ my $fh = $cgi_object->upload($arg) or return undef;
+ my $upload_info = $cgi_object->uploadInfo($fh);
+
+ my $filename = "$fh";
+ $filename =~ s#^.*[\\/]##;
+ binmode($fh);
+
+ return {
+ Value => $filename,
+ LargeContent => do { local $/; scalar <$fh> },
+ ContentType => $upload_info->{'Content-Type'},
+ };
+}
+
+sub GetColumnMapEntry {
+ my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
+
+ # deal with the simplest thing first
+ if ( $args{'Map'}{ $args{'Name'} } ) {
+ return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
+ }
+
+ # complex things
+ elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
+ $subkey =~ s/^\{(.*)\}$/$1/;
+ return undef unless $args{'Map'}->{$mainkey};
+ return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
+ unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
+
+ return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
+ }
+ return undef;
+}
+
+sub ProcessColumnMapValue {
+ my $value = shift;
+ my %args = ( Arguments => [], Escape => 1, @_ );
+
+ if ( ref $value ) {
+ if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
+ my @tmp = $value->( @{ $args{'Arguments'} } );
+ return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
+ } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
+ return join '', map ProcessColumnMapValue( $_, %args ), @$value;
+ } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
+ return $$value;
+ }
+ }
+
+ return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
+ return $value;
+}
+
+=head2 GetPrincipalsMap OBJECT, CATEGORIES
+
+Returns an array suitable for passing to /Admin/Elements/EditRights with the
+principal collections mapped from the categories given.
+
+=cut
+
+sub GetPrincipalsMap {
+ my $object = shift;
+ my @map;
+ for (@_) {
+ if (/System/) {
+ my $system = RT::Groups->new($session{'CurrentUser'});
+ $system->LimitToSystemInternalGroups();
+ $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
+ push @map, [
+ 'System' => $system, # loc_left_pair
+ 'Type' => 1,
+ ];
+ }
+ elsif (/Groups/) {
+ my $groups = RT::Groups->new($session{'CurrentUser'});
+ $groups->LimitToUserDefinedGroups();
+ $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
+
+ # Only show groups who have rights granted on this object
+ $groups->WithGroupRight(
+ Right => '',
+ Object => $object,
+ IncludeSystemRights => 0,
+ IncludeSubgroupMembers => 0,
+ );
+
+ push @map, [
+ 'User Groups' => $groups, # loc_left_pair
+ 'Name' => 0
+ ];
+ }
+ elsif (/Roles/) {
+ my $roles = RT::Groups->new($session{'CurrentUser'});
+
+ if ($object->isa('RT::System')) {
+ $roles->LimitToRolesForSystem();
+ }
+ elsif ($object->isa('RT::Queue')) {
+ $roles->LimitToRolesForQueue($object->Id);
+ }
+ else {
+ $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
+ next;
+ }
+ $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
+ push @map, [
+ 'Roles' => $roles, # loc_left_pair
+ 'Type' => 1
+ ];
+ }
+ elsif (/Users/) {
+ my $Users = RT->PrivilegedUsers->UserMembersObj();
+ $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
+
+ # Only show users who have rights granted on this object
+ my $group_members = $Users->WhoHaveGroupRight(
+ Right => '',
+ Object => $object,
+ IncludeSystemRights => 0,
+ IncludeSubgroupMembers => 0,
+ );
+
+ # Limit to UserEquiv groups
+ my $groups = $Users->NewAlias('Groups');
+ $Users->Join(
+ ALIAS1 => $groups,
+ FIELD1 => 'id',
+ ALIAS2 => $group_members,
+ FIELD2 => 'GroupId'
+ );
+ $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
+ $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
+
+
+ my $display = sub {
+ $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
+ };
+ push @map, [
+ 'Users' => $Users, # loc_left_pair
+ $display => 0
+ ];
+ }
+ }
+ return @map;
+}
+
+=head2 _load_container_object ( $type, $id );
+
+Instantiate container object for saving searches.
+
+=cut
+
+sub _load_container_object {
+ my ( $obj_type, $obj_id ) = @_;
+ return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
+}
+
+=head2 _parse_saved_search ( $arg );
+
+Given a serialization string for saved search, and returns the
+container object and the search id.
+
+=cut
+
+sub _parse_saved_search {
+ my $spec = shift;
+ return unless $spec;
+ if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
+ return;
+ }
+ my $obj_type = $1;
+ my $obj_id = $2;
+ my $search_id = $3;
+
+ return ( _load_container_object( $obj_type, $obj_id ), $search_id );
+}
+
+=head2 ScrubHTML content
+
+Removes unsafe and undesired HTML from the passed content
+
+=cut
+
+my $SCRUBBER;
+sub ScrubHTML {
+ my $Content = shift;
+ $SCRUBBER = _NewScrubber() unless $SCRUBBER;
+
+ $Content = '' if !defined($Content);
+ return $SCRUBBER->scrub($Content);
+}
+
+=head2 _NewScrubber
+
+Returns a new L<HTML::Scrubber> object.
+
+If you need to be more lax about what HTML tags and attributes are allowed,
+create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
+following:
+
+ package HTML::Mason::Commands;
+ # Let tables through
+ push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
+ 1;
+
+=cut
+
+our @SCRUBBER_ALLOWED_TAGS = qw(
+ A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
+ H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
+);
+
+our %SCRUBBER_ALLOWED_ATTRIBUTES = (
+ # Match http, https, ftp, mailto and relative urls
+ # XXX: we also scrub format strings with this module then allow simple config options
+ href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
+ face => 1,
+ size => 1,
+ target => 1,
+ style => qr{
+ ^(?:\s*
+ (?:(?:background-)?color: \s*
+ (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
+ \#[a-f0-9]{3,6} | # #fff or #ffffff
+ [\w\-]+ # green, light-blue, etc.
+ ) |
+ text-align: \s* \w+ |
+ font-size: \s* [\w.\-]+ |
+ font-family: \s* [\w\s"',.\-]+ |
+ font-weight: \s* [\w\-]+ |
+
+ # MS Office styles, which are probably fine. If we don't, then any
+ # associated styles in the same attribute get stripped.
+ mso-[\w\-]+?: \s* [\w\s"',.\-]+
+ )\s* ;? \s*)
+ +$ # one or more of these allowed properties from here 'till sunset
+ }ix,
+ dir => qr/^(rtl|ltr)$/i,
+ lang => qr/^\w+(-\w+)?$/,
+);
+
+our %SCRUBBER_RULES = ();
+
+sub _NewScrubber {
+ require HTML::Scrubber;
+ my $scrubber = HTML::Scrubber->new();
+ $scrubber->default(
+ 0,
+ {
+ %SCRUBBER_ALLOWED_ATTRIBUTES,
+ '*' => 0, # require attributes be explicitly allowed
+ },
+ );
+ $scrubber->deny(qw[*]);
+ $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
+ $scrubber->rules(%SCRUBBER_RULES);
+
+ # Scrubbing comments is vital since IE conditional comments can contain
+ # arbitrary HTML and we'd pass it right on through.
+ $scrubber->comment(0);
+
+ return $scrubber;
+}
+
+=head2 JSON
+
+Redispatches to L<RT::Interface::Web/EncodeJSON>
+
+=cut
+
+sub JSON {
+ RT::Interface::Web::EncodeJSON(@_);
+}
+
+package RT::Interface::Web;
+RT::Base->_ImportOverlays();
+
+1;
use Plack::Request;
use Plack::Response;
use Plack::Util;
-use Encode qw(encode_utf8);
sub PSGIApp {
my $self = shift;
$cleanup->();
return '';
}
- return utf8::is_utf8($_[0]) ? encode_utf8($_[0]) : $_[0];
+ # XXX: Ideally, responses should flag if they need
+ # to be encoded, rather than relying on the UTF-8
+ # flag
+ return Encode::encode("UTF-8",$_[0]) if utf8::is_utf8($_[0]);
return $_[0];
};
});
my ($val, $msg) = $cf->_CanonicalizeValue(\%args);
return ($val, $msg) unless $val;
- if ( defined $args{'Content'} && length( Encode::encode_utf8($args{'Content'}) ) > 255 ) {
+ my $encoded = Encode::encode("UTF-8", $args{'Content'});
+ if ( defined $args{'Content'} && length( $encoded ) > 255 ) {
if ( defined $args{'LargeContent'} && length $args{'LargeContent'} ) {
$RT::Logger->error("Content is longer than 255 bytes and LargeContent specified");
}
use RT::I18N;
use RT::User;
use RT::Attributes;
-use Encode qw();
our $_TABLE_ATTR = { };
use base RT->Config->Get('RecordBaseClass');
return undef if (!defined $value);
+ # Pg returns character columns as character strings; mysql and
+ # sqlite return them as bytes. While mysql can be made to return
+ # characters, using the mysql_enable_utf8 flag, the "Content" column
+ # is bytes on mysql and characters on Postgres, making true
+ # consistency impossible.
if ( $args{'decode_utf8'} ) {
- if ( !utf8::is_utf8($value) ) {
+ if ( !utf8::is_utf8($value) ) { # mysql/sqlite
utf8::decode($value);
}
- }
- else {
+ } else {
if ( utf8::is_utf8($value) ) {
utf8::encode($value);
}
=cut
sub _EncodeLOB {
- my $self = shift;
- my $Body = shift;
- my $MIMEType = shift || '';
- my $Filename = shift;
-
- my $ContentEncoding = 'none';
+ my $self = shift;
+ my $Body = shift;
+ my $MIMEType = shift || '';
+ my $Filename = shift;
- #get the max attachment length from RT
- my $MaxSize = RT->Config->Get('MaxAttachmentSize');
+ my $ContentEncoding = 'none';
- #if the current attachment contains nulls and the
- #database doesn't support embedded nulls
+ RT::Util::assert_bytes( $Body );
- if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
+ #get the max attachment length from RT
+ my $MaxSize = RT->Config->Get('MaxAttachmentSize');
- # set a flag telling us to mimencode the attachment
- $ContentEncoding = 'base64';
+ #if the current attachment contains nulls and the
+ #database doesn't support embedded nulls
- #cut the max attchment size by 25% (for mime-encoding overhead.
- $RT::Logger->debug("Max size is $MaxSize");
- $MaxSize = $MaxSize * 3 / 4;
- # Some databases (postgres) can't handle non-utf8 data
- } elsif ( !$RT::Handle->BinarySafeBLOBs
- && $Body =~ /\P{ASCII}/
- && !Encode::is_utf8( $Body, 1 ) ) {
- $ContentEncoding = 'quoted-printable';
- }
+ if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
- #if the attachment is larger than the maximum size
- if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
+ # set a flag telling us to mimencode the attachment
+ $ContentEncoding = 'base64';
- # if we're supposed to truncate large attachments
- if (RT->Config->Get('TruncateLongAttachments')) {
+ #cut the max attchment size by 25% (for mime-encoding overhead.
+ $RT::Logger->debug("Max size is $MaxSize");
+ $MaxSize = $MaxSize * 3 / 4;
+ # Some databases (postgres) can't handle non-utf8 data
+ } elsif ( !$RT::Handle->BinarySafeBLOBs
+ && $Body =~ /\P{ASCII}/
+ && !Encode::is_utf8( $Body, 1 ) ) {
+ $ContentEncoding = 'quoted-printable';
+ }
- # truncate the attachment to that length.
- $Body = substr( $Body, 0, $MaxSize );
+ #if the attachment is larger than the maximum size
+ if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
- }
+ # if we're supposed to truncate large attachments
+ if (RT->Config->Get('TruncateLongAttachments')) {
- # elsif we're supposed to drop large attachments on the floor,
- elsif (RT->Config->Get('DropLongAttachments')) {
+ # truncate the attachment to that length.
+ $Body = substr( $Body, 0, $MaxSize );
- # drop the attachment on the floor
- $RT::Logger->info( "$self: Dropped an attachment of size "
- . length($Body));
- $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
- $Filename .= ".txt" if $Filename;
- return ("none", "Large attachment dropped", "text/plain", $Filename );
- }
}
- # if we need to mimencode the attachment
- if ( $ContentEncoding eq 'base64' ) {
-
- # base64 encode the attachment
- Encode::_utf8_off($Body);
- $Body = MIME::Base64::encode_base64($Body);
+ # elsif we're supposed to drop large attachments on the floor,
+ elsif (RT->Config->Get('DropLongAttachments')) {
- } elsif ($ContentEncoding eq 'quoted-printable') {
- Encode::_utf8_off($Body);
- $Body = MIME::QuotedPrint::encode($Body);
+ # drop the attachment on the floor
+ $RT::Logger->info( "$self: Dropped an attachment of size "
+ . length($Body));
+ $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
+ $Filename .= ".txt" if $Filename;
+ return ("none", "Large attachment dropped", "text/plain", $Filename );
}
+ }
+ # if we need to mimencode the attachment
+ if ( $ContentEncoding eq 'base64' ) {
+ # base64 encode the attachment
+ $Body = MIME::Base64::encode_base64($Body);
- return ($ContentEncoding, $Body, $MIMEType, $Filename );
+ } elsif ($ContentEncoding eq 'quoted-printable') {
+ $Body = MIME::QuotedPrint::encode($Body);
+ }
+ return ($ContentEncoding, $Body, $MIMEType, $Filename );
}
-=head2 _DecodeLOB
+=head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
Unpacks data stored in the database, which may be base64 or QP encoded
because of our need to store binary and badly encoded data in columns
RT::Interface::Web::DecodeARGS. This filter should only end up being
applied to old data from less UTF-8-safe versions of RT.
+If the passed C<ContentType> includes a character set, that will be used
+to decode textual data; the default character set is UTF-8. This is
+necessary because while we attempt to store textual data as UTF-8, the
+definition of "textual" has migrated over time, and thus we may now need
+to attempt to decode data that was previously not trancoded on insertion.
+
Important Note - This function expects an octet string and returns a
character string for non-binary data.
my $ContentEncoding = shift || 'none';
my $Content = shift;
+ RT::Util::assert_bytes( $Content );
+
if ( $ContentEncoding eq 'base64' ) {
$Content = MIME::Base64::decode_base64($Content);
}
return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
}
if ( RT::I18N::IsTextualContentType($ContentType) ) {
- $Content = Encode::decode('UTF-8',$Content,Encode::FB_PERLQQ) unless Encode::is_utf8($Content);
+ my $entity = MIME::Entity->new();
+ $entity->head->add("Content-Type", $ContentType);
+ $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
+ my $charset = RT::I18N::_FindOrGuessCharset($entity);
+ $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
+
+ $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
}
- return ($Content);
+ return ($Content);
}
# A helper table for links mapping to make it easier
CREATE INDEX SHREDDER_TXN3 ON Transactions(Type, OldValue);
CREATE INDEX SHREDDER_TXN4 ON Transactions(Type, NewValue)
+ CREATE INDEX SHREDDER_ATTACHMENTS1 ON Attachments(Creator);
+
=head1 INFORMATION FOR DEVELOPERS
=head2 General API
Returns L<MIME::Entity> object parsed using L</Parse> method. Returns
undef if last call to L</Parse> failed or never be called.
-Note that content of the template is UTF-8, but L<MIME::Parser> is not
-good at handling it and all data of the entity should be treated as
-octets and converted to perl strings using Encode::decode_utf8 or
-something else.
+Note that content of the template is characters, but the contents of all
+L<MIME::Entity> objects (including the one returned by this function,
+are bytes in UTF-8.
=cut
### Should we forgive normally-fatal errors?
$parser->ignore_errors(1);
- # MIME::Parser doesn't play well with perl strings
- utf8::encode($content);
+ # Always provide bytes, not characters, to MIME objects
+ $content = Encode::encode( 'UTF-8', $content );
$self->{'MIMEObj'} = eval { $parser->parse_data( \$content ) };
if ( my $error = $@ || $parser->last_error ) {
$RT::Logger->error( "$error" );
require HTML::FormatText;
require HTML::TreeBuilder;
- require Encode;
- # need to decode_utf8, see the doc of MIMEObj method
+ # MIME objects are always bytes, not characters
my $tree = HTML::TreeBuilder->new_from_content(
- Encode::decode_utf8($new_entity->bodyhandle->as_string)
+ Encode::decode( 'UTF-8', $new_entity->bodyhandle->as_string)
);
- $new_entity->bodyhandle(MIME::Body::InCore->new(
- \(scalar HTML::FormatText->new(
- leftmargin => 0,
- rightmargin => 78,
- )->format( $tree ))
- ));
+ my $text = HTML::FormatText->new(
+ leftmargin => 0,
+ rightmargin => 78,
+ )->format( $tree );
+ $text = Encode::encode( "UTF-8", $text );
+
+ $new_entity->bodyhandle(MIME::Body::InCore->new( \$text ));
$tree->delete;
$orig_entity->add_part($new_entity, 0); # plain comes before html
$class->set_config_wrapper;
+ $class->encode_output;
+
my $screen_logger = $RT::Logger->remove( 'screen' );
require Log::Dispatch::Perl;
$RT::Logger->add( Log::Dispatch::Perl->new
};
}
+sub encode_output {
+ my $builder = Test::More->builder;
+ binmode $builder->output, ":encoding(utf8)";
+ binmode $builder->failure_output, ":encoding(utf8)";
+ binmode $builder->todo_output, ":encoding(utf8)";
+}
+
sub bootstrap_db {
my $self = shift;
my %args = @_;
$filter = $SIG{__WARN__};
}
$SIG{__WARN__} = sub {
- if ($filter) {
- my $status = $filter->(@_);
- if ($status and $status eq 'IGNORE') {
- return; # pretend the bad dream never happened
- }
- }
+ $filter->(@_) if $filter;
# Avoid reporting this anonymous call frame as the source of the warning.
goto &$Test_NoWarnings_Catcher;
};
if ( my $content = delete $args{'Content'} ) {
$args{'MIMEObj'} = MIME::Entity->build(
- From => $args{'Requestor'},
- Subject => $args{'Subject'},
- Data => $content,
+ From => Encode::encode( "UTF-8", $args{'Requestor'} ),
+ Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ),
+ Type => "text/plain",
+ Charset => "UTF-8",
+ Data => Encode::encode( "UTF-8", $content ),
);
}
}
$args{$date} = $dateobj->ISO;
}
- $args{'mimeobj'} = MIME::Entity->new();
- $args{'mimeobj'}->build(
- Type => ( $args{'contenttype'} || 'text/plain' ),
- Data => ($args{'content'} || '')
+ $args{'mimeobj'} = MIME::Entity->build(
+ Type => ( $args{'contenttype'} || 'text/plain' ),
+ Charset => "UTF-8",
+ Data => Encode::encode("UTF-8", ($args{'content'} || ''))
);
return (%args);
}
unless ( $args{'MIMEObj'} ) {
+ my $data = ref $args{'Content'}? $args{'Content'} : [ $args{'Content'} ];
$args{'MIMEObj'} = MIME::Entity->build(
- Data => ( ref $args{'Content'}? $args{'Content'}: [ $args{'Content'} ] )
+ Type => "text/plain",
+ Charset => "UTF-8",
+ Data => [ map {Encode::encode("UTF-8", $_)} @{$data} ],
);
}
my $addresses = join ', ', (
map { RT::User->CanonicalizeEmailAddress( $_->address ) }
Email::Address->parse( $args{ $type . 'MessageTo' } ) );
- $args{'MIMEObj'}->head->replace( 'RT-Send-' . $type, Encode::encode_utf8( $addresses ) );
+ $args{'MIMEObj'}->head->replace( 'RT-Send-' . $type, Encode::encode( "UTF-8", $addresses ) );
}
}
foreach my $argument (qw(Encrypt Sign)) {
$args{'MIMEObj'}->head->replace(
- "X-RT-$argument" => Encode::encode_utf8( $args{ $argument } )
+ "X-RT-$argument" => Encode::encode( "UTF-8", $args{ $argument } )
) if defined $args{ $argument };
}
# internal Message-ID now, so all emails sent because of this
# message have a common Message-ID
my $org = RT->Config->Get('Organization');
- my $msgid = $args{'MIMEObj'}->head->get('Message-ID');
+ my $msgid = Encode::decode( "UTF-8", $args{'MIMEObj'}->head->get('Message-ID') );
unless (defined $msgid && $msgid =~ /<(rt-.*?-\d+-\d+)\.(\d+-0-0)\@\Q$org\E>/) {
$args{'MIMEObj'}->head->set(
- 'RT-Message-ID' => Encode::encode_utf8(
+ 'RT-Message-ID' => Encode::encode( "UTF-8",
RT::Interface::Email::GenMessageId( Ticket => $self )
)
);
#Record the correspondence (write the transaction)
my ( $Trans, $msg, $TransObj ) = $self->_NewTransaction(
Type => $args{'NoteType'},
- Data => ( $args{'MIMEObj'}->head->get('subject') || 'No Subject' ),
+ Data => ( Encode::decode( "UTF-8", $args{'MIMEObj'}->head->get('Subject') ) || 'No Subject' ),
TimeTaken => $args{'TimeTaken'},
MIMEObj => $args{'MIMEObj'},
CommitScrips => $args{'CommitScrips'},
}
my $Message = MIME::Entity->build(
+ Subject => defined $args{UpdateSubject} ? Encode::encode( "UTF-8", $args{UpdateSubject} ) : "",
Type => 'text/plain',
- Subject => defined $args{UpdateSubject} ? Encode::encode_utf8( $args{UpdateSubject} ) : "",
Charset => 'UTF-8',
- Data => $args{'UpdateContent'} || "",
+ Data => Encode::encode("UTF-8", $args{'UpdateContent'} || ""),
);
my ( $Transaction, $Description, $Object ) = $self->$action(
my $self = shift;
my %args = @_;
my $Message = MIME::Entity->build(
- Type => 'text/plain',
- Subject => defined $args{Subject} ? Encode::encode_utf8( $args{'Subject'} ) : "",
+ Subject => defined $args{Subject} ? Encode::encode( "UTF-8", $args{'Subject'} ) : "",
(defined $args{'Cc'} ?
- ( Cc => Encode::encode_utf8( $args{'Cc'} ) ) : ()),
+ ( Cc => Encode::encode( "UTF-8", $args{'Cc'} ) ) : ()),
+ Type => 'text/plain',
Charset => 'UTF-8',
- Data => $args{'Content'} || "",
+ Data => Encode::encode( "UTF-8", $args{'Content'} || ""),
);
my ( $Transaction, $Object, $Description ) = $self->Create(
$self->_CloseParen;
}
elsif ( $op eq '=' || $op eq '!=' || $op eq '<>' ) {
- if ( length( Encode::encode_utf8($value) ) < 256 ) {
+ if ( length( Encode::encode( "UTF-8", $value) ) < 256 ) {
$self->_SQLLimit(
ALIAS => $ObjectCFs,
FIELD => 'Content',
use RT::Principals;
use RT::ACE;
use RT::Interface::Email;
-use Encode;
use Text::Password::Pronounceable;
sub _OverlayAccessible {
AuthSystem => { public => 1, admin => 1 },
Gecos => { public => 1, admin => 1 },
PGPKey => { public => 1, admin => 1 },
- PrivateKey => { admin => 1 },
}
}
my $sha = Digest::SHA->new(512);
$sha->add($salt);
- $sha->add(encode_utf8($password));
+ $sha->add(Encode::encode( 'UTF-8', $password));
return join("!", "", "sha512", $salt, $sha->b64digest);
}
my $hash = MIME::Base64::decode_base64($stored);
# Decoding yields 30 byes; first 4 are the salt, the rest are substr(SHA256,0,26)
my $salt = substr($hash, 0, 4, "");
- return 0 unless substr(Digest::SHA::sha256($salt . Digest::MD5::md5(encode_utf8($value))), 0, 26) eq $hash;
+ return 0 unless substr(Digest::SHA::sha256($salt . Digest::MD5::md5(Encode::encode( "UTF-8", $value))), 0, 26) eq $hash;
} elsif (length $stored == 32) {
# Hex nonsalted-md5
- return 0 unless Digest::MD5::md5_hex(encode_utf8($value)) eq $stored;
+ return 0 unless Digest::MD5::md5_hex(Encode::encode( "UTF-8", $value)) eq $stored;
} elsif (length $stored == 22) {
# Base64 nonsalted-md5
- return 0 unless Digest::MD5::md5_base64(encode_utf8($value)) eq $stored;
+ return 0 unless Digest::MD5::md5_base64(Encode::encode( "UTF-8", $value)) eq $stored;
} elsif (length $stored == 13) {
# crypt() output
- return 0 unless crypt(encode_utf8($value), $stored) eq $stored;
+ return 0 unless crypt(Encode::encode( "UTF-8", $value), $stored) eq $stored;
} else {
$RT::Logger->warning("Unknown password form");
return 0;
my $self = shift;
my $protect = shift;
- my $str = $self->AuthToken . $protect;
- utf8::encode($str);
+ my $str = Encode::encode( "UTF-8", $self->AuthToken . $protect );
return substr(Digest::MD5::md5_hex($str),0,16);
}
my $auth_string = shift;
my $protected = shift;
- my $str = $self->AuthToken . $protected;
- utf8::encode( $str );
+ my $str = Encode::encode( "UTF-8", $self->AuthToken . $protected );
return $auth_string eq substr(Digest::MD5::md5_hex($str),0,16);
}
my $name = _PrefName (shift);
my $default = shift;
- my $attr = RT::Attribute->new( $self->CurrentUser );
- $attr->LoadByNameAndObject( Object => $self, Name => $name );
-
- my $content = $attr->Id ? $attr->Content : undef;
+ my ($attr) = $self->Attributes->Named( $name );
+ my $content = $attr ? $attr->Content : undef;
unless ( ref $content eq 'HASH' ) {
return defined $content ? $content : $default;
}
return (0, $self->loc("No permission to set preferences"))
unless $self->CurrentUserCanModify('Preferences');
- my $attr = RT::Attribute->new( $self->CurrentUser );
- $attr->LoadByNameAndObject( Object => $self, Name => $name );
- if ( $attr->Id ) {
+ my ($attr) = $self->Attributes->Named( $name );
+ if ( $attr ) {
my ($ok, $msg) = $attr->SetContent( $value );
return (1, "No updates made")
if $msg eq "That is already the current value";
return (0, $self->loc("No permission to set preferences"))
unless $self->CurrentUserCanModify('Preferences');
- my $attr = RT::Attribute->new( $self->CurrentUser );
- $attr->LoadByNameAndObject( Object => $self, Name => $name );
- if ( $attr->Id ) {
- return $attr->Delete;
- }
+ my ($attr) = $self->DeleteAttribute( $name );
+ return (0, $self->loc("Preferences were not found"))
+ unless $attr;
- return (0, $self->loc("Preferences were not found"));
+ return 1;
}
=head2 Stylesheet
my $self = shift;
my $key = shift;
- unless ($self->CurrentUserCanModify('PrivateKey')) {
+ # Users should not be able to change their own PrivateKey values
+ unless ( $self->CurrentUser->HasRight(Right => 'AdminUsers', Object => $RT::System) ) {
return (0, $self->loc("Permission Denied"));
}
$head = $head->head if $head->isa('MIME::Entity');
for my $attr_name (qw( content-disposition.filename content-type.name )) {
- my $value = $head->mime_attr($attr_name);
+ my $value = Encode::decode("UTF-8",$head->mime_attr($attr_name));
if ( defined $value && $value =~ /\S/ ) {
return $value;
}
return;
}
+sub assert_bytes {
+ my $string = shift;
+ return unless utf8::is_utf8($string);
+ return unless $string =~ /([^\x00-\x7F])/;
+
+ my $msg;
+ if (ord($1) > 255) {
+ $msg = "Expecting a byte string, but was passed characters";
+ } else {
+ $msg = "Expecting a byte string, but was possibly passed charcters;"
+ ." if the string is actually bytes, please use utf8::downgrade";
+ }
+ $RT::Logger->warn($msg, Carp::longmess());
+
+}
+
+
RT::Base->_ImportOverlays();
1;
}
# Set our sender and recipient.
- $digest_template->MIMEObj->head->replace( 'From', RT::Config->Get('CorrespondAddress') );
- $digest_template->MIMEObj->head->replace( 'To', $to );
+ $digest_template->MIMEObj->head->replace(
+ 'From', Encode::encode( "UTF-8", RT::Config->Get('CorrespondAddress') ) );
+ $digest_template->MIMEObj->head->replace(
+ 'To', Encode::encode( "UTF-8", $to ) );
if ($print) {
$digest_template->MIMEObj->print;
Outputs INSERT queries into file. This dump can be used to restore data
after wiping out.
-By default creates files
-F<< <RT_home>/var/data/RT-Shredder/<ISO_date>-XXXX.sql >>
+By default creates files named F<< <ISO_date>-XXXX.sql >> in the current
+directory.
=head2 --object (DEPRECATED)
.
$deps{'POSTGRESQL'} = [ text_to_hash( << '.') ];
+DBIx::SearchBuilder 1.66
DBD::Pg 1.43
.
my %AVOID = (
'DBD::Oracle' => [qw(1.23)],
- 'DBD::Pg' => [qw(3.3.0)],
'Email::Address' => [qw(1.893 1.894)],
'Devel::StackTrace' => [qw(1.28 1.29)],
);
<&| /Widgets/TitleBox, title => loc('Access control') &>
<input type="hidden" class="hidden" name="SetEnabled" value="1" />
-<input type="checkbox" class="checkbox" name="Enabled" value="1" <%$EnabledChecked%> />
+<input type="checkbox" class="checkbox" name="Enabled" value="1" <%$EnabledChecked||''%> />
<&|/l&>Let this user access RT</&><br />
next if $skip_update;
if ( $ARGS{ "Approval-" . $ticket->Id . "-Notes" } ) {
- my $notes = MIME::Entity->build(
- Data => [ $ARGS{ "Approval-" . $ticket->Id . "-Notes" } ]
- );
- RT::I18N::SetMIMEEntityToUTF8($notes); # convert text parts into utf-8
-
- my ( $notesval, $notesmsg ) = $ticket->Correspond( MIMEObj => $notes );
+ my ( $notesval, $notesmsg ) = $ticket->Correspond(
+ Content => $ARGS{ "Approval-" . $ticket->Id . "-Notes" }
+ );
if ($notesval) {
push ( @actions, loc("Approval #[_1]: Notes recorded",$ticket->Id ));
} else {
--- /dev/null
+<%ARGS>
+ $Date => undef,
+ @Tickets => ()
+ $slots => $default_slots,
+ $sday => undef,
+ $tod_row => undef,
+ $timestep => $default_timestep,
+ @username => ()
+</%ARGS>
+<%SHARED>
+my @slots = ( [], [], [], [], [], [], [] );
+</%SHARED>
+% #for my $t ( @{ $Tickets{$date->strftime("%F")} } ) {
+% for my $t (@Tickets) {
+%
+% my($sm, $sh) = ($t->StartsObj->Localtime('user'))[1,2];
+% my $starts = $sh*60 + $sm;
+%
+% if ( RTx::Calendar::LocalDate($t->StartsObj->Unix) eq $Date->strftime('%F') #today
+% && $starts >= $tod_row && $starts < ($tod_row + $timestep) ) {
+% #then we're a new entry, find a slot for us
+% my $s = 0;
+% while ( ref($slots[$sday]->[$s]) ) { $s++ }
+% $slots[$sday]->[$s] = [ $t->Id, $t ];
+% }
+%
+% my($dm, $dh) = ($t->DueObj->Localtime('user'))[1,2];
+% my $due = $dh*60 + $dm;
+%
+% if ( RTx::Calendar::LocalDate($t->DueObj->Unix) eq $Date->strftime('%F') #today
+% && $due <= $tod_row && $due > ($tod_row + $timestep ) ) {
+% #then find our slot and remove us
+% @{ $slots[$sday] } =
+% map { (!ref($_) || $_->[0] != $t->Id) ? $_ : '' }
+% @{ $slots[$sday] };
+% }
+%
+% }
+%
+% pop @{ $slots[$sday] } while @{ $slots[$sday] } && !ref($slots[$sday]->[-1]);
+%
+% #now display:
+%
+% if ( scalar(@{$slots[$sday]}) > $slots ) {
+% #overflow situation, eek... could be handled better, how?
+
+ <td colspan=<%$slots%>
+ class="weekly
+%# <% $is_today ? 'today'
+%# : $is_yesterday ? 'yesterday'
+%# : $is_aweekago ? 'aweekago'
+%# : ''
+%# %>
+ "
+ >MULTIPLE
+ </td>
+
+% } else {
+%
+% foreach my $slot ( @{ $slots[$sday] } ) {
+% my( $id, $ticket ) = @$slot;
+
+ <td class="weekly
+%# <% $is_today ? 'today'
+%# : $is_yesterday ? 'yesterday'
+%# : $is_aweekago ? 'aweekago'
+%# : ''
+%# %>
+ "
+ ><% $id %>
+ </td>
+
+% }
+%
+% if ( scalar(@{$slots[$sday]}) < $slots ) {
+
+ <td colspan=<% $slots - scalar(@{$slots[$sday]}) %>
+ class="weekly
+%# <% $is_today ? 'today'
+%# : $is_yesterday ? 'yesterday'
+%# : $is_aweekago ? 'aweekago'
+%# : ''
+%# %>
+ "
+ >
+ </td>
+% }
+%
+% }
+<%ONCE>
+my $default_slots = RT->Config->Get('CalendarWeeklySlots') || 5;
+my $default_timestep = RT->Config->Get('CalendarWeeklySizeMin') || 30; #1/2h
+</%ONCE>
%#
%# END BPS TAGGED BLOCK }}}
% my $name = $NamePrefix.$CustomField->Id.'-Values';
-<& /Elements/SelectDate, Name => "$name", current => 0, ShowTime => 0 &> (<%$DateObj->AsString(Time => 0, Timezone => 'utc')%>)
+<& /Elements/SelectDate, Name => "$name", current => 0, ShowTime => 0, $KeepValue && $Default ? (Default => $Default) : () &> (<%$DateObj->AsString(Time => 0, Timezone => 'utc')%>)
<%INIT>
my $DateObj = RT::Date->new ( $session{'CurrentUser'} );
$Default => undef
$Values => undef
$MaxValues => 1
+$KeepValue => undef
</%ARGS>
%#
%# END BPS TAGGED BLOCK }}}
% my $name = $NamePrefix.$CustomField->Id.'-Values';
-<& /Elements/SelectDate, Name => "$name", current => 0 &> (<%$DateObj->AsString%>)
+<& /Elements/SelectDate, Name => "$name", current => 0, $KeepValue && $Default ? (Default => $Default) : () &> (<%$DateObj->AsString($KeepValue ? ( Timezone => 'utc' ) : () )%>)
<%INIT>
my $DateObj = RT::Date->new ( $session{'CurrentUser'} );
$Values => undef
$MaxValues => 1
$Format => 'ISO'
+$KeepValue => undef
</%ARGS>
my $error = "WebRT: $Why";
$error .= " ($Details)" if defined $Details && length $Details;
-# TODO: Log::Dispatch isn't UTF-8 safe. Autrijus needs to talk to dave rolsky about getting this fixed
-use Encode ();
-Encode::_utf8_off($error);
-
-$RT::Logger->error($error);
+$RT::Logger->error( $error );
if ( $session{'REST'} ) {
$r->content_type('text/plain');
.ticket-summary .titlebox-title .left a, .ticket-summary .titlebox-title .left a:visited { color: #fff;}
-.unread-messages .titlebox , .unread-messages .titlebox-title .left {
- border: 1px solid #99a;
- border-right: 2px solid #aab;
- border-bottom: 2px solid #aab;
-
-}
-
-
-.unread-messages .titlebox {
- background-color: #dde;
-}
-
-.unread-messages .titlebox-title .left {
- background-color: #cce;
-}
-
.ticket-inactive {
text-decoration: line-through;
color: #666
display: none;
}
+.unread-messages .titlebox-content :link {
+ text-decoration: underline;
+}
<%init>
use Data::ICal;
use Data::ICal::Entry::Event;
-use Encode ();
my $path = $m->dhandler_arg;
my ($name, $auth, $search) = ($1, $2, $3);
# Unescape parts
$_ =~ s/\%([0-9a-z]{2})/chr(hex($1))/gei for $name, $search;
-# convert to perl strings
-$_ = Encode::decode_utf8( $_ ) for $name, $search;
+# Decode from bytes to characters
+$_ = Encode::decode( "UTF-8", $_ ) for $name, $search;
my $user = RT::User->new( RT->SystemUser );
$user->Load( $name );
'X-RT-Interface' => 'REST',
);
$ent->attach(
- 'Content-Type' => $changes{'Content-Type'} || 'text/plain',
- Data => $changes{Text},
+ Type => $changes{'Content-Type'} || 'text/plain',
+ Charset => "UTF-8",
+ Data => Encode::encode("UTF-8", $changes{Text} ),
) if $changes{Text};
$v{MIMEObj} =
MIME::Entity->build(
Type => "multipart/mixed",
- From => $session{CurrentUser}->EmailAddress,
- Subject => $v{Subject},
+ From => Encode::encode( "UTF-8", $session{CurrentUser}->EmailAddress ),
+ Subject => Encode::encode( "UTF-8", $v{Subject}),
'X-RT-Interface' => 'REST',
);
$v{MIMEObj}->attach(
- Data => $text,
- 'Content-Type' => $v{'Content-Type'} || 'text/plain',
+ Type => $v{'Content-Type'} || 'text/plain',
+ Charset => "UTF-8",
+ Data => Encode::encode( "UTF-8", $text ),
) if $text;
my ($status, $msg) = process_attachments($v{'MIMEObj'}, @atts);
unless ($status) {
Type => "multipart/mixed",
'X-RT-Interface' => 'REST',
);
-$ent->attach(Data => $k->{Text}) if $k->{Text};
+$ent->attach(
+ Type => "text/plain",
+ Charset => "UTF-8",
+ Data => Encode::encode( "UTF-8", $k->{Text} ),
+) if $k->{Text};
{
my ($res, $msg) = process_attachments($ent, @atts);
%#
%# END BPS TAGGED BLOCK }}}
<%INIT>
-use Encode ();
-
my $old_current_user;
if ( $m->request_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
# Unescape parts
$name =~ s/\%([0-9a-z]{2})/chr(hex($1))/gei;
- # convert to perl strings
- $name = Encode::decode_utf8($name);
+ # Decode from bytes to characters
+ $name = Encode::decode( "UTF-8", $name );
my $user = RT::User->new(RT->SystemUser);
$user->Load($name);
delete $col->{title}
if $col->{title} and $col->{title} =~ /^\s*#\s*$/;
return {
- header => Encode::encode_utf8(loc($col->{title} || $col->{attribute})),
+ header => loc($col->{title} || $col->{attribute}),
map => $m->comp(
"/Elements/ColumnMap",
Name => $col->{attribute},
# remove tabs from all field values, they screw up the tsv
$val = '' unless defined $val;
$val =~ s/(?:\n|\r)//g; $val =~ s{\t}{ }g;
- Encode::encode_utf8($val);
+ $val;
} @$col)."\n");
}
}
% $m->callback( CallbackName => 'AfterOwner', ARGSRef => \%ARGS );
- <& /Ticket/Elements/EditCustomFields, %ARGS, QueueObj => $QueueObj, InTable => 1 &>
- <& /Ticket/Elements/EditTransactionCustomFields, %ARGS, QueueObj => $QueueObj, InTable => 1 &>
+ <& /Ticket/Elements/EditCustomFields, %ARGS, QueueObj => $QueueObj, InTable => 1, KeepValue => 1 &>
+ <& /Ticket/Elements/EditTransactionCustomFields, %ARGS, QueueObj => $QueueObj, InTable => 1, KeepValue => 1 &>
</table>
</&>
% $m->callback( CallbackName => 'AfterBasics', QueueObj => $QueueObj, ARGSRef => \%ARGS );
</<% $CELL %>>
<<% $CELL %>>
<& /Elements/EditCustomField,
+ %ARGS,
CustomField => $CF,
- NamePrefix => $NamePrefix
+ NamePrefix => $NamePrefix,
&>
% if (my $msg = $m->notes('InvalidField-' . $CF->Id)) {
<br />
</ul>
% }
% if (RT->Config->Get('PreviewScripMessages')) {
- <textarea cols="80" rows="5"><%$scrip->ActionObj->TemplateObj->MIMEObj->as_string%></textarea>
+ <textarea cols="80" rows="5"><% Encode::decode( "UTF-8", $scrip->ActionObj->TemplateObj->MIMEObj->as_string ) %></textarea>
% }
<br />
% }
</div>
<%ARGS>
$Ticket
+$DisplayPath => $session{'CurrentUser'}->Privileged ? 'Ticket' : 'SelfService'
</%ARGS>
<%INIT>
return unless (RT->Config->Get( 'ShowUnreadMessageNotifications', $session{'CurrentUser'}));
my $txn = $Ticket->SeenUpTo or return;
-my $DisplayPath = $session{'CurrentUser'}->Privileged ? 'Ticket' : 'SelfService';
</%INIT>
%#
%# END BPS TAGGED BLOCK }}}
<div><img src="<% RT->Config->Get('WebPath') %>/Ticket/Graphs/<% $id %>?<% $m->comp('/Elements/QueryString', %ARGS) %>" usemap="#<% $graph->{'NAME'} || 'test' %>" style="border: none" />
-<% safe_run_child { Encode::decode_utf8( $graph->as_cmapx ) } |n %>
+<% safe_run_child { Encode::decode( "UTF-8", $graph->as_cmapx ) } |n %>
</div>
<& ShowLegends, %ARGS, Ticket => $ticket &>
<%ARGS>
</td>
</tr>
- <tr><td colspan="2"><& /Ticket/Elements/EditTransactionCustomFields, %ARGS, TicketObj => $Ticket &></td></tr>
+ <tr><td colspan="2"><& /Ticket/Elements/EditTransactionCustomFields, %ARGS, TicketObj => $Ticket, KeepValue => 1, &></td></tr>
<& /Ticket/Elements/AddAttachments, %ARGS, TicketObj => $Ticket &>
% $m->callback( %ARGS, CallbackName => 'AfterWorked', Ticket => $TicketObj );
-<& /Ticket/Elements/EditTransactionCustomFields, %ARGS, TicketObj => $TicketObj, AsTable => 1 &>
+<& /Ticket/Elements/EditTransactionCustomFields, %ARGS, TicketObj => $TicketObj, AsTable => 1, KeepValue => 1 &>
<!--</table>-->
</&>
$template .= $buffer;
}
my $encode = RT::I18N::_GuessCharset( $template );
- require Encode;
$template = Encode::decode( $encode, $template );
$template =~ s/\r\n/\n/gs;
$action->Parse(Content => $template, Queue => $qname, Requestor => $requestoraddress);
#
my $page = $m->request_comp->path;
-my $title_b64 = MIME::Base64::encode_base64(Encode::encode_utf8($title), '');
+my $title_b64 = MIME::Base64::encode_base64(Encode::encode( "UTF-8", $title), '');
my $tid = "TitleBox--$page--" .
join '--', ($class, $bodyclass, $title_b64, $id);
use HTML::Mason::Compiler;
use HTML::Mason::Compiler::ToObject;
BEGIN { require RT::Test; }
-use Encode qw(decode_utf8);
sub compile_file {
my $file = shift;
- my $text = decode_utf8(RT::Test->file_content($file));
+ my $text = Encode::decode( "UTF-8", RT::Test->file_content($file));
my $compiler = new HTML::Mason::Compiler::ToObject;
$compiler->compile(
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test nodb => 1;
+use File::Find;
+
+my @files;
+find( sub { push @files, $File::Find::name if -f },
+ qw{etc lib share t bin sbin devel/tools} );
+if ( my $dir = `git rev-parse --git-dir 2>/dev/null` ) {
+ # We're in a git repo, use the ignore list
+ chomp $dir;
+ my %ignores;
+ $ignores{ $_ }++ for grep $_, split /\n/,
+ `git ls-files -o -i --exclude-standard .`;
+ @files = grep {not $ignores{$_}} @files;
+}
+
+sub check {
+ my $file = shift;
+ my %check = (
+ strict => 0,
+ warnings => 0,
+ shebang => 0,
+ exec => 0,
+ bps_tag => 0,
+ @_,
+ );
+
+ if ($check{strict} or $check{warnings} or $check{shebang} or $check{bps_tag}) {
+ local $/;
+ open my $fh, '<', $file or die $!;
+ my $content = <$fh>;
+
+ like(
+ $content,
+ qr/^use strict(?:;|\s+)/m,
+ "$file has 'use strict'"
+ ) if $check{strict};
+
+ like(
+ $content,
+ qr/^use warnings(?:;|\s+)/m,
+ "$file has 'use warnings'"
+ ) if $check{warnings};
+
+ if ($check{shebang} == 1) {
+ like( $content, qr/^#!/, "$file has shebang" );
+ } elsif ($check{shebang} == -1) {
+ unlike( $content, qr/^#!/, "$file has no shebang" );
+ }
+
+ $check{bps_tag} = -1 if $check{bps_tag} == 1
+ and not $content =~ /Copyright\s+\(c\)\s+\d\d\d\d-\d\d\d\d Best Practical Solutions/i
+ and $file =~ /(?:ckeditor|scriptaculous|superfish|tablesorter|farbtastic)/i;
+ $check{bps_tag} = -1 if $check{bps_tag} == 1
+ and not $content =~ /Copyright\s+\(c\)\s+\d\d\d\d-\d\d\d\d Best Practical Solutions/i
+ and ($content =~ /\b(copyright|GPL|Public Domain)\b/i
+ or /\(c\)\s+\d\d\d\d(?:-\d\d\d\d)?/i);
+ if ($check{bps_tag} == 1) {
+ like( $content, qr/[B]EGIN BPS TAGGED BLOCK {{{/, "$file has BPS license tag");
+ } elsif ($check{bps_tag} == -1) {
+ unlike( $content, qr/[B]EGIN BPS TAGGED BLOCK {{{/, "$file has no BPS license tag");
+ }
+ }
+
+ my $executable = ( stat $file )[2] & 0100;
+ if ($check{exec} == 1) {
+ if ( $file =~ /\.in$/ ) {
+ ok( !$executable, "$file permission is u-x (.in will add +x)" );
+ } else {
+ ok( $executable, "$file permission is u+x" );
+ }
+ } elsif ($check{exec} == -1) {
+ ok( !$executable, "$file permission is u-x" );
+ }
+}
+
+check( $_, shebang => -1, exec => -1, warnings => 1, strict => 1, bps_tag => 1 )
+ for grep {m{^lib/.*\.pm$}} @files;
+
+check( $_, shebang => -1, exec => -1, warnings => 1, strict => 1, bps_tag => -1 )
+ for grep {m{^t/.*\.t$}} @files;
+
+check( $_, shebang => 1, exec => 1, warnings => 1, strict => 1, bps_tag => 1 )
+ for grep {m{^s?bin/}} @files;
+
+check( $_, shebang => 1, exec => 1, warnings => 1, strict => 1, bps_tag => 1 )
+ for grep {m{^devel/tools/} and not m{/(localhost\.(crt|key)|mime\.types)$}} @files;
+
+check( $_, exec => -1, bps_tag => not m{\.(png|gif|jpe?g)$} )
+ for grep {m{^share/html/}} @files;
+
+check( $_, exec => -1 )
+ for grep {m{^share/(po|fonts)/}} @files;
+
+check( $_, exec => -1 )
+ for grep {m{^t/data/}} @files;
+
+check( $_, exec => -1, bps_tag => -1 )
+ for grep {m{^etc/upgrade/[^/]+/}} @files;
my $mime = $attachment->ContentAsMIME;
like( $mime->head->get('Content-Type'),
qr/charset="iso-8859-1"/, 'content type of ContentAsMIME is original' );
- require Encode;
is(
Encode::decode( 'iso-8859-1', $mime->stringify_body ),
- Encode::decode( 'utf8', "Håvard\n" ),
+ Encode::decode( 'UTF-8', "Håvard\n" ),
'body of ContentAsMIME is original'
);
}
use RT::Test nodata => 1, tests => 11;
use RT::I18N;
-use Encode;
my %map = (
'euc-cn' => 'gbk',
my $mime = MIME::Entity->build(
Type => 'text/plain; charset=gb2312',
- Data => [encode('gbk', decode_utf8("法新社倫敦11日電"))],
+ Data => [Encode::encode("gbk", Encode::decode( "UTF-8", "法新社倫敦11日電"))],
);
RT::I18N::SetMIMEEntityToUTF8($mime);
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 18;
+
+my $suffix = '-'. $$;
+
+use_ok 'RT::Users';
+use_ok 'RT::CustomField';
+
+my $u1 = RT::User->new( RT->SystemUser );
+isa_ok( $u1, 'RT::User' );
+ok( $u1->Load('root'), "Loaded user 'root'" );
+
+# create cf
+my $cfname = 'TestUserCF'. $suffix;
+my $cf = RT::CustomField->new( RT->SystemUser );
+isa_ok( $cf, 'RT::CustomField' );
+
+{
+ my ($id, $msg) = $cf->Create(
+ Name => $cfname,
+ LookupType => 'RT::User',
+ Type => 'Freeform',
+ Description => 'Freeform CF for tests',
+ );
+ ok( $id, "Created cf '$cfname' - " . $msg );
+}
+
+{
+ my ($status, $msg) = $cf->AddToObject( $u1 );
+ ok( $status, "Added CF to user object - " . $msg);
+}
+
+my $cfvalue1 = 'Foo';
+
+{
+ my ($id, $msg) = $u1->AddCustomFieldValue(
+ Field => $cfname,
+ Value => $cfvalue1,
+ RecordTransaction => 0 );
+ ok( $id, "Adding CF value '$cfvalue1' - " . $msg );
+}
+
+# Confirm value is returned.
+{
+ my $cf_value_ref = QueryCFValue( $cfvalue1, $cf->id );
+ is( scalar(@$cf_value_ref), 1, 'Got one value.' );
+ is( $cf_value_ref->[0], 'Foo', 'Got Foo back for value.' );
+}
+
+{
+ my ($id, $msg) = $u1->DeleteCustomFieldValue(
+ Field => $cfname,
+ Value => $cfvalue1,
+ RecordTransaction => 0 );
+ ok( $id, "Deleting CF value - " . $msg );
+}
+
+my $cfvalue2 = 'Bar';
+{
+ my ($id, $msg) = $u1->AddCustomFieldValue(
+ Field => $cfname,
+ Value => $cfvalue2,
+ RecordTransaction => 0 );
+ ok( $id, "Adding second CF value '$cfvalue2' - " . $msg );
+}
+
+# Confirm no value is returned for Foo.
+{
+ # Calling with $cfvalue1 on purpose to confirm
+ # it has been disabled by the delete above.
+
+ my $cf_value_ref = QueryCFValue( $cfvalue1, $cf->id );
+ is( scalar(@$cf_value_ref), 0, 'No values returned for Foo.' );
+}
+
+# Confirm value is returned for Bar.
+{
+ my $cf_value_ref = QueryCFValue( $cfvalue2, $cf->id );
+ is( scalar(@$cf_value_ref), 1, 'Got one value.' );
+ is( $cf_value_ref->[0], 'Bar', 'Got Bar back for value.' );
+}
+
+
+sub QueryCFValue{
+ my $cf_value = shift;
+ my $cf_id = shift;
+ my @cf_value_strs;
+
+ my $users = RT::Users->new(RT->SystemUser);
+ isa_ok( $users, 'RT::Users' );
+
+ $users->LimitCustomField(
+ CUSTOMFIELD => $cf_id,
+ OPERATOR => "=",
+ VALUE => $cf_value );
+
+ while ( my $filtered_user = $users->Next() ){
+ my $cf_values = $filtered_user->CustomFieldValues($cf->id);
+ while (my $cf_value = $cf_values->Next() ){
+ push @cf_value_strs, $cf_value->Content;
+ }
+ }
+ return \@cf_value_strs;
+}
use RT::Test tests => 16;
-use Encode qw(encode);
-
use constant HAS_ENCODE_GUESS => do { local $@; eval { require Encode::Guess; 1 } };
use constant HAS_ENCODE_DETECT => do { local $@; eval { require Encode::Detect::Detector; 1 } };
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+use RT::Interface::Web::Menu;
+
+sub child_path_is($$$) {
+ my ($menu, $child, $expected) = @_;
+ my $c = $menu->child($child->[0], path => $child->[1]);
+ is $c->path, $expected, "'$child->[1]' normalizes to '$expected'";
+ return $c;
+}
+
+{
+ package FakeRequest;
+ sub new { bless {}, shift }
+ sub path_info { "" }
+
+ package FakeInterp;
+ require CGI;
+ sub new { bless {}, shift }
+ sub cgi_object { CGI->new }
+}
+
+local $HTML::Mason::Commands::r = FakeRequest->new;
+local $HTML::Mason::Commands::m = FakeInterp->new;
+
+my $menu = RT::Interface::Web::Menu->new;
+ok $menu, "Created top level menu";
+
+child_path_is $menu, [search => "Search/Simple.html"], "/Search/Simple.html";
+child_path_is $menu, [absolute => "/Prefs/Other.html"], "/Prefs/Other.html";
+child_path_is $menu, [scheme => "http://example.com"], "http://example.com";
+
+my $tools =
+ child_path_is $menu, [tools => "/Tools/"], "/Tools/";
+ child_path_is $tools, [myday => "MyDay.html"], "/Tools/MyDay.html";
+ child_path_is $tools, [activity => "/Activity.html"], "/Activity.html";
+ my $ext =
+ child_path_is $tools, [external => "http://example.com"], "http://example.com";
+ child_path_is $ext, [wiki => "wiki/"], "http://example.com/wiki/";
+
+# Pathological case of multiplying slashes
+my $home =
+ child_path_is $menu, [home => "/"], "/";
+ child_path_is $home, [slash => "/"], "/";
+ child_path_is $home, [empty => ""], "/";
+
+
+
+sub order_ok($$;$) {
+ my ($menu, $expected, $name) = @_;
+ my @children = $menu->children;
+
+ is scalar @children, scalar @$expected, "correct number of children";
+ is_deeply [map { $_->key } @children], $expected, $name;
+
+ my $last_child = shift @children; # first child's sort doesn't matter
+ for (@children) {
+ ok $_->sort_order > $last_child->sort_order, sprintf "%s order higher than %s's", $_->key, $last_child->key;
+ $last_child = $_;
+ }
+}
+
+$menu = RT::Interface::Web::Menu->new;
+
+ok $menu->child("foo", title => "foo"), "added child foo";
+order_ok $menu, [qw(foo)], "sorted";
+
+ok $menu->child("foo")->add_after("bar", title => "bar"), "added child bar after foo";
+order_ok $menu, [qw(foo bar)], "sorted after";
+
+ok $menu->child("bar")->add_before("baz", title => "baz"), "added child baz before bar";
+order_ok $menu, [qw(foo baz bar)], "sorted before (in between)";
+
+ok $menu->child("bat", title => "bat", sort_order => 2.2), "added child bat between baz and bar";
+order_ok $menu, [qw(foo baz bat bar)], "sorted between manually";
+
+ok $menu->child("bat")->add_before("pre", title => "pre"), "added child pre before bat";
+order_ok $menu, [qw(foo baz pre bat bar)], "sorted between (before)";
+
+ok $menu->child("bat")->add_after("post", title => "post"), "added child post after bat";
+order_ok $menu, [qw(foo baz pre bat post bar)], "sorted between (after)";
+
+done_testing;
use RT::Test;
use Digest::MD5;
-use Encode 'encode_utf8';
-use utf8;
my $default = "sha512";
# Non-ASCII salted truncated SHA-256
my $non_ascii_trunc = MIME::Base64::encode_base64(
- "salt" . substr(Digest::SHA::sha256("salt".Digest::MD5::md5(encode_utf8("áěšý"))),0,26),
+ "salt" . substr(Digest::SHA::sha256("salt".Digest::MD5::md5("áěšý")),0,26),
""
);
$root->_Set( Field => "Password", Value => $non_ascii_trunc);
-ok($root->IsPassword("áěšý"), "Unsalted MD5 base64 works");
+ok($root->IsPassword(Encode::decode("UTF-8", "áěšý")), "Unsalted MD5 base64 works");
like($root->__Value("Password"), qr/^\!$default\!/, "And is now upgraded to salted $default");
--- /dev/null
+use strict;
+use warnings;
+use RT;
+use RT::Test tests => 266;
+use Test::Warn;
+
+my $queue = RT::Queue->new(RT->SystemUser);
+$queue->Load("General");
+
+my $ticket_cf = RT::CustomField->new(RT->SystemUser);
+$ticket_cf->Create(
+ Name => 'Department',
+ Queue => '0',
+ Type => 'FreeformSingle',
+);
+
+my $txn_cf = RT::CustomField->new(RT->SystemUser);
+$txn_cf->Create(
+ Name => 'Category',
+ LookupType => RT::Transaction->CustomFieldLookupType,
+ Type => 'FreeformSingle',
+);
+$txn_cf->AddToObject($queue);
+
+my $ticket = RT::Ticket->new(RT->SystemUser);
+my ($id, $msg) = $ticket->Create(
+ Subject => "template testing",
+ Queue => "General",
+ Owner => 'root@localhost',
+ Requestor => ["dom\@example.com"],
+ "CustomField-" . $txn_cf->id => "Special",
+);
+ok($id, "Created ticket: $msg");
+my $txn = $ticket->Transactions->First;
+
+$ticket->AddCustomFieldValue(
+ Field => 'Department',
+ Value => 'Coolio',
+);
+
+TemplateTest(
+ Content => "\ntest",
+ PerlOutput => "test",
+ SimpleOutput => "test",
+);
+
+TemplateTest(
+ Content => "\ntest { 5 * 5 }",
+ PerlOutput => "test 25",
+ SimpleOutput => "test { 5 * 5 }",
+);
+
+TemplateTest(
+ Content => "\ntest { \$Requestor }",
+ PerlOutput => "test dom\@example.com",
+ SimpleOutput => "test dom\@example.com",
+);
+
+TemplateTest(
+ Content => "\ntest { \$TicketSubject }",
+ PerlOutput => "test ",
+ SimpleOutput => "test template testing",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketQueueId }",
+ Output => "test 1",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketQueueName }",
+ Output => "test General",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketOwnerId }",
+ Output => "test 12",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketOwnerName }",
+ Output => "test root",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketOwnerEmailAddress }",
+ Output => "test root\@localhost",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketStatus }",
+ Output => "test new",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest #{ \$TicketId }",
+ Output => "test #" . $ticket->id,
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketCFDepartment }",
+ Output => "test Coolio",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest #{ \$TransactionId }",
+ Output => "test #" . $txn->id,
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TransactionType }",
+ Output => "test Create",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TransactionCFCategory }",
+ Output => "test Special",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$TicketDelete }",
+ Output => "test { \$TicketDelete }",
+);
+
+SimpleTemplateTest(
+ Content => "\ntest { \$Nonexistent }",
+ Output => "test { \$Nonexistent }",
+);
+
+warning_like {
+ TemplateTest(
+ Content => "\ntest { \$Ticket->Nonexistent }",
+ PerlOutput => undef,
+ SimpleOutput => "test { \$Ticket->Nonexistent }",
+ );
+} qr/RT::Ticket::Nonexistent Unimplemented/;
+
+warning_like {
+ TemplateTest(
+ Content => "\ntest { \$Nonexistent->Nonexistent }",
+ PerlOutput => undef,
+ SimpleOutput => "test { \$Nonexistent->Nonexistent }",
+ );
+} qr/Can't call method "Nonexistent" on an undefined value/;
+
+TemplateTest(
+ Content => "\ntest { \$Ticket->OwnerObj->Name }",
+ PerlOutput => "test root",
+ SimpleOutput => "test { \$Ticket->OwnerObj->Name }",
+);
+
+warning_like {
+ TemplateTest(
+ Content => "\ntest { *!( }",
+ SyntaxError => 1,
+ PerlOutput => undef,
+ SimpleOutput => "test { *!( }",
+ );
+} qr/Template parsing error: syntax error/;
+
+TemplateTest(
+ Content => "\ntest { \$rtname ",
+ SyntaxError => 1,
+ PerlOutput => undef,
+ SimpleOutput => undef,
+);
+
+is($ticket->Status, 'new', "test setup");
+SimpleTemplateTest(
+ Content => "\ntest { \$Ticket->SetStatus('resolved') }",
+ Output => "test { \$Ticket->SetStatus('resolved') }",
+);
+is($ticket->Status, 'new', "simple templates can't call ->SetStatus");
+
+note "test arguments passing";
+{
+ PerlTemplateTest(
+ Content => "\ntest { \$Nonexistent }",
+ Output => "test ",
+ );
+ PerlTemplateTest(
+ Content => "\ntest { \$Nonexistent }",
+ Arguments => { Nonexistent => 'foo' },
+ Output => "test foo",
+ );
+
+ PerlTemplateTest(
+ Content => "\n".'array: { join ", ", @array }',
+ Arguments => { array => [qw(foo bar)] },
+ Output => "array: foo, bar",
+ );
+ PerlTemplateTest(
+ Content => "\n".'hash: { join ", ", map "$_ => $hash{$_}", sort keys %hash }',
+ Arguments => { hash => {1 => 2, a => 'b'} },
+ Output => "hash: 1 => 2, a => b",
+ );
+ PerlTemplateTest(
+ Content => "\n".'code: { code() }',
+ Arguments => { code => sub { "baz" } },
+ Output => "code: baz",
+ );
+}
+
+# Make sure changing the template's type works
+{
+ my $template = RT::Template->new(RT->SystemUser);
+ $template->Create(
+ Name => "type chameleon",
+ Type => "Perl",
+ Content => "\ntest { 10 * 7 }",
+ );
+ ok($id = $template->id, "Created template");
+ $template->Parse;
+ is($template->MIMEObj->stringify_body, "test 70", "Perl output");
+
+ $template = RT::Template->new(RT->SystemUser);
+ $template->Load($id);
+ is($template->Name, "type chameleon");
+
+ $template->SetType('Simple');
+ $template->Parse;
+ is($template->MIMEObj->stringify_body, "test { 10 * 7 }", "Simple output");
+
+ $template = RT::Template->new(RT->SystemUser);
+ $template->Load($id);
+ is($template->Name, "type chameleon");
+
+ $template->SetType('Perl');
+ $template->Parse;
+ is($template->MIMEObj->stringify_body, "test 70", "Perl output");
+}
+
+undef $ticket;
+
+my $counter = 0;
+sub IndividualTemplateTest {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my %args = (
+ Name => "Test-" . ++$counter,
+ Type => "Perl",
+ @_,
+ );
+
+ my $t = RT::Template->new(RT->SystemUser);
+ $t->Create(
+ Name => $args{Name},
+ Type => $args{Type},
+ Content => $args{Content},
+ );
+
+ ok($t->id, "Created $args{Type} template");
+ is($t->Name, $args{Name}, "$args{Type} template name");
+ is($t->Content, $args{Content}, "$args{Type} content");
+ is($t->Type, $args{Type}, "template type");
+
+ # this should never blow up!
+ my ($ok, $msg) = $t->CompileCheck;
+
+ # we don't need to syntax check simple templates since if you mess them up
+ # it's safe to just use the input directly as the template's output
+ if ($args{SyntaxError} && $args{Type} eq 'Perl') {
+ ok(!$ok, "got a syntax error");
+ }
+ else {
+ ok($ok, $msg);
+ }
+
+ ($ok, $msg) = $t->Parse(
+ $args{'Arguments'}
+ ? ( %{ $args{'Arguments'} } )
+ : (TicketObj => $ticket, TransactionObj => $txn )
+ ,
+ );
+ if (defined $args{Output}) {
+ ok($ok, $msg);
+ is($t->MIMEObj->stringify_body, $args{Output}, "$args{Type} template's output");
+ }
+ else {
+ ok(!$ok, "expected a failure");
+ }
+}
+
+sub TemplateTest {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my %args = @_;
+
+ for my $type ('Perl', 'Simple') {
+ IndividualTemplateTest(
+ %args,
+ Type => $type,
+ Output => $args{$type . 'Output'},
+ );
+ }
+}
+
+sub SimpleTemplateTest {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ IndividualTemplateTest( @_, Type => 'Simple' );
+}
+
+sub PerlTemplateTest {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ IndividualTemplateTest( @_, Type => 'Perl' );
+}
+
--- /dev/null
+
+use strict;
+use warnings;
+use RT;
+use RT::Test tests => undef;
+use Test::Warn;
+
+use_ok ('RT::Transaction');
+
+{
+ my $u = RT::User->new(RT->SystemUser);
+ $u->Load("root");
+ ok ($u->Id, "Found the root user");
+ ok(my $t = RT::Ticket->new(RT->SystemUser));
+ my ($id, $msg) = $t->Create( Queue => 'General',
+ Subject => 'Testing',
+ Owner => $u->Id
+ );
+ ok($id, "Create new ticket $id");
+ isnt($id , 0);
+
+ my $txn = RT::Transaction->new(RT->SystemUser);
+ my ($txn_id, $txn_msg) = $txn->Create(
+ Type => 'AddLink',
+ Field => 'RefersTo',
+ Ticket => $id,
+ NewValue => 'ticket 42', );
+ ok( $txn_id, "Created transaction $txn_id: $txn_msg");
+
+ my $brief;
+ warning_like { $brief = $txn->BriefDescription }
+ qr/Could not determine a URI scheme/,
+ "Caught URI warning";
+
+ is( $brief, 'Reference to ticket 42 added', "Got string description: $brief");
+
+ $txn = RT::Transaction->new(RT->SystemUser);
+ ($txn_id, $txn_msg) = $txn->Create(
+ Type => 'DeleteLink',
+ Field => 'RefersTo',
+ Ticket => $id,
+ OldValue => 'ticket 42', );
+ ok( $txn_id, "Created transaction $txn_id: $txn_msg");
+
+ warning_like { $brief = $txn->BriefDescription }
+ qr/Could not determine a URI scheme/,
+ "Caught URI warning";
+
+ is( $brief, 'Reference to ticket 42 deleted', "Got string description: $brief");
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+use RT::Test tests => undef;
+
+my @warnings;
+local $SIG{__WARN__} = sub {
+ push @warnings, "@_";
+};
+
+# Create ticket
+my $ticket = RT::Test->create_ticket( Queue => 1, Subject => 'test ticket' );
+ok $ticket->id, 'created ticket';
+
+# Create article class
+my $class = RT::Class->new( $RT::SystemUser );
+$class->Create( Name => 'URItest - '. $$ );
+ok $class->id, 'created a class';
+
+# Create article
+my $article = RT::Article->new( $RT::SystemUser );
+$article->Create(
+ Name => 'Testing URI parsing - '. $$,
+ Summary => 'In which this should load',
+ Class => $class->Id
+);
+ok $article->id, 'create article';
+
+# Test permutations of URIs
+my $ORG = RT->Config->Get('Organization');
+my $URI = RT::URI->new( RT->SystemUser );
+my %expected = (
+ # tickets
+ "1" => "fsck.com-rt://$ORG/ticket/1",
+ "t:1" => "fsck.com-rt://$ORG/ticket/1",
+ "fsck.com-rt://$ORG/ticket/1" => "fsck.com-rt://$ORG/ticket/1",
+
+ # articles
+ "a:1" => "fsck.com-article://$ORG/article/1",
+ "fsck.com-article://$ORG/article/1" => "fsck.com-article://$ORG/article/1",
+
+ # random stuff
+ "http://$ORG" => "http://$ORG",
+ "mailto:foo\@example.com" => "mailto:foo\@example.com",
+ "invalid" => "invalid", # doesn't trigger die
+);
+for my $uri (sort keys %expected) {
+ is $URI->CanonicalizeURI($uri), $expected{$uri}, "canonicalized as expected";
+}
+
+is_deeply \@warnings, [
+ "Could not determine a URI scheme for invalid\n",
+], "expected warnings";
+
+done_testing;
--- /dev/null
+use Test::MockTime qw(set_fixed_time restore_time);
+
+use warnings;
+use strict;
+
+use RT::Test tests => undef;
+
+RT::Test->set_rights(
+ { Principal => 'Everyone', Right => [qw(
+ SeeQueue ShowTicket CreateTicket SeeCustomField ModifyCustomField
+ )] },
+);
+
+my $q = RT::Test->load_or_create_queue( Name => 'General' );
+ok $q && $q->id, 'loaded or created a queue';
+
+my $user_m = RT::Test->load_or_create_user( Name => 'moscow', Timezone => 'Europe/Moscow' );
+ok $user_m && $user_m->id;
+
+my $user_b = RT::Test->load_or_create_user( Name => 'boston', Timezone => 'America/New_York' );
+ok $user_b && $user_b->id;
+
+
+my $cf_name = 'A Date';
+my $cf;
+{
+ $cf = RT::CustomField->new(RT->SystemUser);
+ ok(
+ $cf->Create(
+ Name => $cf_name,
+ Type => 'Date',
+ MaxValues => 1,
+ LookupType => RT::Ticket->CustomFieldLookupType,
+ ),
+ 'create cf date'
+ );
+ ok( $cf->AddToObject($q), 'date cf apply to queue' );
+}
+
+{
+ my $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_m ) );
+ my ($id) = $ticket->Create(
+ Queue => $q->id,
+ Subject => 'Test',
+ 'CustomField-'. $cf->id => '2013-02-11',
+ );
+ my $cf_value = $ticket->CustomFieldValues($cf_name)->First;
+ is( $cf_value->Content, '2013-02-11', 'correct value' );
+
+ $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_b ) );
+ $ticket->Load($id);
+ is( $ticket->FirstCustomFieldValue($cf_name), '2013-02-11', 'correct value' );
+}
+
+{
+ my $ticket = RT::Ticket->new(RT->SystemUser);
+ ok(
+ $ticket->Create(
+ Queue => $q->id,
+ Subject => 'Test',
+ 'CustomField-' . $cf->id => '2010-05-04 11:34:56',
+ ),
+ 'create ticket with cf set to 2010-05-04 11:34:56'
+ );
+ is( $ticket->CustomFieldValues->First->Content,
+ '2010-05-04', 'date in db only has date' );
+}
+
+# in moscow it's already Feb 11, so tomorrow is Feb 12
+set_fixed_time("2013-02-10T23:10:00Z");
+{
+ my $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_m ) );
+ my ($id) = $ticket->Create(
+ Queue => $q->id,
+ Subject => 'Test',
+ 'CustomField-'. $cf->id => 'tomorrow',
+ );
+ my $cf_value = $ticket->CustomFieldValues($cf_name)->First;
+ is( $cf_value->Content, '2013-02-12', 'correct value' );
+
+ $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_b ) );
+ $ticket->Load($id);
+ is( $ticket->FirstCustomFieldValue($cf_name), '2013-02-12', 'correct value' );
+}
+
+done_testing();
--- /dev/null
+use Test::MockTime qw(set_fixed_time restore_time);
+
+use warnings;
+use strict;
+
+use RT::Test tests => undef;
+
+RT::Test->set_rights(
+ { Principal => 'Everyone', Right => [qw(
+ SeeQueue ShowTicket CreateTicket SeeCustomField ModifyCustomField
+ )] },
+);
+
+my $q = RT::Test->load_or_create_queue( Name => 'General' );
+ok $q && $q->id, 'loaded or created a queue';
+
+my $user_m = RT::Test->load_or_create_user( Name => 'moscow', Timezone => 'Europe/Moscow' );
+ok $user_m && $user_m->id;
+
+my $user_b = RT::Test->load_or_create_user( Name => 'boston', Timezone => 'America/New_York' );
+ok $user_b && $user_b->id;
+
+
+my $cf_name = 'A Date and Time';
+my $cf;
+{
+ $cf = RT::CustomField->new(RT->SystemUser);
+ ok(
+ $cf->Create(
+ Name => $cf_name,
+ Type => 'DateTime',
+ MaxValues => 1,
+ LookupType => RT::Ticket->CustomFieldLookupType,
+ ),
+ 'create cf date'
+ );
+ ok( $cf->AddToObject($q), 'date cf apply to queue' );
+}
+
+{
+ my $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_m ) );
+ my ($id) = $ticket->Create(
+ Queue => $q->id,
+ Subject => 'Test',
+ 'CustomField-'. $cf->id => '2013-02-11 00:00:00',
+ );
+ my $cf_value = $ticket->CustomFieldValues($cf_name)->First;
+ TODO: {
+ local $TODO = 'questionable result, should we change?';
+ # $Ticket->Created returns UTC, not user's date, but
+ # ticket has ->CreatedObj method to get all required
+ # transformation
+ # No more TODO.
+ is( $cf_value->Content, '2013-02-11 00:00:00', 'correct value' );
+ }
+ is( $cf_value->Content, '2013-02-10 20:00:00', 'correct value' );
+
+ $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_b ) );
+ $ticket->Load($id);
+ is( $ticket->FirstCustomFieldValue($cf_name), '2013-02-10 20:00:00', 'correct value' );
+}
+
+# in moscow it's already Feb 11, so tomorrow is Feb 12
+set_fixed_time("2013-02-10T23:10:00Z");
+{
+ my $ticket = RT::Ticket->new( RT::CurrentUser->new( $user_m ) );
+ my ($id) = $ticket->Create(
+ Queue => $q->id,
+ Subject => 'Test',
+ 'CustomField-'. $cf->id => 'tomorrow',
+ );
+ my $cf_value = $ticket->CustomFieldValues($cf_name)->First;
+ is( $cf_value->Content, '2013-02-11 23:10:00', 'correct value' );
+}
+
+done_testing();
}
);
- $agent->content_like( qr/can not be parsed as an IP address range/,
+ $agent->content_like( qr/is not a valid IP address range/,
'ticket fails to create' );
}
--- /dev/null
+use warnings;
+use strict;
+
+use RT::Test tests => undef;
+
+
+my $ticket = RT::Test->create_ticket( Subject => 'test repeated values', Queue => 'General' );
+my ( $ret, $msg );
+
+{
+ diag "testing freeform single cf";
+ my $freeform_single = RT::Test->load_or_create_custom_field(
+ Name => 'freeform single',
+ Type => 'FreeformSingle',
+ Queue => 0,
+ );
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $freeform_single, Value => 'foo' );
+ ok( $ret, $msg );
+ is( $ticket->FirstCustomFieldValue($freeform_single), 'foo', 'value is foo' );
+
+ my $ocfv = $ticket->CustomFieldValues($freeform_single)->First;
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $freeform_single, Value => 'foo' );
+ is( $ret, $ocfv->id, "got the same previous object" );
+ is( $ticket->FirstCustomFieldValue($freeform_single), 'foo', 'value is still foo' );
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $freeform_single, Value => 'FOO' );
+ ok( $ret, $msg );
+ isnt( $ret, $ocfv->id, "got a new value" );
+ is( $ticket->FirstCustomFieldValue($freeform_single), 'FOO', 'value is FOO' );
+}
+
+{
+ diag "testing freeform multiple cf";
+ my $freeform_multiple = RT::Test->load_or_create_custom_field(
+ Name => 'freeform multiple',
+ Type => 'FreeformMultiple',
+ Queue => 0,
+ );
+
+ ($ret, $msg) = $ticket->AddCustomFieldValue( Field => $freeform_multiple, Value => 'foo' );
+ ok($ret, $msg);
+ is( $ticket->FirstCustomFieldValue($freeform_multiple), 'foo', 'value is foo' );
+
+ my $ocfv = $ticket->CustomFieldValues($freeform_multiple)->First;
+ ($ret, $msg) = $ticket->AddCustomFieldValue( Field => $freeform_multiple, Value => 'foo' );
+ is($ret, $ocfv->id, "got the same previous object");
+ is( $ticket->FirstCustomFieldValue($freeform_multiple), 'foo', 'value is still foo' );
+
+ ($ret, $msg) = $ticket->AddCustomFieldValue( Field => $freeform_multiple, Value => 'bar' );
+ ok($ret, $msg);
+
+ my $ocfvs = $ticket->CustomFieldValues($freeform_multiple)->ItemsArrayRef;
+ is( scalar @$ocfvs, 2, 'has 2 values');
+ is( $ocfvs->[0]->Content, 'foo', 'first is foo' );
+ is( $ocfvs->[1]->Content, 'bar', 'sencond is bar' );
+}
+
+{
+ diag "testing select single cf";
+
+ my $select_single = RT::Test->load_or_create_custom_field(
+ Name => 'select single',
+ Type => 'SelectSingle',
+ Queue => 0,
+ );
+
+ for my $value ( qw/foo bar baz/ ) {
+ $select_single->AddValue( Name => $value );
+ }
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $select_single, Value => 'foo' );
+ ok( $ret, $msg );
+ my $ocfv = $ticket->CustomFieldValues($select_single)->First;
+ is( $ticket->FirstCustomFieldValue($select_single), 'foo', 'value is foo' );
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $select_single, Value => 'foo' );
+ is( $ret, $ocfv->id, "got the same previous object" );
+ is( $ticket->FirstCustomFieldValue($select_single), 'foo', 'value is still foo' );
+
+ diag "select values are case insensitive";
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $select_single, Value => 'FOO' );
+ is( $ret, $ocfv->id, "got the same previous object" );
+ is( $ticket->FirstCustomFieldValue($select_single), 'foo', 'value is still foo' );
+
+ ($ret, $msg) = $ticket->AddCustomFieldValue( Field => $select_single, Value => 'bar' );
+ ok($ret, $msg);
+ isnt( $ret, $ocfv->id, "got a new value" );
+ is( $ticket->FirstCustomFieldValue($select_single), 'bar', 'new value is bar' );
+}
+
+{
+ diag "testing binary single cf";
+
+ my $binary_single = RT::Test->load_or_create_custom_field(
+ Name => 'upload single',
+ Type => 'BinarySingle',
+ Queue => 0,
+ );
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $binary_single, Value => 'foo', LargeContent => 'bar' );
+ ok( $ret, $msg );
+ my $ocfv = $ticket->CustomFieldValues($binary_single)->First;
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $binary_single, Value => 'foo', LargeContent => 'bar' );
+ is( $ret, $ocfv->id, "got the same previous object" );
+ is($ocfv->Content, 'foo', 'name is foo');
+ is($ocfv->LargeContent, 'bar', 'content is bar');
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $binary_single, Value => 'foo', LargeContent => 'baz' );
+ ok( $ret, $msg );
+ isnt( $ret, $ocfv->id, "got a new value" );
+ $ocfv = $ticket->CustomFieldValues($binary_single)->First;
+ is($ocfv->Content, 'foo', 'name is foo');
+ is($ocfv->LargeContent, 'baz', 'content is baz');
+
+ ( $ret, $msg ) =
+ $ticket->AddCustomFieldValue( Field => $binary_single, Value => 'foo.2', LargeContent => 'baz' );
+ ok( $ret, $msg );
+ isnt( $ret, $ocfv->id, "got a new value" );
+ $ocfv = $ticket->CustomFieldValues($binary_single)->First;
+ is($ocfv->Content, 'foo.2', 'name is foo.2');
+ is($ocfv->LargeContent, 'baz', 'content is baz');
+}
+
+done_testing();
--- /dev/null
+ServerRoot %%SERVER_ROOT%%
+PidFile %%PID_FILE%%
+LockFile %%LOCK_FILE%%
+ServerAdmin root@localhost
+
+%%LOAD_MODULES%%
+
+<IfModule !mpm_netware_module>
+<IfModule !mpm_winnt_module>
+User freeside
+Group freeside
+</IfModule>
+</IfModule>
+
+ServerName localhost
+Listen %%LISTEN%%
+
+ErrorLog "%%LOG_FILE%%"
+LogLevel debug
+
+<Directory />
+ Options FollowSymLinks
+ AllowOverride None
+ Order deny,allow
+ Deny from all
+</Directory>
+
+AddDefaultCharset UTF-8
+
+FastCgiServer %%RT_SBIN_PATH%%/rt-server.fcgi \
+ -socket %%TMP_DIR%%/socket \
+ -processes 1 \
+ -idle-timeout 180 \
+ -initial-env RT_SITE_CONFIG=%%RT_SITE_CONFIG%% \
+ -initial-env RT_TESTING=1
+
+Alias /NoAuth/images/ %%DOCUMENT_ROOT%%/NoAuth/images/
+ScriptAlias / %%RT_SBIN_PATH%%/rt-server.fcgi/
+
+DocumentRoot "%%DOCUMENT_ROOT%%"
+<Location />
+ Order allow,deny
+ Allow from all
+
+%%BASIC_AUTH%%
+
+ Options +ExecCGI
+ AddHandler fastcgi-script fcgi
+</Location>
+
--- /dev/null
+<IfModule mpm_prefork_module>
+ StartServers 1
+ MinSpareServers 1
+ MaxSpareServers 1
+ MaxClients 1
+ MaxRequestsPerChild 0
+</IfModule>
+
+<IfModule mpm_worker_module>
+ StartServers 1
+ MinSpareThreads 1
+ MaxSpareThreads 1
+ ThreadLimit 1
+ ThreadsPerChild 1
+ MaxClients 1
+ MaxRequestsPerChild 0
+</IfModule>
+
+ServerRoot %%SERVER_ROOT%%
+PidFile %%PID_FILE%%
+LockFile %%LOCK_FILE%%
+ServerAdmin root@localhost
+
+%%LOAD_MODULES%%
+
+<IfModule !mpm_netware_module>
+<IfModule !mpm_winnt_module>
+User freeside
+Group freeside
+</IfModule>
+</IfModule>
+
+ServerName localhost
+Listen %%LISTEN%%
+
+ErrorLog "%%LOG_FILE%%"
+LogLevel debug
+
+<Directory />
+ Options FollowSymLinks
+ AllowOverride None
+ Order deny,allow
+ Deny from all
+</Directory>
+
+AddDefaultCharset UTF-8
+PerlSetEnv RT_SITE_CONFIG %%RT_SITE_CONFIG%%
+
+DocumentRoot "%%DOCUMENT_ROOT%%"
+<Location />
+ Order allow,deny
+ Allow from all
+
+%%BASIC_AUTH%%
+
+ SetHandler modperl
+
+ PerlResponseHandler Plack::Handler::Apache2
+ PerlSetVar psgi_app %%RT_SBIN_PATH%%/rt-server
+</Location>
+
+<Perl>
+ $ENV{RT_TESTING}=1;
+ use Plack::Handler::Apache2;
+ Plack::Handler::Apache2->preload("%%RT_SBIN_PATH%%/rt-server");
+</Perl>
+
+++ /dev/null
-From rickt@other-example.com Tue Jun 17 20:39:13 2003
-Return-Path: <rickt@other-example.com>
-X-Original-To: info
-Delivered-To: mitya@vh.example.com
-Received: from example.com (mx.example.com [194.87.0.32])
- by vh.example.com (Postfix) with ESMTP id 8D77B16E6BD
- for <info>; Tue, 17 Jun 2003 20:39:05 +0400 (MSD)
-Received: from hotline@example.com
- by example.com (CommuniGate Pro GROUP 4.1b7/D)
- with GROUP id 76033026; Tue, 17 Jun 2003 20:38:00 +0400
-Received: by example.com (CommuniGate Pro PIPE 4.1b7/D)
- with PIPE id 76033052; Tue, 17 Jun 2003 20:38:00 +0400
-Received: from [217.132.49.75] (HELO compuserve.com)
- by example.com (CommuniGate Pro SMTP 4.1b7/D)
- with SMTP id 76032971 for info@example.com; Tue, 17 Jun 2003 20:37:41 +0400
-Date: Wed, 18 Jun 2003 01:41:01 +0000
-From: Ó÷åáíûé Öåíòð <rickt@other-example.com>
-Subject: Ïðèãëàøàåì ðóêîâîäèòåëÿ, íà÷àëüíèêîâ ïîäðàçäåëåíèé íà òðåíèíã YXLWLJ3LPT9UHuLyGTzyuKQc06eIZ96Y6RVTCZFt
-To: Info <info@example.com>
-References: <0ID97EGL951H1907@example.com>
-In-Reply-To: <0ID97EGL951H1907@example.com>
-Message-ID: <HDE46LIK8GGJJ72I@other-example.com>
-MIME-Version: 1.0
-Content-Type: text/html; charset=Windows-1251
-Content-Transfer-Encoding: 8bit
-X-Spam-Flag: YES
-X-Spam-Checker-Version: SpamAssassin 2.60-cvs-jumbo.demos (1.190-2003-06-01-exp)
-X-Spam-Level: ++++++++++++++
-X-Spam-Status: Yes, hits=14.9 required=5.0 tests=BAYES_99,DATE_IN_FUTURE_06_12
- FROM_ILLEGAL_CHARS,HTML_10_20,HTML_FONTCOLOR_UNKNOWN,HTML_FONT_BIG
- MIME_HTML_ONLY,RCVD_IN_NJABL,SUBJ_HAS_SPACES,SUBJ_HAS_UNIQ_ID
- SUBJ_ILLEGAL_CHARS autolearn=no version=2.60-cvs-jumbo.demos
-X-Spam-Report: 14.9 points, 5.0 required;
- * 2.3 -- Subject contains lots of white space
- * 1.0 -- BODY: HTML font color is unknown to us
- * 0.3 -- BODY: FONT Size +2 and up or 3 and up
- [score: 1.0000]
- * 2.8 -- BODY: Bayesian classifier spam probability is 99 to 100%
- * 1.0 -- BODY: Message is 10% to 20% HTML
- * 1.0 -- From contains too many raw illegal characters
- * 1.0 -- Subject contains a unique ID
- * 1.0 -- Subject contains too many raw illegal characters
- * 1.2 -- Date: is 6 to 12 hours after Received: date
- [217.132.49.75 listed in dnsbl.njabl.org]
- * 1.2 -- RBL: Received via a relay in dnsbl.njabl.org
- * 2.0 -- Message only has text/html MIME parts
-Status: RO
-Content-Length: 2743
-Lines: 36
-
-<html><body><basefont face="times new roman, times, serif" size="2">
-<center>Ó÷eáíûé Öeíòp "ÊÀÄÐÛ ÄÅËÎÂÎÃÎ ÌÈÐÀ" ïpèãëaøaeò ía òpeíèíã:<br>
-<font size="5"><b>ÌÎÒÈÂÀÖÈß ÊÀÊ ÈÍÑÒÐÓÌÅÍÒ ÓÏÐÀÂËÅÍÈß ÏÅÐÑÎÍÀËÎÌ</b></font><br>
-<font color="red"><b>19 èþíÿ 2003 ã.</b></font><br>
-<b><i>Òpeíèíã ïpeäíaçía÷eí äëÿ âûcøeão è cpeäíeão óïpaâëeí÷ecêoão ïepcoíaëa.</i></b><br></center><br>
-<p align="justify"><b>Òpeíep: Áopìoòoâ Ïaâeë.</b> Ïpaêòè÷ecêèé ïcèõoëoã, oïûò paáoòû áoëee 10 ëeò â oáëacòè ïcèõoëoãèè è áèçíec-òpeíèíãoâ. Àâòop pÿäa ïóáëèêaöèé è ìeòoäè÷ecêèõ ïocoáèé paçëè÷íûõ íaïpaâëeíèé ïcèõoëoãèè, â òoì ÷ècëe: \93Òeõíoëoãèÿ äeëoâoão oáùeíèÿ\94, \93Òeõíèêè è ïpèeìû ýôôeêòèâíûõ ïepeãoâopoâ\94, \93Ñòpaòeãèè ôopìèpoâaíèÿ êopïopaòèâíoão èìèäæa\94 è äp. Çaêoí÷èë ËÃÓ ôaêóëüòeò coöèaëüíoé ïcèõoëoãèè, Ðoccèécêóþ Àêaäeìèþ ãocóäapcòâeííoé cëóæáû ïpè Ïpeçèäeíòe ÐÔ, êópcû MBA.<br><br>
-<b><u>Öeëè òpeíèíãa:</u></b><br>
-1. Îcâoèòü ïpèeìû óïpaâëeíèÿ ìoòèâaöèeé;<br>
-2. Ïoëó÷èòü ïpaêòè÷ecêèe íaâûêè ìoòèâaöèè ïepcoíaëa ê paáoòe;<br>
-3. Îcâoèòü ocíoâíûe íaâûêè êoìaíäooápaçoâaíèÿ;<br>
-4. Îâëaäeòü ïpaêòè÷ecêèìè ìeòoäaìè coçäaíèÿ è ócèëeíèÿ paáo÷eé ìoòèâaöèè, êoìaíäooápaçoâaíèÿ.<br><br>
-<b><u>Çaäa÷è òpeíèíãa:</u></b><br>
- - Îcâoèòü ìeòoäû ïoáóæäeíèÿ äpóãèõ ëþäeé ê âûïoëíeíèþ oïpeäeëeííoé äeÿòeëüíocòè;<br>
- - Íaó÷èòücÿ íaïpaâëÿòü ïoáóæäeíèÿ coòpóäíèêoâ â cooòâeòcòâèe c çaäa÷aìè opãaíèçaöèè.<br><br>
-<b><u>Ñoäepæaíèe ïpoãpaììû:</u></b><br>
-<b>I. Ìaòepèaëüíûe è íeìaòepèaëüíûe ôopìû ìoòèâaöèè:</b><br>
-1. Ìecòo è poëü ìoòèâaöèè â óïpaâëeíèè ïepcoíaëoì;<br>
-2. Ïpaêòèêa óïpaâëeíèÿ opãaíèçaöèÿìè.<br>
-<b>II. Ïpaêòè÷ecêoe ïpèìeíeíèe ìoòèâaöèè â óïpaâëeíèè ïepcoíaëoì:</b><br>
-1. Àíòèìoòèâèpóþùèe pacïopÿæeíèÿ;<br>
-2. Ìoòèâaöèÿ è oöeíêa äeÿòeëüíocòè (poëü aòòecòaöèè coòpóäíèêoâ);<br>
-3. Ìoòèâaöèÿ è ïpaêòèêa íaêaçaíèé.<br><br>
-<b><u>Â çaâepøeíèè ïpoãpaììû ó÷acòíèêè cìoãóò:</u></b><br>
-1. Îpèeíòèpoâaòü coòpóäíèêoâ ía äocòèæeíèe oïpeäeëeííoão peçóëüòaòa;<br>
-2. Îâëaäeòü íeoáõoäèìûìè íaâûêaìè óïpaâëeíèÿ ìoòèâaöèeé ïepcoíaëa;<br>
-3. Ïpèìeíÿòü ïoëó÷eííûe çíaíèÿ â ïpaêòèêe óïpaâëeíèÿ ïepcoíaëoì;<br>
-4. Îïpeäeëÿòü èíäèâèäóaëüíûe ocoáeííocòè (ïpeäïo÷òeíèÿ) ìoòèâaöèè coòpóäíèêoâ â opãaíèçaöèè.<br>
-<i> õoäe òpeíèíãa ècïoëüçóeòcÿ paáo÷èé è cïpaâo÷íûé ìaòepèaë ïo ìoòèâaöèè è còèìóëèpoâaíèþ ïepcoíaëa poccèécêèõ êoìïaíèé. Ïo oêoí÷aíèè âûäaeòcÿ cepòèôèêaò.</i><br><br>
-<center>Ïpoäoëæèòeëüíocòü: 1 äeíü, 8 ÷acoâ (äâa ïepepûâa, oáeä)<br>
-<b>Ñòoèìocòü ó÷acòèÿ: 4 700 póáëeé áeç ÍÄÑ.</b><br>
-921-5862, 928-4156, 928-4200, 928-5321</center><br>
-<font size=1> Åcëè èíôopìaöèÿ ïoäoáíoão poäa Âac íe èíòepecóeò è ïo äpóãèì âoïpocaì - ïèøèòe: <a href="mailto:motiv@mailje.nl">seminar</a></font>
-<br><font size="1" color="#ffffff">3ZkRPb60QBbiHef1IRVl</font>
-</body></html>
-
-
-
--- /dev/null
+<%flags>
+inherit => undef # avoid auth
+</%flags>
+<%init>
+$r->content_type("text/plain");
+$m->out( $RT::User::LOADED_OVERLAY ? "yes" : "no" );
+$m->abort(200);
+</%init>
--- /dev/null
+<%flags>
+inherit => undef # avoid auth
+</%flags>
+<%init>
+$r->content_type("application/json");
+$m->out( JSON( RT::User->_ClassAccessible() ) );
+$m->abort(200);
+</%init>
--- /dev/null
+package Overlays;
+1;
--- /dev/null
+package RT::User;
+use strict;
+use warnings;
+
+our $LOADED_OVERLAY = 1;
+
+sub _LocalAccessible {
+ { Comments => { public => 1 } }
+}
+
+1;
$m->add_header('Accept-Language' => 'zh-tw,zh;q=0.8,en-gb;q=0.5,en;q=0.3');
$m->get_ok('/');
-use utf8;
-Encode::_utf8_on($m->{content});
-$m->title_is('登入', 'Page title properly translated to chinese');
-$m->content_contains('密碼','Password properly translated');
+$m->title_is( Encode::decode("UTF-8",'登入'),
+ 'Page title properly translated to chinese');
+$m->content_contains( Encode::decode("UTF-8",'密碼'),
+ 'Password properly translated');
{
local $TODO = "We fail to correctly advertise the langauage in the <html> block";
$m->content_contains('<html lang="zh-tw">');
use strict;
use warnings;
-use Encode;
use RT::Test tests => 78;
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$set}{test}/
or do { $status = 0; diag "wrong subject: $subject" };
}
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$tag_set}{support}/
or do { $status = 0; diag "wrong subject: $subject" };
}
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$tag_set}{support}/
or do { $status = 0; diag "wrong subject: $subject" };
$subject =~ /$string{$set}{test}/
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$prefix_set}{autoreply}/
or do { $status = 0; diag "wrong subject: $subject" };
}
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$prefix_set}{autoreply}/
or do { $status = 0; diag "wrong subject: $subject" };
$subject =~ /$string{$set}{test}/
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$prefix_set}{autoreply}/
or do { $status = 0; diag "wrong subject: $subject" };
$subject =~ /$string{$tag_set}{support}/
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$set}{test}/
or do { $status = 0; diag "wrong subject: $subject" };
}
my $status = 1;
foreach my $mail ( @mails ) {
my $entity = parse_mail( $mail );
- my $subject = Encode::decode_utf8( $entity->head->get('Subject') );
+ my $subject = Encode::decode( "UTF-8", $entity->head->get('Subject') );
$subject =~ /$string{$set}{test}/
or do { $status = 0; diag "wrong subject: $subject" };
$subject =~ /$string{$tag_set}{support}/
}
}
-use utf8;
-
my $root = RT::Test->load_or_create_user( Name => 'root' );
my ( $baseurl, $m ) = RT::Test->started_ok;
my $ticket = RT::Ticket->new( $RT::SystemUser );
$ticket->Create(
Queue => 'General',
- Subject => 'test äöü',
+ Subject => Encode::decode("UTF-8",'test äöü'),
);
ok( $ticket->id, 'created ticket' );
-$m->get_ok(q{/Search/Chart.html?Query=Subject LIKE 'test äöü'});
+$m->get_ok(Encode::decode("UTF-8", q{/Search/Chart.html?Query=Subject LIKE 'test äöü'}));
$m->submit_form(
form_name => 'SaveSearch',
fields => {
$m->click_button( name => 'Save' );
$m->content_contains('Subscribed to dashboard dashboard foo');
-my $c = $m->get(q{/Search/Chart?Query=Subject LIKE 'test äöü'});
+my $c = $m->get(Encode::decode("UTF-8",q{/Search/Chart?Query=Subject LIKE 'test äöü'}));
my $image = $c->content;
RT::Test->run_and_capture(
command => $RT::SbinPath . '/rt-email-dashboards', all => 1
use strict;
use warnings;
-use utf8;
use RT::Test tests => 18;
is ($tick->Id, $id, "correct ticket");
is ($tick->Subject , 'This is a test of I18N ticket creation', "Created the ticket - ". $tick->Subject);
- my $unistring = "\303\241\303\251\303\255\303\263\303\272";
- Encode::_utf8_on($unistring);
+ my $unistring = Encode::decode("UTF-8","\303\241\303\251\303\255\303\263\303\272");
is (
$tick->Transactions->First->Content,
$tick->Transactions->First->Attachments->First->Content,
is ($tick->Id, $id, "correct ticket");
is ($tick->Subject , 'This is a test of I18N ticket creation', "Created the ticket");
- my $unistring = "\303\241\303\251\303\255\303\263\303\272";
- Encode::_utf8_on($unistring);
+ my $unistring = Encode::decode("UTF-8","\303\241\303\251\303\255\303\263\303\272");
ok (
$tick->Transactions->First->Content =~ $unistring,
my $tick = RT::Test->last_ticket;
is ($tick->Id, $id, "correct ticket");
- my $content = $tick->Transactions->First->Content;
- Encode::_utf8_off($content);
+ my $content = Encode::encode("UTF-8",$tick->Transactions->First->Content);
like $content, qr{informaci\303\263n confidencial};
like $content, qr{informaci\357\277\275n confidencial};
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 12;
+use Test::Warn;
+
+my ($baseurl, $m) = RT::Test->started_ok;
+
+diag "Testing non-ASCII in From: header";
+SKIP:{
+ skip "Test requires Email::Address 1.893 or later, "
+ . "you have $Email::Address::VERSION", 3,
+ if $Email::Address::VERSION < 1.893;
+
+ my $mail = Encode::encode( 'iso-8859-1', Encode::decode( "UTF-8", <<'.') );
+From: René@example.com>
+Reply-To: =?iso-8859-1?Q?Ren=E9?= <René@example.com>
+Subject: testing non-ASCII From
+Content-Type: text/plain; charset=iso-8859-1
+
+here's some content
+.
+
+ my ($status, $id);
+ warnings_like { ( $status, $id ) = RT::Test->send_via_mailgate($mail) }
+ [qr/Failed to parse Reply-To:.*, From:/,
+ qr/Couldn't parse or find sender's address/
+ ],
+ 'Got parse error for non-ASCII in From';
+ is( $status >> 8, 0, "The mail gateway exited normally" );
+ TODO: {
+ local $TODO = "Currently don't handle non-ASCII for sender";
+ ok( $id, "Created ticket" );
+ }
+}
+
+diag "Testing iso-8859-1 encoded non-ASCII in From: header";
+SKIP:{
+ skip "Test requires Email::Address 1.893 or later, "
+ . "you have $Email::Address::VERSION", 3,
+ if $Email::Address::VERSION < 1.893;
+
+ my $mail = Encode::encode( 'iso-8859-1', Encode::decode( "UTF-8", <<'.' ) );
+From: =?iso-8859-1?Q?Ren=E9?= <René@example.com>
+Reply-To: =?iso-8859-1?Q?Ren=E9?= <René@example.com>
+Subject: testing non-ASCII From
+Content-Type: text/plain; charset=iso-8859-1
+
+here's some content
+.
+
+ my ($status, $id);
+ warnings_like { ( $status, $id ) = RT::Test->send_via_mailgate($mail) }
+ [qr/Failed to parse Reply-To:.*, From:/,
+ qr/Couldn't parse or find sender's address/
+ ],
+ 'Got parse error for iso-8859-1 in From';
+ is( $status >> 8, 0, "The mail gateway exited normally" );
+ TODO: {
+ local $TODO = "Currently don't handle non-ASCII in sender";
+ ok( $id, "Created ticket" );
+ }
+}
+
+diag "No sender";
+{
+ my $mail = <<'.';
+To: rt@example.com
+Subject: testing non-ASCII From
+Content-Type: text/plain; charset=iso-8859-1
+
+here's some content
+.
+
+ my ($status, $id);
+ warnings_like { ( $status, $id ) = RT::Test->send_via_mailgate($mail) }
+ [qr/Couldn't parse or find sender's address/],
+ 'Got parse error with no sender fields';
+ is( $status >> 8, 0, "The mail gateway exited normally" );
+ ok( !$id, "No ticket created" );
+}
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+use Test::Warn;
+
+my $queue = RT::Test->load_or_create_queue( Name => 'General' );
+ok $queue->id, 'loaded queue';
+
+{
+ my $mail = <<'END';
+From: root@localhost
+Subject: test
+Content-type: text/plain; charset="not-supported-encoding"
+
+ho hum just some text
+
+END
+
+ my ($stat, $id);
+ warning_like {
+ ($stat, $id) = RT::Test->send_via_mailgate($mail);
+ is( $stat >> 8, 0, "The mail gateway exited normally" );
+ ok( $id, "created ticket" );
+ } qr/Encoding 'not-supported-encoding' is not supported/;
+
+ my $ticket = RT::Ticket->new( RT->SystemUser );
+ $ticket->Load($id);
+ ok $ticket->id, "loaded ticket";
+
+ my $txn = $ticket->Transactions->First;
+ ok !$txn->ContentObj, 'no content';
+
+ my $attach = $txn->Attachments->First;
+ like $attach->Content, qr{ho hum just some text}, 'attachment is there';
+ is $attach->GetHeader('Content-Type'),
+ 'application/octet-stream; charset="not-supported-encoding"',
+ 'content type is changed'
+ ;
+ is $attach->GetHeader('X-RT-Original-Content-Type'),
+ 'text/plain',
+ 'original content type is saved'
+ ;
+}
+
+{
+ my $mail = <<'END';
+From: root@localhost
+Subject: =?not-supported?Q?=07test=A9?=
+Content-type: text/plain; charset="ascii"
+
+ho hum just some text
+
+END
+
+ my ($stat, $id);
+ warning_like {
+ ($stat, $id) = RT::Test->send_via_mailgate($mail);
+ is( $stat >> 8, 0, "The mail gateway exited normally" );
+ ok( $id, "created ticket" );
+ } qr/Charset 'not-supported' is not supported/;
+
+ my $ticket = RT::Ticket->new( RT->SystemUser );
+ $ticket->Load($id);
+ ok $ticket->id, "loaded ticket";
+ is $ticket->Subject, "\x{FFFD}test\x{FFFD}";
+}
+
+done_testing;
use strict;
use warnings;
-use utf8;
use RT::Test tests => 38;
use strict;
use warnings;
-use utf8;
use RT::Test tests => undef;
my ($baseurl, $m) = RT::Test->started_ok;
ok $m->login, 'logged in as root';
ok( $id, "Created ticket" );
$m->get_ok("/Ticket/Display.html?id=$id");
- $m->content_contains("新しいテキスト ドキュメント.txt", "found full filename");
+ $m->content_contains(Encode::decode("UTF-8","新しいテキスト ドキュメント.txt"), "found full filename");
}
undef $m;
use strict;
use warnings;
-use File::Spec ();
-
-use RT::Test tests => 141;
-use RT::EmailParser;
-use RT::Tickets;
-use RT::Action::SendEmail;
+use RT::Test tests => undef;
-my @_outgoing_messages;
-my @scrips_fired;
+use File::Spec ();
+use Email::Abstract;
-#We're not testing acls here.
+# We're not testing acls here.
my $everyone = RT::Group->new(RT->SystemUser);
$everyone->LoadSystemInternalGroup('Everyone');
$everyone->PrincipalObj->GrantRight( Right =>'SuperUser' );
-
-is (__PACKAGE__, 'main', "We're operating in the main package");
-
-{
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
-
- main::_fired_scrip($self->ScripObj);
- main::is(ref($MIME) , 'MIME::Entity', "hey, look. it's a mime entity");
- };
-}
-
# some utils
sub first_txn { return $_[0]->Transactions->First }
sub first_attach { return first_txn($_[0])->Attachments->First }
-
-sub count_txns { return $_[0]->Transactions->Count }
sub count_attachs { return first_txn($_[0])->Attachments->Count }
-# instrument SendEmail to pass us what it's about to send.
-# create a regular ticket
-
-my $parser = RT::EmailParser->new();
-
-# Let's test to make sure a multipart/report is processed correctly
-my $multipart_report_email = RT::Test::get_relocatable_file('multipart-report',
- (File::Spec->updir(), 'data', 'emails'));
-my $content = RT::Test->file_content($multipart_report_email);
-# be as much like the mail gateway as possible.
-use RT::Interface::Email;
-my %args = (message => $content, queue => 1, action => 'correspond');
-my ($status, $msg) = RT::Interface::Email::Gateway(\%args);
-ok($status, "successfuly used Email::Gateway interface") or diag("error: $msg");
-my $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
-my $tick= $tickets->First();
-isa_ok($tick, "RT::Ticket", "got a ticket object");
-ok ($tick->Id, "found ticket ".$tick->Id);
-like (first_txn($tick)->Content , qr/The original message was received/, "It's the bounce");
-
-
-# make sure it fires scrips.
-is ($#scrips_fired, 1, "Fired 2 scrips on ticket creation");
-
-undef @scrips_fired;
-
-
-
-
-$parser->ParseMIMEEntityFromScalar('From: root@localhost
-To: rt@example.com
-Subject: This is a test of new ticket creation as an unknown user
-
-Blah!
-Foob!');
-
-
-use Data::Dumper;
-
-my $ticket = RT::Ticket->new(RT->SystemUser);
-my ($id, undef, $create_msg ) = $ticket->Create(Requestor => ['root@localhost'], Queue => 'general', Subject => 'I18NTest', MIMEObj => $parser->Entity);
-ok ($id,$create_msg);
-$tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-is ($tick->Subject , 'I18NTest', "failed to create the new ticket from an unprivileged account");
-
-# make sure it fires scrips.
-is ($#scrips_fired, 1, "Fired 2 scrips on ticket creation");
-# make sure it sends an autoreply
-# make sure it sends a notification to adminccs
-
-
-# we need to swap out SendMessage to test the new things we care about;
-&utf8_redef_sendmessage;
-
-# create an iso 8859-1 ticket
-@scrips_fired = ();
-
-my $iso_8859_1_ticket_email = RT::Test::get_relocatable_file(
- 'new-ticket-from-iso-8859-1', (File::Spec->updir(), 'data', 'emails'));
-$content = RT::Test->file_content($iso_8859_1_ticket_email);
-
-
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
-use RT::Interface::Email;
-
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_txn($tick)->Content , qr/H\x{e5}vard/, "It's signed by havard. yay");
-
-
-# make sure it fires scrips.
-is ($#scrips_fired, 1, "Fired 2 scrips on ticket creation");
-# make sure it sends an autoreply
-
-
-# make sure it sends a notification to adminccs
-
-# If we correspond, does it do the right thing to the outbound messages?
-
-$parser->ParseMIMEEntityFromScalar($content);
- ($id, $msg) = $tick->Comment(MIMEObj => $parser->Entity);
-ok ($id, $msg);
-
-$parser->ParseMIMEEntityFromScalar($content);
-($id, $msg) = $tick->Correspond(MIMEObj => $parser->Entity);
-ok ($id, $msg);
-
-
-
-
-
-# we need to swap out SendMessage to test the new things we care about;
-&iso8859_redef_sendmessage;
-RT->Config->Set( EmailOutputEncoding => 'iso-8859-1' );
-# create an iso 8859-1 ticket
-@scrips_fired = ();
-
- $content = RT::Test->file_content($iso_8859_1_ticket_email);
-# be as much like the mail gateway as possible.
-use RT::Interface::Email;
-
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
-$tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_txn($tick)->Content , qr/H\x{e5}vard/, "It's signed by havard. yay");
-
-
-# make sure it fires scrips.
-is ($#scrips_fired, 1, "Fired 2 scrips on ticket creation");
-# make sure it sends an autoreply
-
-
-# make sure it sends a notification to adminccs
-
-
-# If we correspond, does it do the right thing to the outbound messages?
-
-$parser->ParseMIMEEntityFromScalar($content);
- ($id, $msg) = $tick->Comment(MIMEObj => $parser->Entity);
-ok ($id, $msg);
-
-$parser->ParseMIMEEntityFromScalar($content);
-($id, $msg) = $tick->Correspond(MIMEObj => $parser->Entity);
-ok ($id, $msg);
-
-
-sub _fired_scrip {
- my $scrip = shift;
- push @scrips_fired, $scrip;
-}
+sub mail_in_ticket {
+ my ($filename) = @_;
+ my $path = RT::Test::get_relocatable_file($filename,
+ (File::Spec->updir(), 'data', 'emails'));
+ my $content = RT::Test->file_content($path);
-sub utf8_redef_sendmessage {
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
+ RT::Test->clean_caught_mails;
+ my ($status, $id) = RT::Test->send_via_mailgate( $content );
+ ok( $status, "Fed $filename into mailgate");
- my $scrip = $self->ScripObj->id;
- ok(1, $self->ScripObj->ConditionObj->Name . " ".$self->ScripObj->ActionObj->Name);
- main::_fired_scrip($self->ScripObj);
- $MIME->make_singlepart;
- main::is( ref($MIME) , 'MIME::Entity',
- "hey, look. it's a mime entity" );
- main::is( ref( $MIME->head ) , 'MIME::Head',
- "its mime header is a mime header. yay" );
- main::like( $MIME->head->get('Content-Type') , qr/utf-8/,
- "Its content type is utf-8" );
- my $message_as_string = $MIME->bodyhandle->as_string();
- use Encode;
- $message_as_string = Encode::decode_utf8($message_as_string);
- main::like(
- $message_as_string , qr/H\x{e5}vard/,
-"The message's content contains havard's name. this will fail if it's not utf8 out");
+ my $ticket = RT::Ticket->new(RT->SystemUser);
+ $ticket->Load($id);
+ ok( $ticket->Id, "Successfully created ticket ".$ticket->Id);
- };
+ my @mail = map {Email::Abstract->new($_)->cast('MIME::Entity')}
+ RT::Test->fetch_caught_mails;
+ return ($ticket, @mail);
}
-sub iso8859_redef_sendmessage {
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
-
- my $scrip = $self->ScripObj->id;
- ok(1, $self->ScripObj->ConditionObj->Name . " ".$self->ScripObj->ActionObj->Name);
- main::_fired_scrip($self->ScripObj);
- $MIME->make_singlepart;
- main::is( ref($MIME) , 'MIME::Entity',
- "hey, look. it's a mime entity" );
- main::is( ref( $MIME->head ) , 'MIME::Head',
- "its mime header is a mime header. yay" );
- main::like( $MIME->head->get('Content-Type') , qr/iso-8859-1/,
- "Its content type is iso-8859-1 - " . $MIME->head->get("Content-Type") );
- my $message_as_string = $MIME->bodyhandle->as_string();
- use Encode;
- $message_as_string = Encode::decode("iso-8859-1",$message_as_string);
- main::like(
- $message_as_string , qr/H\x{e5}vard/, "The message's content contains havard's name. this will fail if it's not utf8 out");
- };
+{
+ my ($ticket) = mail_in_ticket('multipart-report');
+ like( first_txn($ticket)->Content , qr/The original message was received/, "It's the bounce");
}
+for my $encoding ('ISO-8859-1', 'UTF-8') {
+ RT->Config->Set( EmailOutputEncoding => $encoding );
- my $alt_umlaut_email = RT::Test::get_relocatable_file(
- 'multipart-alternative-with-umlaut', (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($alt_umlaut_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
+ my ($ticket, @mail) = mail_in_ticket('new-ticket-from-iso-8859-1');
+ like (first_txn($ticket)->Content , qr/H\x{e5}vard/, "It's signed by havard. yay");
+ is(@mail, 1);
+ like( $mail[0]->head->get('Content-Type') , qr/$encoding/,
+ "Its content type is $encoding" );
+ my $message_as_string = $mail[0]->bodyhandle->as_string();
+ $message_as_string = Encode::decode($encoding, $message_as_string);
+ like( $message_as_string , qr/H\x{e5}vard/,
+ "The message's content contains havard's name in $encoding");
+}
-# be as much like the mail gateway as possible.
{
- no warnings qw/redefine/;
- local *RT::Action::SendEmail::SendMessage = sub { return 1};
-
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- # TODO: following 5 lines should replaced by get_latest_ticket_ok()
- $tickets = RT::Tickets->new(RT->SystemUser);
- $tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
- $tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-
- ok ($tick->Id, "found ticket ".$tick->Id);
-
- like (first_txn($tick)->Content , qr/causes Error/, "We recorded the content right as text-plain");
- is (count_attachs($tick) , 3 , "Has three attachments, presumably a text-plain, a text-html and a multipart alternative");
-
+ my ($ticket) = mail_in_ticket('multipart-alternative-with-umlaut');
+ like( first_txn($ticket)->Content, qr/causes Error/,
+ "We recorded the content as containing 'causes error'");
+ is( count_attachs($ticket), 3,
+ "Has three attachments, presumably a text-plain, a text-html and a multipart alternative");
}
-
- my $text_html_email = RT::Test::get_relocatable_file('text-html-with-umlaut',
- (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($text_html_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
-&text_html_redef_sendmessage;
-
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_attach($tick)->Content , qr/causes Error/, "We recorded the content as containing 'causes error'") or diag( first_attach($tick)->Content );
-like (first_attach($tick)->ContentType , qr/text\/html/, "We recorded the content as text/html");
-is (count_attachs($tick), 1 , "Has one attachment, presumably a text-html and a multipart alternative");
-
-sub text_html_redef_sendmessage {
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
- return (1) unless ($self->ScripObj->ScripActionObj->Name eq "Notify AdminCcs" );
- is ($MIME->parts, 0, "generated correspondence mime entity
- does not have parts");
- is ($MIME->head->mime_type , "text/plain", "The mime type is a plain");
- };
+{
+ my ($ticket, @mail) = mail_in_ticket('text-html-with-umlaut');
+ like( first_attach($ticket)->Content, qr/causes Error/,
+ "We recorded the content as containing 'causes error'");
+ like( first_attach($ticket)->ContentType , qr/text\/html/,
+ "We recorded the content as text/html");
+ is (count_attachs($ticket), 1,
+ "Has one attachment, just a text-html");
+
+ is(@mail, 1);
+ is( $mail[0]->parts, 0, "generated correspondence mime entity does not have parts");
+ is( $mail[0]->head->mime_type , "text/plain", "The mime type is a plain");
}
-
- my $russian_email = RT::Test::get_relocatable_file('text-html-in-russian',
- (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($russian_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-# be as much like the mail gateway as possible.
-&text_html_redef_sendmessage;
-
- %args = (message => $content, queue => 1, action => 'correspond');
-
{
-
-my @warnings;
-local $SIG{__WARN__} = sub {
- push @warnings, "@_";
-};
-
-RT::Interface::Email::Gateway(\%args);
-
-TODO: {
- local $TODO =
-'need a better approach of encoding converter, should be fixed in 4.2';
-ok( @warnings == 1 || @warnings == 2, "1 or 2 warnings are ok" );
-ok( @warnings == 1 || ( @warnings == 2 && $warnings[1] eq $warnings[0] ),
- 'if there are 2 warnings, they should be same' );
-
-like(
- $warnings[0],
- qr/\QEncoding error: "\x{041f}" does not map to iso-8859-1/,
-"The badly formed Russian spam we have isn't actually well-formed UTF8, which makes Encode (correctly) warn",
-);
-
-}
+ my @InputEncodings = RT->Config->Get('EmailInputEncodings');
+ RT->Config->Set( EmailInputEncodings => 'koi8-r', @InputEncodings );
+ RT->Config->Set( EmailOutputEncoding => 'koi8-r' );
+
+ my ($ticket, @mail) = mail_in_ticket('russian-subject-no-content-type');
+ like( first_attach($ticket)->ContentType, qr/text\/plain/,
+ "We recorded the content type right");
+ is( count_attachs($ticket), 1,
+ "Has one attachment, presumably a text-plain");
+ is( $ticket->Subject, Encode::decode("UTF-8","тест тест"),
+ "Recorded the subject right");
+
+ is(@mail, 1);
+ is( $mail[0]->head->mime_type , "text/plain", "The only part is text/plain ");
+ like( $mail[0]->head->get("subject"), qr/\Q=?KOI8-R?B?W2V4YW1wbGUuY29tICM2XSBBdXRvUmVwbHk6INTF09Qg1MXT1A==?=\E/,
+ "The subject is encoded correctly");
+
+ RT->Config->Set(EmailInputEncodings => @InputEncodings );
+ RT->Config->Set(EmailOutputEncoding => 'utf-8');
}
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick = $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_attach($tick)->ContentType , qr/text\/html/, "We recorded the content right as text-html");
-
-is (count_attachs($tick) ,1 , "Has one attachment, presumably a text-html and a multipart alternative");
-
-
-
-RT->Config->Set( EmailInputEncodings => 'koi8-r', RT->Config->Get('EmailInputEncodings') );
-RT->Config->Set( EmailOutputEncoding => 'koi8-r' );
-my $russian_subject_email = RT::Test::get_relocatable_file(
- 'russian-subject-no-content-type', (File::Spec->updir(), 'data', 'emails'));
-$content = RT::Test->file_content($russian_subject_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
-&text_plain_russian_redef_sendmessage;
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
-$tick= $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_attach($tick)->ContentType , qr/text\/plain/, "We recorded the content type right");
-is (count_attachs($tick) ,1 , "Has one attachment, presumably a text-plain");
-is ($tick->Subject, "\x{442}\x{435}\x{441}\x{442} \x{442}\x{435}\x{441}\x{442}", "Recorded the subject right");
-sub text_plain_russian_redef_sendmessage {
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
- return (1) unless ($self->ScripObj->ScripActionObj->Name eq "Notify AdminCcs" );
- is ($MIME->head->mime_type , "text/plain", "The only part is text/plain ");
- my $subject = $MIME->head->get("subject");
- chomp($subject);
- #is( $subject , /^=\?KOI8-R\?B\?W2V4YW1wbGUuY39tICM3XSDUxdPUINTF09Q=\?=/ , "The $subject is encoded correctly");
- };
+{
+ my ($ticket, @mail) = mail_in_ticket('nested-rfc-822');
+ is( $ticket->Subject, "[Jonas Liljegren] Re: [Para] Niv\x{e5}er?");
+ like( first_attach($ticket)->ContentType, qr/multipart\/mixed/,
+ "We recorded the content type right");
+ is( count_attachs($ticket), 5,
+ "Has five attachments, presumably a text-plain and a message RFC 822 and another plain");
+
+ is(@mail, 1);
+ is( $mail[0]->head->mime_type , "text/plain", "The outgoing mail is plain text");
+
+ my $encoded_subject = $mail[0]->head->get("Subject");
+ chomp $encoded_subject;
+ my $subject = Encode::decode('MIME-Header',$encoded_subject);
+ like($subject, qr/Niv\x{e5}er/, "The subject matches the word - $subject");
}
-my @input_encodings = RT->Config->Get( 'EmailInputEncodings' );
-shift @input_encodings;
-RT->Config->Set(EmailInputEncodings => @input_encodings );
-RT->Config->Set(EmailOutputEncoding => 'utf-8');
-
-
-
-my $nested_rfc822_email = RT::Test::get_relocatable_file('nested-rfc-822',
- (File::Spec->updir(), 'data', 'emails'));
-$content = RT::Test->file_content($nested_rfc822_email);
-ok ($content, "Loaded nested-rfc-822 to test");
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
-&text_plain_nested_redef_sendmessage;
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
-$tick= $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-is ($tick->Subject, "[Jonas Liljegren] Re: [Para] Niv\x{e5}er?");
-like (first_attach($tick)->ContentType , qr/multipart\/mixed/, "We recorded the content type right");
-is (count_attachs($tick) , 5 , "Has one attachment, presumably a text-plain and a message RFC 822 and another plain");
-sub text_plain_nested_redef_sendmessage {
- no warnings qw/redefine/;
- *RT::Action::SendEmail::SendMessage = sub {
- my $self = shift;
- my $MIME = shift;
-
- return (1) unless ($self->ScripObj->ScripActionObj->Name eq "Notify AdminCcs" );
-
- is ($MIME->head->mime_type , "multipart/mixed", "It is a mixed multipart");
-
- use MIME::Words qw(:all);
- my $encoded_subject = $MIME->head->get("subject");
- my $subject = decode_mimewords($encoded_subject);
-
- # MIME::Words isn't actually UTF8-safe. There go 4 hours I'll never get back.
- utf8::decode($subject);
- like($subject, qr/Niv\x{e5}er/, "The subject matches the word - $subject");
-
- 1;
- };
+{
+ my ($ticket) = mail_in_ticket('notes-uuencoded');
+ like( first_txn($ticket)->Content, qr/from Lotus Notes/,
+ "We recorded the content right");
+ is( count_attachs($ticket), 3, "Has three attachments");
}
-
-
-
- my $uuencoded_email = RT::Test::get_relocatable_file('notes-uuencoded',
- (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($uuencoded_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
{
- no warnings qw/redefine/;
- local *RT::Action::SendEmail::SendMessage = sub { return 1};
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
- $tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
- $tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
- $tick= $tickets->First();
- ok ($tick->Id, "found ticket ".$tick->Id);
-
- like (first_txn($tick)->Content , qr/from Lotus Notes/, "We recorded the content right");
- is (count_attachs($tick) , 3 , "Has three attachments");
+ my ($ticket) = mail_in_ticket('crashes-file-based-parser');
+ like( first_txn($ticket)->Content, qr/FYI/, "We recorded the content right");
+ is( count_attachs($ticket), 5, "Has five attachments");
}
+{
+ my ($ticket) = mail_in_ticket('rt-send-cc');
+ my $cc = first_attach($ticket)->GetHeader('RT-Send-Cc');
+ like ($cc, qr/test$_/, "Found test $_") for 1..5;
+}
-
- my $crashes_file_based_parser_email = RT::Test::get_relocatable_file(
- 'crashes-file-based-parser', (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($crashes_file_based_parser_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-# be as much like the mail gateway as possible.
-
-no warnings qw/redefine/;
-local *RT::Action::SendEmail::SendMessage = sub { return 1};
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
-$tick= $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-like (first_txn($tick)->Content , qr/FYI/, "We recorded the content right");
-is (count_attachs($tick) , 5 , "Has three attachments");
-
-
-
-
-
-
- my $rt_send_cc_email = RT::Test::get_relocatable_file('rt-send-cc',
- (File::Spec->updir(), 'data', 'emails'));
- $content = RT::Test->file_content($rt_send_cc_email);
-
-$parser->ParseMIMEEntityFromScalar($content);
-
-
-
- %args = (message => $content, queue => 1, action => 'correspond');
- RT::Interface::Email::Gateway(\%args);
- $tickets = RT::Tickets->new(RT->SystemUser);
-$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC');
-$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0');
-$tick= $tickets->First();
-ok ($tick->Id, "found ticket ".$tick->Id);
-
-my $cc = first_attach($tick)->GetHeader('RT-Send-Cc');
-like ($cc , qr/test1/, "Found test 1");
-like ($cc , qr/test2/, "Found test 2");
-like ($cc , qr/test3/, "Found test 3");
-like ($cc , qr/test4/, "Found test 4");
-like ($cc , qr/test5/, "Found test 5");
-
-
-diag q{regression test for #5248 from rt3.fsck.com};
{
- my $subject_folding_email = RT::Test::get_relocatable_file(
- 'subject-with-folding-ws', (File::Spec->updir(), 'data', 'emails'));
- my $content = RT::Test->file_content($subject_folding_email);
- my ($status, $msg, $ticket) = RT::Interface::Email::Gateway(
- { message => $content, queue => 1, action => 'correspond' }
- );
- ok ($status, 'created ticket') or diag "error: $msg";
- ok ($ticket->id, "found ticket ". $ticket->id);
+ diag "Regression test for #5248 from rt3.fsck.com";
+ my ($ticket) = mail_in_ticket('subject-with-folding-ws');
is ($ticket->Subject, 'test', 'correct subject');
}
-diag q{regression test for #5248 from rt3.fsck.com};
{
- my $long_subject_email = RT::Test::get_relocatable_file('very-long-subject',
- (File::Spec->updir(), 'data', 'emails'));
- my $content = RT::Test->file_content($long_subject_email);
- my ($status, $msg, $ticket) = RT::Interface::Email::Gateway(
- { message => $content, queue => 1, action => 'correspond' }
- );
- ok ($status, 'created ticket') or diag "error: $msg";
- ok ($ticket->id, "found ticket ". $ticket->id);
+ diag "Regression test for #5248 from rt3.fsck.com";
+ my ($ticket) = mail_in_ticket('very-long-subject');
is ($ticket->Subject, '0123456789'x20, 'correct subject');
}
-
-
-# Don't taint the environment
-$everyone->PrincipalObj->RevokeRight(Right =>'SuperUser');
+done_testing;
use strict;
use warnings;
-use utf8;
use RT::Test tests => 22;
RT->Config->Set( NotifyActor => 1 );
use RT::Test nodb => 1, tests => 6;
use_ok('RT::I18N');
-use utf8;
-use Encode;
-my $test_string = 'À';
-my $encoded_string = encode( 'iso-8859-1', $test_string );
+my $test_string = Encode::decode("UTF-8", 'À');
+my $encoded_string = Encode::encode( 'iso-8859-1', $test_string );
my $mime = MIME::Entity->build(
"Subject" => $encoded_string,
"Data" => [$encoded_string],
"We can't encode something into the wrong encoding without Encode complaining"
);
-my $subject = decode( 'iso-8859-1', $mime->head->get('Subject') );
+my $subject = Encode::decode( 'iso-8859-1', $mime->head->get('Subject') );
chomp $subject;
is( $subject, $test_string, 'subject is set to iso-8859-1' );
-my $body = decode( 'iso-8859-1', $mime->stringify_body );
+my $body = Encode::decode( 'iso-8859-1', $mime->stringify_body );
chomp $body;
is( $body, $test_string, 'body is set to iso-8859-1' );
}
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my ($base, $m) = RT::Test->started_ok;
+
+my $link = RT::Test->load_or_create_custom_field(
+ Name => 'link',
+ Type => 'Freeform',
+ MaxValues => 1,
+ Queue => 0,
+ LinkValueTo => '__CustomField__',
+);
+
+my $include = RT::Test->load_or_create_custom_field(
+ Name => 'include',
+ Type => 'Freeform',
+ MaxValues => 1,
+ Queue => 0,
+ IncludeContentForValue => '__CustomField__',
+);
+
+my $data_uri = 'data:text/html;base64,PHNjcmlwdD5hbGVydChkb2N1bWVudC5jb29raWUpPC9zY3JpcHQ+';
+my $xss = q{')-eval(decodeURI('alert("xss")'))-('};
+
+my $ticket = RT::Ticket->new(RT->SystemUser);
+$ticket->Create(
+ Queue => 'General',
+ Subject => 'ticket A',
+ 'CustomField-'.$link->id => $data_uri,
+ 'CustomField-'.$include->id => $xss,
+);
+ok $ticket->Id, 'created ticket';
+
+ok $m->login('root', 'password'), "logged in";
+$m->get_ok($base . "/Ticket/Display.html?id=" . $ticket->id);
+
+# look for lack of link to data:text/html;base64,...
+ok !$m->find_link(text => $data_uri), "no data: link";
+ok !$m->find_link(url => $data_uri), "no data: link";
+
+# look for unescaped JS
+$m->content_lacks($xss, 'escaped js');
+
+$m->warning_like(qr/Potentially dangerous URL type/, "found warning about dangerous link");
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+use Test::Warn;
+
+my ($base, $m) = RT::Test->started_ok;
+
+my $ticket = RT::Test->create_ticket(
+ Queue => 'General',
+ Subject => 'test ticket A',
+);
+my $id = $ticket->id;
+ok $id, "created ticket";
+
+my @links = (
+ 'javascript:alert("xss")',
+ 'data:text/html,<script>alert("xss")</script>',
+);
+
+for my $link ( map { ($_, ucfirst $_) } @links ) {
+ my ($ok, $msg);
+ warnings_like {
+ ($ok, $msg) = $ticket->AddLink(
+ Type => 'RefersTo',
+ Target => $link,
+ );
+ } [qr/Could not determine a URI scheme/, qr/Couldn't resolve/];
+ ok !$ok, $msg;
+
+ ok $m->login, "logged in";
+ $m->get_ok($base);
+ $m->follow_link_ok({ text => 'test ticket A' }, 'ticket page');
+ $m->follow_link_ok({ text => 'Links' }, 'links page');
+ $m->submit_form_ok({
+ with_fields => {
+ "$id-RefersTo" => $link,
+ },
+ button => 'SubmitTicket',
+ }, 'submitted links page');
+ $m->content_contains("Couldn't resolve ");
+ $m->next_warning_like(qr/Could not determine a URI scheme/, 'expected warning');
+ $m->next_warning_like(qr/Couldn't resolve/, 'expected warning');
+
+ my $element = $m->find_link( url => $link );
+ ok !$element, "no <a> link";
+}
+
+$m->no_leftover_warnings_ok;
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test nodb => 1, tests => undef;
+use RT::Interface::Web; # This gets us HTML::Mason::Commands
+use Test::LongString;
+
+{
+ my $html = '<div id="metadata"><span class="actions"><a>OH HAI</a></span></div><p>Moose</p>';
+ my $expected = '<div><span><a>OH HAI</a></span></div><p>Moose</p>';
+ is_string(scrub_html($html), $expected, "class and id are stripped");
+}
+
+sub scrub_html {
+ return HTML::Mason::Commands::ScrubHTML(shift);
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my $user = RT::Test->load_or_create_user(
+ Name => 'user',
+ EmailAddress => 'user@example.com',
+ Privileged => 1,
+ Password => 'password',
+);
+
+ok(
+ RT::Test->set_rights(
+ { Principal => 'Everyone', Right => [qw/CreateTicket/] },
+ { Principal => 'Requestor', Right => [qw/ShowTicket/] },
+ ),
+ 'set rights'
+);
+
+my $secret = "sekrit message";
+
+RT::Test->create_tickets(
+ {},
+ {
+ Subject => 'ticket A',
+ Requestor => $user->EmailAddress,
+ Content => "user's ticket",
+ },
+ {
+ Subject => 'ticket B',
+ Requestor => 'root@localhost',
+ Content => $secret,
+ },
+);
+
+my $ticket_b = RT::Test->last_ticket;
+
+my ($baseurl, $m) = RT::Test->started_ok;
+ok $m->login( 'user', 'password' ), 'logged in as user';
+
+$m->get_ok("$baseurl/Ticket/Display.html?id=" . $ticket_b->id);
+$m->content_contains('No permission');
+$m->warning_like(qr/no permission/i, 'no permission warning');
+
+RT::Test->clean_caught_mails;
+
+# Ticket Create is just one example of where this is vulnerable
+$m->get_ok('/Ticket/Create.html?Queue=1');
+$m->submit_form_ok({
+ form_name => 'TicketCreate',
+ fields => {
+ Subject => 'ticket C',
+ AttachTickets => $ticket_b->id,
+ },
+}, 'create a ticket');
+
+my @mail = RT::Test->fetch_caught_mails;
+ok @mail, "got some outgoing emails";
+unlike $mail[0], qr/\Q$secret\E/, "doesn't contain ticket user can't see";
+
+undef $m;
+done_testing;
+
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+use JSON qw(decode_json);
+
+my ($base, $m) = RT::Test->started_ok;
+
+my $cf1 = RT::Test->load_or_create_custom_field(
+ Name => 'cf1',
+ Type => 'Select',
+ MaxValues => 1,
+ Queue => 0,
+);
+ok $cf1->id, "created cf1";
+
+my $cf2 = RT::Test->load_or_create_custom_field(
+ Name => 'cf2',
+ Type => 'Select',
+ MaxValues => 1,
+ Queue => 0,
+);
+ok $cf2->id, "created cf2";
+
+ok( $cf1->AddValue( Name => "cf1 value $_" ) ) for qw(a b c);
+ok( $cf2->AddValue( Name => "cf2 value $_" ) ) for qw(x y z);
+
+sub ac {
+ my (%args) = (
+ CF => $cf1->id,
+ Term => "%",
+ Context => undef,
+ ContextId => undef,
+ ContextType => undef,
+ @_
+ );
+ $args{term} = delete $args{Term};
+
+ if (my $obj = delete $args{Context}) {
+ $args{ContextId} = $obj->Id unless defined $args{ContextId};
+ $args{ContextType} = ref($obj) unless defined $args{ContextType};
+ }
+
+ $args{"Object---CustomField-$args{CF}-Values"} = "";
+ delete $args{CF};
+
+ delete $args{$_} for grep {not defined $args{$_}} keys %args;
+
+ my $URI = URI->new("$base/Helpers/Autocomplete/CustomFieldValues");
+ $URI->query_form( %args );
+ $m->get_ok($URI, "GET to autocompleter");
+ return decode_json($m->content);
+}
+
+$m->login;
+is_deeply ac(CF => 12345, ContextId => 1, ContextType => "RT::Queue"),
+ [], 'nothing for invalid CF';
+
+is_deeply ac(),
+ [], "Nothing without a context id";
+is_deeply ac( ContextId => 12345, ContextType => "RT::Queue"),
+ [], "Nothing with invalid contextid id";
+is_deeply ac( ContextId => 12, ContextType => "RT::User"),
+ [], "Nothing with invalid contextid type";
+
+
+
+my $user = RT::Test->load_or_create_user(
+ Name => 'user',
+ Password => 'password',
+ Privileged => 1,
+);
+my $queue = RT::Test->load_or_create_queue( Name => 'CF Test' );
+ok $queue->id, 'found or created queue';
+my $ticket = RT::Test->create_ticket(
+ Queue => $queue->id,
+ Subject => "CF application",
+);
+ok $queue->id, 'created ticket';
+
+$m->logout;
+$m->login('user','password');
+
+is_deeply ac( Context => $queue ), [], 'queue context, no permissions, no result';
+is_deeply ac( Context => $ticket ), [], 'ticket context, no permissions, no result';
+
+ok( RT::Test->set_rights(
+ { Principal => $user, Right => [qw(SeeCustomField)], Object => $queue },
+), 'add queue level CF viewing rights');
+
+my $cfvalues = [ ( map { { value => "cf1 value $_" , label => "cf1 value $_" } } qw(a b c) ) ];
+is_deeply ac( Context => $queue ), $cfvalues, 'queue context, with permissions get result';
+is_deeply ac( Context => $ticket ), $cfvalues, 'ticket context, with permissions get result';
+
+{
+ diag "Switching to non-global CFs";
+ my $globalq = RT::Queue->new( RT->SystemUser );
+ my ($status, $msg) = $cf1->RemoveFromObject( $globalq );
+ ok($status, "Removed CF1 globally: $msg");
+ ($status, $msg) = $cf1->AddToObject( $queue );
+ ok($status, "Added CF1 to queue @{[$queue->id]}: $msg");
+ ($status, $msg) = $cf2->RemoveFromObject( $globalq );
+ ok($status, "Removed CF2 globally: $msg");
+}
+
+is_deeply ac( CF => $cf2->id, Context => $queue ), [], 'queue context, but not applied, get no result';
+is_deeply ac( CF => $cf2->id, Context => $ticket ), [], 'ticket context, but not applied, get no result';
+
+is_deeply ac( Context => $queue ), $cfvalues, 'queue context, applied correctly, get result';
+is_deeply ac( Context => $ticket ), $cfvalues, 'ticket context, applied correctly, get result';
+
+
+
+diag "Ticket-level rights";
+
+ok( RT::Test->set_rights(
+ { Principal => "Owner", Right => [qw(SeeCustomField)], Object => $queue },
+ { Principal => $user, Right => [qw(OwnTicket SeeTicket)], Object => RT->System },
+), 'add owner level CF viewing rights');
+
+is_deeply ac( Context => $queue ), [], 'queue context, but not owner';
+is_deeply ac( Context => $ticket ), [], 'ticket context, but not owner';
+
+my ($status, $msg) = $ticket->SetOwner( $user->id );
+ok( $status, "Set owner to user: $msg" );
+
+is_deeply ac( Context => $queue ), [], 'queue context is not enough';
+is_deeply ac( Context => $ticket ), $cfvalues, 'ticket context, get values';
+
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+sub set_fails {
+ my $col = shift;
+ my $obj = shift;
+ my $to = ref $_[0] ? +shift->Id : shift;
+ my $from = $obj->$col;
+ my $meth = "Set$col";
+
+ my ($ok, $msg) = $obj->$meth($to);
+ ok !$ok, "$meth denied: $msg";
+ is $obj->$col, $from, "$col left alone";
+}
+
+sub set_ok {
+ my $col = shift;
+ my $obj = shift;
+ my $to = ref $_[0] ? +shift->Id : shift;
+ my $from = $obj->$col;
+ my $meth = "Set$col";
+
+ my ($ok, $msg) = $obj->$meth($to);
+ ok $ok, "$meth allowed: $msg";
+ is $obj->$col, $to, "$col updated";
+}
+
+my $qa = RT::Test->load_or_create_queue( Name => 'Queue A' );
+my $qb = RT::Test->load_or_create_queue( Name => 'Queue B' );
+ok $qa->id, "created Queue A";
+ok $qb->id, "created Queue B";
+
+my $user = RT::Test->load_or_create_user( Name => 'testuser' );
+my $cu = RT::CurrentUser->new( $user );
+ok $user->id, "created testuser";
+
+diag "ModifyScrips";
+{
+ my $scrip = RT::Scrip->new( RT->SystemUser );
+ my ($scrip_id, $msg) = $scrip->Create(
+ Description => 'Testing',
+ Queue => $qa->Id,
+ ScripCondition => 'User Defined',
+ ScripAction => 'User Defined',
+ Template => 'Blank',
+ CustomIsApplicableCode => 'if ($self->TicketObj->Subject =~ /fire/) { return (1);} else { return(0)}',
+ CustomPrepareCode => '1;',
+ CustomCommitCode => 'warn "scrip fired!";',
+ );
+ ok $scrip_id, $msg;
+
+ RT::Test->set_rights(
+ { Principal => $user, Right => 'ShowScrips' },
+ { Principal => $user, Right => 'ModifyScrips', Object => $qa },
+ );
+
+ $scrip = RT::Scrip->new( $cu );
+ $scrip->Load( $scrip_id );
+ ok $scrip->id, "loaded scrip as test user";
+ is $scrip->Queue, $qa->Id, 'queue is A';
+
+ ok +($scrip->SetName('Testing ModifyScrips'));
+
+ set_fails( Queue => $scrip => $qb );
+ set_fails( Queue => $scrip => 0 );
+ set_fails( Queue => $scrip => undef );
+ set_fails( Queue => $scrip => '' );
+
+ RT::Test->add_rights( Principal => $user, Right => 'ModifyScrips', Object => $qb );
+
+ set_ok( Queue => $scrip => $qb );
+ set_fails( Queue => $scrip => 0 );
+ set_fails( Queue => $scrip => undef );
+ set_fails( Queue => $scrip => '' );
+
+ RT::Test->add_rights( Principal => $user, Right => 'ModifyScrips' );
+
+ set_ok( Queue => $scrip => 0 );
+
+ set_fails( Template => $scrip => 2 );
+
+ RT::Test->add_rights( Principal => $user, Right => 'ShowTemplate' );
+
+ set_ok( Template => $scrip => 2 );
+ is $scrip->TemplateObj->Name, 'Autoreply', 'template name is right';
+}
+
+diag "ModifyTemplate";
+{
+ RT::Test->set_rights(
+ { Principal => $user, Right => 'ShowTemplate' },
+ { Principal => $user, Right => 'ModifyTemplate', Object => $qa },
+ );
+
+ my $template = RT::Template->new( RT->SystemUser );
+ my ($id, $msg) = $template->Create(
+ Queue => $qa->Id,
+ Name => 'Testing',
+ Type => 'Perl',
+ Content => "\n\nThis is a test template.\n",
+ );
+ ok $id, $msg;
+
+ $template = RT::Template->new( $cu );
+ $template->Load( $id );
+ ok $template->id, "loaded template as test user";
+ is $template->Queue, $qa->Id, 'queue is A';
+
+ ok +($template->SetName('Testing ModifyTemplate'));
+
+ set_fails( Queue => $template => $qb );
+ set_fails( Queue => $template => 0 );
+
+ RT::Test->add_rights( Principal => $user, Right => 'ModifyTemplate', Object => $qb );
+
+ set_ok( Queue => $template => $qb );
+ set_fails( Queue => $template => 0 );
+
+ RT::Test->add_rights( Principal => $user, Right => 'ModifyTemplate' );
+
+ set_ok( Queue => $template => 0 );
+}
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+# A privileged user, but with no privs
+my $bad = RT::Test->load_or_create_user(
+ Name => 'testing',
+ EmailAddress => 'test@example.com',
+ Password => 'password',
+);
+ok( $bad, "Got a user object back" );
+ok( $bad->id, "Successfully created a user" );
+
+
+# A ticket CF
+my $obj = RT::Test->load_or_create_custom_field(
+ Name => "Private CF",
+ Type => "Freeform",
+ Queue => 0,
+);
+
+my ($t) = RT::Test->create_tickets( {},
+ { Subject => 'Testing' }
+);
+ok($t->id, "Created a ticket");
+
+# Add a txn on it
+my ($cfid) = $t->AddCustomFieldValue(
+ Field => $obj->Id,
+ Value => "hidden-value"
+);
+ok($cfid, "Got CF id $cfid");
+my $update_id = $t->Transactions->Last->Id;
+
+# Somebody else shouldn't be able to see the old and new values
+my ($base, $m) = RT::Test->started_ok;
+$m->post_ok("$base/REST/1.0/transaction/$update_id", [
+ user => 'testing',
+ pass => 'password',
+ format => 'l',
+]);
+$m->content_lacks("hidden-value");
+
+# Make a transaction on a user
+my $root = RT::Test->load_or_create_user( Name => "root" );
+$root->SetHomePhone("hidden-value");
+$update_id = $root->Transactions->Last->Id;
+
+# Which should also be hidden from random privileged users
+$m->post_ok("$base/REST/1.0/transaction/$update_id", [
+ user => 'testing',
+ pass => 'password',
+ format => 'l',
+]);
+$m->content_lacks("hidden-value");
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+RT->Config->Set( MailCommand => 'sendmailpipe' );
+RT->Config->Set( VERPPrefix => "verp-" );
+RT->Config->Set( VERPDomain => "example.com" );
+
+# Ensure that the fake sendmail knows where to write to
+$ENV{RT_MAILLOGFILE} = RT::Test->temp_directory . "/sendmailpipe.log";
+my $fake = File::Spec->rel2abs( File::Spec->catfile(
+ 't', 'security', 'fake-sendmail' ) );
+RT->Config->Set( SendmailPath => $fake);
+
+ok(
+ RT::Test->set_rights(
+ { Principal => 'Everyone', Right => [qw/CreateTicket/] },
+ ),
+ 'set rights'
+);
+
+my $bad = RT::Test->load_or_create_user(
+ EmailAddress => 'danger-$USER@example.com',
+);
+ok( $bad, "Got a user object back" );
+ok( $bad->id, "Successfully created a user" );
+
+my $current_user = RT::CurrentUser->new(RT->SystemUser);
+my ($id, $msg) = $current_user->Load($bad->Id);
+ok( $id, "Loaded the user successfully" );
+
+my $ticket = RT::Ticket->new( $current_user );
+($id, $msg) = $ticket->Create(
+ Requestor => $bad->Id,
+ Subject => "Danger, Will Robinson!",
+ Queue => "General"
+);
+ok( $id, "Created a ticket: $msg" );
+
+open(LOG, "<", $ENV{RT_MAILLOGFILE}) or die "Can't open log file: $!";
+while (my $line = <LOG>) {
+ next unless $line =~ /^-f/;
+ like($line, qr/\$USER/, "Contains uninterpolated \$USER");
+}
+close(LOG);
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+plan skip_all => 'valid SQL only on mysql'
+ unless RT->Config->Get('DatabaseType') eq 'mysql';
+
+my ($base, $m) = RT::Test->started_ok;
+ok $m->login, "logged in";
+
+my $t = RT::Ticket->new( RT->SystemUser );
+$t->Create(
+ Queue => 1,
+ Subject => 'seed',
+);
+ok $t->id, 'created seed ticket';
+
+my $root = RT::User->new( RT->SystemUser );
+$root->Load('root');
+my $password = $root->__Value('Password');
+ok $password, 'pulled hashed password from db';
+
+my $sql = q[1 union select 1+id as id, 1+id as EffectiveId, 1 as Queue, 'ticket' as Type, 0 as IssueStatement, 0 as Resolution, 12 as Owner, Password as Subject, 0 as InitialPriority, 0 as FinalPriority, 0 as Priority, 0 as TimeEstimated, 0 as TimeWorked, Name as Status, 0 as TimeLeft, null as Told, null as Starts, null as Started, null as Due, null as Resolved, 0 as LastUpdatedBy, null as LastUpdated, 6 as Creator, null as Created, 0 as Disabled from Users];
+RT::Interface::Web::EscapeURI(\$sql);
+
+$m->get_ok("$base/Search/Results.html?Format=id,Subject,Status;Query=id%3E0;OrderBy=|;Rows=$sql");
+$m->content_lacks($password, "our password hash doesn't show up!");
+$m->warning_like(qr/isn't numeric/);
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my ($base, $m) = RT::Test->started_ok;
+
+my $user = RT::Test->load_or_create_user(
+ Name => 'user',
+ Password => 'password',
+ Privileged => 1,
+);
+
+ok $user->id, 'created user';
+
+ok(
+ RT::Test->set_rights(
+ { Principal => 'privileged', Right => [qw(ModifySelf ShowTicket)] },
+ ),
+ "granted ModifySelf to privileged"
+);
+
+my $ticket = RT::Test->create_ticket(
+ Queue => 'General',
+ Subject => 'testing',
+);
+
+ok $ticket->id, 'created ticket';
+
+$m->login('user');
+$m->get_ok("$base/Prefs/Other.html");
+my $format = 'Formatters';
+$m->submit_form_ok({
+ form_name => 'ModifyPreferences',
+ fields => {
+ DateTimeFormat => $format,
+ },
+ button => 'Update',
+}, 'update prefs');
+is $user->Preferences(RT->System, {})->{DateTimeFormat}, $format, 'set preference';
+
+$m->no_warnings_ok;
+$m->get_ok("$base/Ticket/Display.html?id=" . $ticket->id);
+$m->next_warning_like(qr/Invalid date formatter.+?\Q$format\E/, 'invalid formatter warning');
+$m->content_lacks($_, "lacks formatter in page") for @RT::Date::FORMATTERS;
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my ($base, $m) = RT::Test->started_ok;
+$m->login;
+
+for my $arg (qw(LeadingLink ShowLinks)) {
+ my $ticket = RT::Test->create_ticket(
+ Queue => 'General',
+ Subject => 'testing',
+ );
+ ok $ticket->id, 'created ticket';
+
+ ok !$ticket->ToldObj->Unix, 'no Told';
+ $m->get_ok("$base/Ticket/Graphs/index.html?$arg=SetTold;id=" . $ticket->id);
+
+ $ticket->Load($ticket->id); # cache busting
+
+ ok !$ticket->ToldObj->Unix, 'still no Told';
+ $m->content_lacks('GotoFirstItem', 'no GotoFirstItem error');
+ $m->content_like(qr|<img[^>]+?src=['"]/Ticket/Graphs/@{[$ticket->id]}|, 'found image element');
+}
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ $ENV{RT_TEST_WEB_HANDLER} = 'inline';
+}
+
+use RT::Test tests => undef;
+use Test::Warn;
+
+my ($base, $m) = RT::Test->started_ok;
+
+$m->login;
+$m->content_like(qr/RT at a glance/i, 'homepage');
+
+warning_like {
+ ok !RT->InstallMode(1), 'install mode failed to turn on';
+} qr/tried to turn on InstallMode/;
+
+$m->reload;
+$m->content_like(qr/RT at a glance/i, 'still homepage');
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my $root = RT::CurrentUser->new('root');
+my ($ok, $msg) = $root->UserObj->SetLang('en-us');
+ok $ok, $msg;
+
+my $year = (localtime time)[5] + 1900;
+my $date = RT::Date->new( $root );
+$date->SetToNow;
+
+like $date->AsString( Format => 'LocalizedDateTime' ),
+ qr/\Q$year\E/, 'contains full year';
+
+unlike $date->AsString( Format => 'LocalizedDateTime', DateFormat => 'date_format_short' ),
+ qr/\Q$year\E/, 'lacks full year';
+
+eval {
+ $date->AsString( Format => 'LocalizedDateTime', DateFormat => 'bogus::format' );
+};
+ok !$@, "didn't die with bogus DateFormat";
+
+eval {
+ $date->AsString( Format => 'LocalizedDateTime', TimeFormat => 'bogus::format' );
+};
+ok !$@, "didn't die with bogus TimeFormat";
+
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my ($base, $m) = RT::Test->started_ok;
+
+my $user = RT::Test->load_or_create_user(
+ Name => 'ausername',
+ EmailAddress => 'user@example.com',
+ Password => 'password',
+ Privileged => 1,
+);
+
+ok $user->id, 'created user';
+
+ok(
+ RT::Test->set_rights(
+ { Principal => 'privileged', Right => [qw(ModifySelf ShowTicket)] },
+ ),
+ "granted ModifySelf to privileged"
+);
+
+$m->login('ausername');
+
+{
+ $m->get_ok("$base/Prefs/Other.html");
+ my $style = '../css/base';
+ $m->submit_form_ok({
+ with_fields => {
+ WebDefaultStylesheet => $style,
+ },
+ button => 'Update',
+ }, 'update prefs');
+ is(RT->Config->Get('WebDefaultStylesheet', $user), $style, 'set preference');
+
+ SKIP: {
+ skip "RT::User->Stylesheet wasn't backported", 1 unless $user->can("Stylesheet");
+ is $user->Stylesheet, RT->Config->Get('WebDefaultStylesheet'), '$user->Stylesheet is the default';
+ }
+
+ $m->get_ok($base);
+ $m->content_unlike(qr/<link.+?\Q$style\E/, "lack .. path in page <link>");
+ $m->content_contains( RT->Config->Get('WebDefaultStylesheet') );
+}
+
+{
+ $m->get_ok("$base/Prefs/Other.html");
+ my $format = '/../../m/_elements/full_site_link';
+ $m->submit_form_ok({
+ form_name => 'ModifyPreferences',
+ fields => {
+ UsernameFormat => $format,
+ },
+ button => 'Update',
+ }, 'update prefs');
+ $m->content_contains('saved');
+
+ my $ticket = RT::Test->create_ticket(
+ Queue => 'General',
+ Subject => 'test ticket',
+ Requestor => 'user@example.com',
+ );
+ ok $ticket->id, 'created ticket';
+ $m->get_ok($base . "/Ticket/Display.html?id=" . $ticket->id);
+ $m->content_lacks('NotMobile', "lacks NotMobile");
+ $m->next_warning_like(qr/UsernameFormat/, 'caught UsernameFormat warning');
+}
+
+{
+ $m->get_ok("$base/Helpers/Toggle/ShowRequestor?Status=/../../../Elements/Logo;Requestor=root");
+ $m->content_lacks('logo', "didn't display /Elements/Logo");
+ $m->content_contains('Results.html', "found link to search results");
+}
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my $template = RT::Template->new( RT->SystemUser );
+my ($ok, $msg) = $template->Create(
+ Queue => 0,
+ Name => 'test',
+ Type => 'Simple',
+ Content => <<'.',
+===Create-Ticket: testing
+Queue: General
+Subject: duplicate: { $Tickets{TOP}->Subject }
+.
+);
+ok $ok, $msg;
+
+my $ticket = RT::Test->create_ticket(
+ Queue => 'General',
+ Subject => 'a ticket',
+);
+ok $ticket->id, "created ticket";
+
+for my $type (qw(Simple Perl)) {
+ if ($template->Type ne $type) {
+ my ($ok, $msg) = $template->SetType($type);
+ ok $ok, $msg;
+ }
+
+ require RT::Action::CreateTickets;
+ my $action = RT::Action::CreateTickets->new(
+ CurrentUser => RT->SystemUser,
+ TemplateObj => $template,
+ TicketObj => $ticket,
+ );
+ $action->{TransactionObj} = $ticket->Transactions->First;
+ ok $action->Prepare, 'prepares';
+ ok $action->Commit, 'commits';
+
+ my $new_ticket = RT::Test->last_ticket;
+ ok $new_ticket->id > $ticket->id, 'new ticket';
+
+ if ($type eq 'Perl') {
+ is $new_ticket->Subject, 'duplicate: a ticket', 'interpolated';
+ isnt $new_ticket->Subject, 'duplicate: { $Tickets{TOP}->Subject }', 'interpolated';
+ } else {
+ isnt $new_ticket->Subject, 'duplicate: a ticket', 'not interpolated';
+ is $new_ticket->Subject, 'duplicate: { $Tickets{TOP}->Subject }', 'not interpolated';
+ }
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+die "No \$RT_MAILLOGFILE set in environment"
+ unless $ENV{RT_MAILLOGFILE};
+open LOG, ">", $ENV{RT_MAILLOGFILE}
+ or die "Can't write to $ENV{RT_MAILLOGFILE}: $!";
+
+my $needs_newline;
+for (@ARGV) {
+ if (/^-/) {
+ print LOG "\n" if $needs_newline++;
+ print LOG $_;
+ } else {
+ print LOG " $_";
+ }
+}
+print LOG "\n";
+
+1 while $_ = <STDIN>;
+
+exit 0;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 2;
+
+use constant KIDS => 50;
+
+my $id;
+
+{
+ my $t = RT::Ticket->new( RT->SystemUser );
+ ($id) = $t->Create(
+ Queue => "General",
+ Subject => "Race $$",
+ );
+}
+
+diag "Created ticket $id";
+RT->DatabaseHandle->Disconnect;
+
+my @kids;
+for (1..KIDS) {
+ if (my $pid = fork()) {
+ push @kids, $pid;
+ next;
+ }
+
+ # In the kid, load up the ticket and correspond
+ RT->ConnectToDatabase;
+ my $t = RT::Ticket->new( RT->SystemUser );
+ $t->Load( $id );
+ $t->Correspond( Content => "Correspondence from PID $$" );
+ undef $t;
+ exit 0;
+}
+
+
+diag "Forked @kids";
+waitpid $_, 0 for @kids;
+diag "All kids finished corresponding";
+
+RT->ConnectToDatabase;
+my $t = RT::Ticket->new( RT->SystemUser );
+$t->Load($id);
+my $txns = $t->Transactions;
+$txns->Limit( FIELD => 'Type', VALUE => 'Status' );
+is($txns->Count, 1, "Only one transaction change recorded" );
+
+$txns = $t->Transactions;
+$txns->Limit( FIELD => 'Type', VALUE => 'Correspond' );
+is($txns->Count, KIDS, "But all correspondences were recorded" );
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test nodata => 1, tests => 34;
+use RT::Ticket;
+
+my $qa = RT::Test->load_or_create_queue( Name => 'Queue A' );
+ok $qa && $qa->id, 'loaded or created queue';
+
+my $qb = RT::Test->load_or_create_queue( Name => 'Queue B' );
+ok $qb && $qb->id, 'loaded or created queue';
+
+my @tickets = RT::Test->create_tickets(
+ {},
+ { Queue => $qa->id, Subject => 'a1', },
+ { Queue => $qa->id, Subject => 'a2', },
+ { Queue => $qb->id, Subject => 'b1', },
+ { Queue => $qb->id, Subject => 'b2', },
+);
+
+run_tests( \@tickets,
+ 'Queue = "Queue A"' => { a1 => 1, a2 => 1, b1 => 0, b2 => 0 },
+ 'Queue = '. $qa->id => { a1 => 1, a2 => 1, b1 => 0, b2 => 0 },
+ 'Queue != "Queue A"' => { a1 => 0, a2 => 0, b1 => 1, b2 => 1 },
+ 'Queue != '. $qa->id => { a1 => 0, a2 => 0, b1 => 1, b2 => 1 },
+
+ 'Queue = "Queue B"' => { a1 => 0, a2 => 0, b1 => 1, b2 => 1 },
+ 'Queue = '. $qb->id => { a1 => 0, a2 => 0, b1 => 1, b2 => 1 },
+ 'Queue != "Queue B"' => { a1 => 1, a2 => 1, b1 => 0, b2 => 0 },
+ 'Queue != '. $qb->id => { a1 => 1, a2 => 1, b1 => 0, b2 => 0 },
+
+ 'Queue = "Bad Queue"' => { a1 => 0, a2 => 0, b1 => 0, b2 => 0 },
+ 'Queue != "Bad Queue"' => { a1 => 1, a2 => 1, b1 => 1, b2 => 1 },
+);
+
+sub run_tests {
+ my @tickets = @{ shift() };
+ my %test = @_;
+ my $query_prefix = join ' OR ', map 'id = '. $_->id, @tickets;
+ foreach my $key ( sort keys %test ) {
+ my $tix = RT::Tickets->new(RT->SystemUser);
+ $tix->FromSQL( "( $query_prefix ) AND ( $key )" );
+
+ my $error = 0;
+
+ my $count = 0;
+ $count++ foreach grep $_, values %{ $test{$key} };
+ is($tix->Count, $count, "found correct number of ticket(s) by '$key'") or $error = 1;
+
+ my $good_tickets = 1;
+ while ( my $ticket = $tix->Next ) {
+ next if $test{$key}->{ $ticket->Subject };
+ diag $ticket->Subject ." ticket has been found when it's not expected";
+ $good_tickets = 0;
+ }
+ ok( $good_tickets, "all tickets are good with '$key'" ) or $error = 1;
+
+ diag "Wrong SQL query for '$key':". $tix->BuildSelectQuery if $error;
+ }
+}
--- /dev/null
+use strict;
+use warnings;
+use RT::Test tests => 'no_declare';
+
+my ($url, $m) = RT::Test->started_ok;
+
+ok $m->login, "Logged in";
+
+# We test two ticket creation paths since one historically doesn't update the
+# session (quick create) and the other does.
+for my $quick (1, 0) {
+ diag $quick ? "Quick ticket creation" : "Normal ticket creation";
+
+ $m->get_ok("/");
+ $m->submit_form_ok({ form_name => 'CreateTicketInQueue' }, "Create new ticket form")
+ unless $quick;
+ $m->submit_form_ok({
+ with_fields => {
+ Subject => "The Plants",
+ Content => "Please water them.",
+ },
+ }, "Submitted new ticket");
+
+ my $id = RT::Test->last_ticket->id;
+
+ like $m->uri, qr/results=[A-Za-z0-9]{32}/, "URI contains results hash";
+ $m->content_contains("Ticket $id created", "Page contains results message");
+ $m->content_contains("#$id: The Plants") unless $quick;
+
+ diag "Reloading without a referer but with a results hash doesn't trigger the CSRF"; {
+ # Mech's API here sucks. To drop the Referer and simulate a real browser
+ # reload, we need to make a new request which explicitly adds an empty Referer
+ # header (causing it to never be sent) and then deletes the empty Referer
+ # header to let it be automatically managed again.
+ $m->add_header("Referer" => undef);
+ $m->get_ok( $m->uri, "Reloading the results page without a Referer" );
+ $m->delete_header("Referer");
+
+ like $m->uri, qr/results=[A-Za-z0-9]{32}/, "URI contains results hash";
+ $m->content_lacks("cross-site request forgery", "Skipped the CSRF interstitial")
+ or $m->follow_link_ok({ text => "click here to resume your request" }, "Ignoring CSRF warning");
+ $m->content_lacks("Ticket $id created", "Page lacks results message");
+ $m->content_contains("#$id: The Plants") unless $quick;
+ }
+}
+
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 13;
+
+my $lifecycles = RT->Config->Get('Lifecycles');
+RT->Config->Set( Lifecycles => %{$lifecycles},
+ foo => {
+ initial => ['initial'],
+ active => ['open'],
+ inactive => ['resolved'],
+ }
+);
+
+RT::Lifecycle->FillCache();
+
+my ( $url, $m ) = RT::Test->started_ok;
+ok( $m->login(), 'logged in' );
+
+$m->get_ok( $url . '/Admin/Queues/Modify.html?id=1' );
+
+my $form = $m->form_name('ModifyQueue');
+my $lifecycle_input = $form->find_input('Lifecycle');
+is( $lifecycle_input->value, 'default', 'default lifecycle' );
+
+my @lifecycles = sort $lifecycle_input->possible_values;
+is_deeply( \@lifecycles, [qw/approvals default foo/], 'found all lifecycles' );
+
+$m->submit_form();
+$m->content_lacks( 'Lifecycle changed from',
+ 'no message of "Lifecycle changed from"' );
+$m->content_lacks( 'That is already the current value',
+ 'no message of "That is already the current value"' );
+
+$form = $m->form_name('ModifyQueue');
+$m->submit_form( fields => { Lifecycle => 'foo' }, );
+$m->content_contains(
+ 'Lifecycle changed from "default" to "foo"');
+$lifecycle_input = $form->find_input('Lifecycle');
+is( $lifecycle_input->value, 'foo', 'lifecycle is changed to foo' );
+
+$form = $m->form_name('ModifyQueue');
+$m->submit_form( fields => { Lifecycle => 'default' }, );
+$m->content_contains(
+ 'Lifecycle changed from "foo" to "default"');
+$lifecycle_input = $form->find_input('Lifecycle');
+is( $lifecycle_input->value, 'default',
+ 'lifecycle is changed back to default' );
+
use warnings;
use RT::Test tests => 32;
-use Encode;
my ( $baseurl, $m ) = RT::Test->started_ok;
ok $m->login, 'logged in as root';
-use utf8;
-
use File::Spec;
+my $subject = Encode::decode("UTF-8",'标题');
+my $content = Encode::decode("UTF-8",'测试');
+my $filename = Encode::decode("UTF-8",'附件.txt');
+
diag 'test without attachments' if $ENV{TEST_VERBOSE};
{
$m->form_name('TicketModify');
$m->submit_form(
form_number => 3,
- fields => { Subject => '标题', Content => '测试' },
+ fields => { Subject => $subject, Content => $content },
);
$m->content_like( qr/Ticket \d+ created/i, 'created the ticket' );
$m->follow_link_ok( { text => 'with headers' },
'-> /Ticket/Attachment/WithHeaders/...' );
- $m->content_contains( '标题', 'has subject 标题' );
- $m->content_contains( '测试', 'has content 测试' );
+ $m->content_contains( $subject, "has subject $subject" );
+ $m->content_contains( $content, "has content $content" );
my ( $id ) = $m->uri =~ /(\d+)$/;
ok( $id, 'found attachment id' );
ok( $attachment->SetHeader( 'X-RT-Original-Encoding' => 'gbk' ),
'set original encoding to gbk' );
$m->get( $m->uri );
- $m->content_contains( '标题', 'has subject 标题' );
- $m->content_contains( '测试', 'has content 测试' );
+ $m->content_contains( $subject, "has subject $subject" );
+ $m->content_contains( $content, "has content $content" );
}
diag 'test with attachemnts' if $ENV{TEST_VERBOSE};
{
my $file =
- File::Spec->catfile( RT::Test->temp_directory, encode_utf8 '附件.txt' );
+ File::Spec->catfile( RT::Test->temp_directory, Encode::encode("UTF-8",$filename) );
open( my $fh, '>', $file ) or die $!;
binmode $fh, ':utf8';
- print $fh '附件';
+ print $fh $filename;
close $fh;
$m->get_ok( $baseurl . '/Ticket/Create.html?Queue=1' );
$m->form_name('TicketModify');
$m->submit_form(
form_number => 3,
- fields => { Subject => '标题', Content => '测试', Attach => $file },
+ fields => { Subject => $subject, Content => $content, Attach => $file },
);
$m->content_like( qr/Ticket \d+ created/i, 'created the ticket' );
- $m->content_contains( '附件.txt', 'attached filename' );
- $m->content_lacks( encode_utf8 '附件.txt', 'no double encoded attached filename' );
+ $m->content_contains( $filename, 'attached filename' );
+ $m->content_lacks( Encode::encode("UTF-8",$filename), 'no double encoded attached filename' );
$m->follow_link_ok( { text => 'with headers' },
'-> /Ticket/Attachment/WithHeaders/...' );
# subject is in the parent attachment, so there is no 标题
- $m->content_lacks( '标题', 'does not have content 标题' );
- $m->content_contains( '测试', 'has content 测试' );
+ $m->content_lacks( $subject, "does not have content $subject" );
+ $m->content_contains( $content, "has content $content" );
my ( $id ) = $m->uri =~ /(\d+)$/;
ok( $id, 'found attachment id' );
ok( $attachment->SetHeader( 'X-RT-Original-Encoding' => 'gbk' ),
'set original encoding to gbk' );
$m->get( $m->uri );
- $m->content_lacks( '标题', 'does not have content 标题' );
- $m->content_contains( '测试', 'has content 测试' );
+ $m->content_lacks( $subject, "does not have content $subject" );
+ $m->content_contains( $content, "has content $content" );
$m->back;
$m->back;
- $m->follow_link_ok( { text => 'Download 附件.txt' },
+ $m->follow_link_ok( { text => "Download $filename" },
'-> /Ticket/Attachment/...' );
- $m->content_contains( '附件', 'has content 附件' );
+ $m->content_contains( $filename, "has file content $filename" );
( $id ) = $m->uri =~ /(\d+)\D+$/;
ok( $id, 'found attachment id' );
ok( $attachment->SetHeader( 'X-RT-Original-Encoding' => 'gbk' ),
'set original encoding to gbk' );
$m->get( $m->uri );
- $m->content_contains( '附件', 'has content 附件' );
+ $m->content_contains( $filename, "has content $filename" );
unlink $file;
}
use strict;
use warnings;
-use Encode;
use RT::Test tests => 23;
$agent->goto_create_ticket(1);
is ($agent->status, 200, "Loaded Create.html");
$agent->form_name('TicketCreate');
- my $string = Encode::decode_utf8("I18N Web Testing æøå");
+ my $string = Encode::decode("UTF-8","I18N Web Testing æøå");
$agent->field('Subject' => "Ticket with utf8 body");
$agent->field('Content' => $string);
ok($agent->submit, "Created new ticket with $string as Content");
is ($agent->status, 200, "Loaded Create.html");
$agent->form_name('TicketCreate');
- my $string = Encode::decode_utf8("I18N Web Testing æøå");
+ my $string = Encode::decode( "UTF-8","I18N Web Testing æøå");
$agent->field('Subject' => $string);
$agent->field('Content' => "Ticket with utf8 subject");
ok($agent->submit, "Created new ticket with $string as Content");
is_deeply( @warnings, q{Couldn't parse date 'foodate' by Time::ParseDate} );
}
+diag 'retain values when adding attachments';
+{
+ my ( $ticket, $id );
+
+ my $txn_cf = RT::CustomField->new( RT->SystemUser );
+ my ( $ret, $msg ) = $txn_cf->Create(
+ Name => 'test txn cf date',
+ TypeComposite => 'Date-1',
+ LookupType => 'RT::Queue-RT::Ticket-RT::Transaction',
+ );
+ ok( $ret, "created 'txn datetime': $msg" );
+ $txn_cf->AddToObject(RT::Queue->new(RT->SystemUser));
+ my $txn_cfid = $txn_cf->id;
+
+ $m->submit_form(
+ form_name => "CreateTicketInQueue",
+ fields => { Queue => 'General' },
+ );
+ $m->content_contains('test cf date', 'has cf' );
+ $m->content_contains('test txn cf date', 'has txn cf' );
+
+ $m->submit_form_ok(
+ {
+ form_name => "TicketCreate",
+ fields => {
+ Subject => 'test 2015-06-04',
+ Content => 'test',
+ "Object-RT::Ticket--CustomField-$cfid-Values" => '2015-06-04',
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" => '2015-08-15',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'create test ticket'
+ );
+ $m->form_name("TicketCreate");
+ is( $m->value( "Object-RT::Ticket--CustomField-$cfid-Values" ),
+ "2015-06-04", "ticket cf date value still on form" );
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-08-15", "txn cf date date value still on form" );
+
+ $m->submit_form();
+ ok( ($id) = $m->content =~ /Ticket (\d+) created/, "created ticket $id" );
+
+ $m->follow_link_ok( {text => 'Reply'} );
+ $m->title_like( qr/Update/ );
+ $m->content_contains('test txn cf date', 'has txn cf');
+ $m->submit_form_ok(
+ {
+ form_name => "TicketUpdate",
+ fields => {
+ Content => 'test',
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" => '2015-09-16',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'Update test ticket'
+ );
+ $m->form_name("TicketUpdate");
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-09-16", "txn date value still on form" );
+
+ $m->follow_link_ok( {text => 'Jumbo'} );
+ $m->title_like( qr/Jumbo/ );
+
+ $m->submit_form_ok(
+ {
+ form_name => "TicketModifyAll",
+ fields => {
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" =>
+ '2015-12-16',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'jumbo form'
+ );
+
+ $m->form_name("TicketModifyAll");
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-12-16", "txn date value still on form" );
+}
+
done_testing;
is_deeply( @warnings, q{Couldn't parse date 'foodate' by Time::ParseDate} );
}
+diag 'retain values when adding attachments';
+{
+ my ( $ticket, $id );
+
+ my $txn_cf = RT::CustomField->new( RT->SystemUser );
+ my ( $ret, $msg ) = $txn_cf->Create(
+ Name => 'test txn cf datetime',
+ TypeComposite => 'DateTime-1',
+ LookupType => 'RT::Queue-RT::Ticket-RT::Transaction',
+ );
+ ok( $ret, "created 'txn datetime': $msg" );
+ $txn_cf->AddToObject(RT::Queue->new(RT->SystemUser));
+ my $txn_cfid = $txn_cf->id;
+
+ $m->submit_form(
+ form_name => "CreateTicketInQueue",
+ fields => { Queue => 'General' },
+ );
+ $m->content_contains('test cf datetime', 'has cf' );
+ $m->content_contains('test txn cf datetime', 'has txn cf' );
+
+ $m->submit_form_ok(
+ {
+ form_name => "TicketCreate",
+ fields => {
+ Subject => 'test 2015-06-04',
+ Content => 'test',
+ "Object-RT::Ticket--CustomField-$cfid-Values" => '2015-06-04 08:30:00',
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" => '2015-08-15 12:30:30',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'Create test ticket'
+ );
+ $m->form_name("TicketCreate");
+ is( $m->value( "Object-RT::Ticket--CustomField-$cfid-Values" ),
+ "2015-06-04 08:30:00", "ticket cf date value still on form" );
+ $m->content_contains( "Jun 04 08:30:00 2015", 'date in parens' );
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-08-15 12:30:30", "txn cf date date value still on form" );
+ $m->content_contains( "Aug 15 12:30:30 2015", 'date in parens' );
+
+ $m->submit_form();
+ ok( ($id) = $m->content =~ /Ticket (\d+) created/, "Created ticket $id" );
+
+ $m->follow_link_ok( {text => 'Reply'} );
+ $m->title_like( qr/Update/ );
+ $m->content_contains('test txn cf date', 'has txn cf');
+ $m->submit_form_ok(
+ {
+ form_name => "TicketUpdate",
+ fields => {
+ Content => 'test',
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" => '2015-09-16 09:30:40',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'Update test ticket'
+ );
+ $m->form_name("TicketUpdate");
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-09-16 09:30:40", "Date value still on form" );
+ $m->content_contains( "Sep 16 09:30:40 2015", 'date in parens' );
+
+ $m->follow_link_ok( {text => 'Jumbo'} );
+ $m->title_like( qr/Jumbo/ );
+
+ $m->submit_form_ok(
+ {
+ form_name => "TicketModifyAll",
+ fields => {
+ "Object-RT::Transaction--CustomField-$txn_cfid-Values" =>
+ '2015-12-16 03:00:00',
+ },
+ button => 'AddMoreAttach',
+ },
+ 'jumbo form'
+ );
+ $m->save_content('/tmp/x.html');
+
+ $m->form_name("TicketModifyAll");
+ is( $m->value( "Object-RT::Transaction--CustomField-$txn_cfid-Values" ),
+ "2015-12-16 03:00:00", "txn date value still on form" );
+ $m->content_contains( "Dec 16 03:00:00 2015", 'date in parens' );
+}
+
sub is_results_number {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $fields = shift;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 8;
+
+use constant VALUES_CLASS => 'RT::CustomFieldValues::Groups';
+RT->Config->Set(CustomFieldValuesSources => VALUES_CLASS);
+
+my ($baseurl, $m) = RT::Test->started_ok;
+ok $m->login, 'logged in as root';
+
+my $cf_name = 'test values class';
+
+my $cfid;
+diag "Create a CF";
+{
+ $m->follow_link( id => 'tools-config-custom-fields-create');
+ $m->submit_form(
+ form_name => "ModifyCustomField",
+ fields => {
+ Name => $cf_name,
+ TypeComposite => 'Select-1',
+ LookupType => 'RT::Queue-RT::Ticket',
+ },
+ );
+ $m->content_contains('Object created', 'created Select-1' );
+ $cfid = $m->form_name('ModifyCustomField')->value('id');
+ ok $cfid, "found id of the CF in the form, it's #$cfid";
+}
+
+diag "change to external values class";
+{
+ $m->submit_form(
+ form_name => "ModifyCustomField",
+ fields => { ValuesClass => 'RT::CustomFieldValues::Groups', },
+ button => 'Update',
+ );
+ $m->content_contains(
+ "Field values source changed from 'RT::CustomFieldValues' to 'RT::CustomFieldValues::Groups'",
+ 'changed to external values class' );
+}
+
+diag "change to internal values class";
+{
+ $m->submit_form(
+ form_name => "ModifyCustomField",
+ fields => { ValuesClass => 'RT::CustomFieldValues', },
+ button => 'Update',
+ );
+ $m->content_contains(
+ "Field values source changed from 'RT::CustomFieldValues::Groups' to 'RT::CustomFieldValues'",
+ 'changed to internal values class' );
+}
+
--- /dev/null
+use strict;
+use warnings;
+use Test::Expect;
+use RT::Test tests => 100, actual_server => 1;
+my ( $baseurl, $m ) = RT::Test->started_ok;
+
+my $rt_tool_path = "$RT::BinPath/rt";
+
+$ENV{'RTUSER'} = 'root';
+$ENV{'RTPASSWD'} = 'password';
+$ENV{'RTSERVER'} = RT->Config->Get('WebBaseURL');
+$ENV{'RTDEBUG'} = '1';
+$ENV{'RTCONFIG'} = '/dev/null';
+
+my @cfs = (
+ 'foo=bar', 'foo.bar', 'foo:bar', 'foo bar',
+ 'foo{bar}', 'foo-bar', 'foo()bar',
+);
+for my $name (@cfs) {
+ RT::Test->load_or_create_custom_field(
+ Name => $name,
+ Type => 'Freeform',
+ MaxValues => 1,
+ Queue => 0,
+ );
+}
+
+expect_run(
+ command => "$rt_tool_path shell",
+ prompt => 'rt> ',
+ quit => 'quit',
+);
+
+# create a ticket
+for my $name (@cfs) {
+ expect_send(
+qq{create -t ticket set subject='test cf $name' 'CF.{$name}=foo:b a.r=baz'},
+ "creating a ticket for cf $name"
+ );
+
+ expect_handle->before() =~ /Ticket (\d+) created/;
+ my $ticket_id = $1;
+
+ expect_send( "show ticket/$ticket_id -f 'CF.{$name}'",
+ 'checking new value' );
+ expect_like( qr/CF\.{\Q$name\E}: foo:b a\.r=baz/i, 'verified change' );
+
+ expect_send( "edit ticket/$ticket_id set 'CF.{$name}=bar'",
+ "changing cf $name to bar" );
+ expect_like( qr/Ticket $ticket_id updated/, 'changed cf' );
+ expect_send( "show ticket/$ticket_id -f 'CF.{$name}'",
+ 'checking new value' );
+ expect_like( qr/CF\.{\Q$name\E}: bar/i, 'verified change' );
+
+ expect_send(
+qq{create -t ticket set subject='test cf $name' 'CF-$name=foo:b a.r=baz'},
+ "creating a ticket for cf $name"
+ );
+ expect_handle->before() =~ /Ticket (\d+) created/;
+ $ticket_id = $1;
+
+ expect_send( "show ticket/$ticket_id -f 'CF-$name'", 'checking new value' );
+ if ( $name eq 'foo=bar' ) {
+ expect_like( qr/CF\.{\Q$name\E}: $/mi,
+ "can't use = in cf name with old style" );
+ }
+ else {
+ expect_like( qr/CF\.{\Q$name\E}: foo:b a\.r=baz/i, 'verified change' );
+ expect_send( "edit ticket/$ticket_id set 'CF-$name=bar'",
+ "changing cf $name to bar" );
+ expect_like( qr/Ticket $ticket_id updated/, 'changed cf' );
+ expect_send( "show ticket/$ticket_id -f 'CF-$name'",
+ 'checking new value' );
+ expect_like( qr/CF\.{\Q$name\E}: bar/i, 'verified change' );
+ }
+}
+
+my @invalid = ('foo,bar');
+for my $name (@invalid) {
+ expect_send(
+ qq{create -t ticket set subject='test cf $name' 'CF.{$name}=foo'},
+ "creating a ticket for cf $name" );
+ expect_like( qr/You shouldn't specify objects as arguments to create/i,
+ '$name is not a valid cf name' );
+}
+
+expect_quit();
use HTTP::Request::Common;
use HTTP::Cookies;
use LWP;
-use Encode;
my $cookie_jar = HTTP::Cookies->new;
--- /dev/null
+
+use strict;
+use warnings;
+use RT::Test tests => 39;
+
+my ( $url, $m ) = RT::Test->started_ok;
+
+$m->login();
+
+my @links = (
+ '/', '/Ticket/Create.html?Queue=1',
+ '/SelfService/Create.html?Queue=1', '/m/ticket/create?Queue=1'
+);
+
+my $root = RT::Test->load_or_create_user( Name => 'root' );
+ok( $root->id, 'loaded root' );
+is( $root->EmailAddress, 'root@localhost', 'default root email' );
+
+for my $link (@links) {
+ $m->get_ok($link);
+ $m->content_contains( '"root@localhost"', "default email in $link" );
+}
+
+$root->SetEmailAddress('foo@example.com');
+is( $root->EmailAddress, 'foo@example.com', 'changed to foo@example.com' );
+
+for my $link (@links) {
+ $m->get_ok($link);
+ $m->content_lacks( '"root@localhost"', "no default email in $link" );
+ $m->content_contains( '"foo@example.com"', "new email in $link" );
+}
+
+$root->SetEmailAddress('root@localhost');
+is( $root->EmailAddress, 'root@localhost', 'changed back to root@localhost' );
+
+for my $link (@links) {
+ $m->get_ok($link);
+ $m->content_lacks( '"foo@example.com"', "no previous email in $link" );
+ $m->content_contains( '"root@localhost"', "default email in $link" );
+}
+
--- /dev/null
+use strict;
+use warnings;
+
+# trs: I'd write a quick t/web/caching-headers.t file which loops the available
+# endpoints checking for the right headers.
+
+use File::Find;
+
+BEGIN {
+ # Ensure that the test and server processes use the same fixed time.
+ use constant TIME => 1365175699;
+ use Test::MockTime 'set_fixed_time';
+ set_fixed_time(TIME);
+
+ use RT::Test
+ tests => undef,
+ config => "use Test::MockTime 'set_fixed_time'; set_fixed_time(".TIME.");";
+}
+
+my ($base, $m) = RT::Test->started_ok;
+ok $m->login, 'logged in';
+
+my $docroot = join '/', qw(share html);
+
+# find endpoints to loop over
+my @endpoints = ('/NoAuth/css/print.css');
+find({
+ wanted => sub {
+ if ( -f $_ && $_ !~ m|autohandler$| ) {
+ ( my $endpoint = $_ ) =~ s|^$docroot||;
+ push @endpoints, $endpoint;
+ }
+ },
+ no_chdir => 1,
+} => join '/', $docroot => 'Helpers');
+
+my $ticket_id;
+diag "create a ticket via the API";
+{
+ my $ticket = RT::Ticket->new( RT->SystemUser );
+ my ($id, $txn, $msg) = $ticket->Create(
+ Queue => 'General',
+ Subject => 'test ticket',
+ );
+ ok $id, 'created a ticket #'. $id or diag "error: $msg";
+ is $ticket->Subject, 'test ticket', 'correct subject';
+ $ticket_id = $id;
+}
+
+
+my $expected;
+diag "set up expected date headers";
+{
+
+ # expected headers
+ $expected = {
+ Autocomplete => {
+ 'Cache-Control' => 'max-age=120, private',
+ 'Expires' => 'Fri, 5 Apr 2013 15:30:19 GMT',
+ },
+ NoAuth => {
+ 'Cache-Control' => 'max-age=2592000, public',
+ 'Expires' => 'Sun, 5 May 2013 15:28:19 GMT',
+ },
+ default => {
+ 'Cache-Control' => 'no-cache',
+ 'Expires' => 'Fri, 5 Apr 2013 15:28:19 GMT',
+ },
+ };
+
+}
+
+foreach my $endpoint ( @endpoints ) {
+ $m->get_ok( $endpoint . "?id=${ticket_id}&Status=open&Requestor=root" );
+
+ my $header_key = 'default';
+ if ( $endpoint =~ m|Autocomplete| ) {
+ $header_key = 'Autocomplete';
+ } elsif ( $endpoint =~ m|NoAuth| ) {
+ $header_key = 'NoAuth';
+ }
+ my $headers = $expected->{$header_key};
+
+ is(
+ $m->res->header('Cache-Control') => $headers->{'Cache-Control'},
+ 'got expected Cache-Control header'
+ );
+
+ is(
+ $m->res->header('Expires') => $headers->{'Expires'},
+ 'got expected Expires header'
+ );
+}
+
+undef $m;
+done_testing;
use strict;
use warnings;
-use RT::Test tests => 19;
-use Encode;
+use RT::Test tests => undef;
my ( $baseurl, $m ) = RT::Test->started_ok;
ok $m->login, 'logged in as root';
-use utf8;
-
diag('make Autoreply template a html one and add utf8 chars')
if $ENV{TEST_VERBOSE};
+my $template = Encode::decode("UTF-8", "你好 éèà€");
+my $subject = Encode::decode("UTF-8", "标题");
+my $content = Encode::decode("UTF-8", "测试");
{
$m->follow_link_ok( { id => 'tools-config-global-templates' }, '-> Templates' );
$m->follow_link_ok( { text => 'Autoreply' }, '-> Autoreply' );
$m->submit_form(
form_name => 'ModifyTemplate',
fields => {
- Content => <<'EOF',
-Subject: AutoReply: {$Ticket->Subject}
+ Content => <<EOF,
+Subject: AutoReply: {\$Ticket->Subject}
Content-Type: text/html
-你好 éèà€
-{$Ticket->Subject}
+$template
+{\$Ticket->Subject}
-------------------------------------------------------------------------
-{$Transaction->Content()}
+{\$Transaction->Content()}
EOF
},
);
$m->content_like( qr/Content updated/, 'content is changed' );
- $m->content_contains( '你好', 'content is really updated' );
+ $m->content_contains( $template, 'content is really updated' );
}
diag('create a ticket to see the autoreply mail') if $ENV{TEST_VERBOSE};
$m->submit_form(
form_name => 'TicketCreate',
- fields => { Subject => '标题', Content => '<h1>测试</h1>',
+ fields => { Subject => $subject, Content => "<h1>$content</h1>",
ContentType => 'text/html' },
);
$m->content_like( qr/Ticket \d+ created/i, 'created the ticket' );
$m->follow_link( text => 'Show' );
- $m->content_contains( '你好', 'html has 你好' );
- $m->content_contains( 'éèà€', 'html has éèà€' );
- $m->content_contains( '标题',
- 'html has ticket subject 标题' );
- $m->content_contains( '<h1>测试</h1>',
- 'html has ticket html content 测试' );
+ $m->content_contains( $template, "html has $template" );
+ $m->content_contains( $subject,
+ "html has ticket subject $subject" );
+ $m->content_contains( "<h1>$content</h1>",
+ "html has ticket html content $content" );
}
diag('test real mail outgoing') if $ENV{TEST_VERBOSE};
# $mail is utf8 encoded
my ($mail) = RT::Test->fetch_caught_mails;
- $mail = decode_utf8 $mail;
- like( $mail, qr/你好.*你好/s, 'mail has éèà€' );
- like( $mail, qr/éèà€.*éèà€/s, 'mail has éèà€' );
- like( $mail, qr/标题.*标题/s, 'mail has ticket subject 标题' );
- like( $mail, qr/测试.*测试/s, 'mail has ticket content 测试' );
- like( $mail, qr!<h1>测试</h1>!, 'mail has ticket html content 测试' );
+ $mail = Encode::decode("UTF-8", $mail );
+ like( $mail, qr/$template.*$template/s, 'mail has template content $template twice' );
+ like( $mail, qr/$subject.*$subject/s, 'mail has ticket subject $sujbect twice' );
+ like( $mail, qr/$content.*$content/s, 'mail has ticket content $content twice' );
+ like( $mail, qr!<h1>$content</h1>!, 'mail has ticket html content <h1>$content</h1>' );
}
+undef $m;
+done_testing;
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => 34;
+
+my ( $baseurl, $m ) = RT::Test->started_ok;
+
+my $ticket = RT::Test->create_ticket(
+ Subject => 'ticket_foo',
+ Queue => 'General',
+);
+
+my ( $user, $pass ) = ( 'root', 'password' );
+
+diag "normal login";
+{
+ $m->get($baseurl);
+ $m->title_is('Login');
+ is( $m->uri, $baseurl, "right url" );
+
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => 'wrong pass',
+ }
+ );
+ $m->content_contains( "Your username or password is incorrect",
+ 'login error message' );
+ $m->warning_like( qr/FAILED LOGIN for root/,
+ "got failed login warning" );
+
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => $pass,
+ }
+ );
+
+ $m->title_is( 'RT at a glance', 'logged in' );
+
+ $m->follow_link_ok( { text => 'Logout' }, 'follow logout' );
+ $m->title_is( 'Logout', 'logout' );
+}
+
+diag "tangent login";
+
+{
+ $m->get( $baseurl . '/Ticket/Display.html?id=1' );
+ $m->title_is('Login');
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => $pass,
+ }
+ );
+ like( $m->uri, qr{/Ticket/Display\.html}, 'normal ticket page' );
+ $m->follow_link_ok( { text => 'Logout' }, 'follow logout' );
+}
+
+diag "mobile login with not mobile client";
+{
+ $m->get( $baseurl . '/m' );
+ is( $m->uri, $baseurl . '/m', "right url" );
+ $m->content_contains( "/m/index.html?NotMobile=1", 'mobile login' );
+
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => 'wrong pass',
+ }
+ );
+ $m->content_contains( "Your username or password is incorrect",
+ 'login error message' );
+ $m->warning_like( qr/FAILED LOGIN for root/,
+ "got failed login warning" );
+
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => $pass,
+ }
+ );
+ like( $m->uri, qr{\Q$baseurl/m\E}, "mobile url" );
+ $m->follow_link_ok( { text => 'Logout' }, 'follow logout' );
+ $m->content_contains( "/m/index.html?NotMobile=1",
+ 'back to mobile login page' );
+ $m->content_lacks( 'Logout', 'really logout' );
+}
+
+
+diag "mobile normal login";
+{
+
+ # default browser in android 2.3.6
+ $m->agent(
+"Mozilla/5.0 (Linux; U; Android 2.3.6; en-us; Nexus One Build/GRK39F) AppleWebKit/533.1 (KHTML, like Gecko) Version/4.0 Mobile Safari/533.1"
+ );
+
+ $m->get($baseurl);
+ is( $m->uri, $baseurl, "right url" );
+ $m->content_contains( "/m/index.html?NotMobile=1", 'mobile login' );
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => $pass,
+ }
+ );
+ is( $m->uri, $baseurl . '/m/', "mobile url" );
+ $m->follow_link_ok( { text => 'Logout' }, 'follow logout' );
+ $m->content_contains( "/m/index.html?NotMobile=1", 'back to mobile login page' );
+ $m->content_lacks( 'Logout', 'really logout' );
+}
+
+diag "mobile tangent login";
+{
+ $m->get( $baseurl . '/Ticket/Display.html?id=1' );
+ $m->content_contains( "/m/index.html?NotMobile=1", 'mobile login' );
+ $m->submit_form(
+ form_id => 'login',
+ fields => {
+ user => $user,
+ pass => $pass,
+ }
+ );
+ like( $m->uri, qr{/m/ticket/show}, 'mobile ticket page' );
+}
+
use warnings;
use RT::Test tests => 8;
-use Encode;
use RT::Ticket;
my ( $url, $m ) = RT::Test->started_ok;
fields => { string => $template, },
button => 'UpdateTickets',
);
- my $content = encode 'utf8', $m->content;
+ my $content = Encode::encode("UTF-8", $m->content);
ok( $content =~ m/申請單 #(\d+) 成功新增於 'General' 表單/, 'message is shown right' );
$ticket_id = $1;
}
button => 'UpdateTickets',
);
- my $content = encode 'utf8', $m->content;
+ my $content = Encode::encode("UTF-8", $m->content);
ok(
$content =~
qr/主題\s*的值從\s*'test message'\s*改為\s*'test message update'/,
use warnings;
use RT::Test tests => 9;
-use utf8;
-
-use Encode;
use RT::Ticket;
my $file = File::Spec->catfile( RT::Test->temp_directory, 'template' );
open my $fh, '>', $file or die $!;
-my $template = <<EOF;
+my $template = Encode::decode("UTF-8",<<EOF);
===Create-Ticket: ticket1
Queue: General
Subject: 标题
ENDOFCONTENT
EOF
-print $fh $template;
+print $fh Encode::encode("UTF-8",$template);
close $fh;
my ( $url, $m ) = RT::Test->started_ok;
button => 'Parse',
);
-$m->content_contains( '这是正文', 'content is parsed right' );
+$m->content_contains( Encode::decode("UTF-8",'这是正文'), 'content is parsed right' );
$m->submit_form(
form_name => 'TicketUpdate',
my $ticket = RT::Ticket->new( RT->SystemUser );
$ticket->Load( $ticket_id );
-is( $ticket->Subject, '标题', 'subject in $ticket is right' );
+is( $ticket->Subject, Encode::decode("UTF-8",'标题'), 'subject in $ticket is right' );
$m->goto_ticket($ticket_id);
-$m->content_contains( '这是正文',
+$m->content_contains( Encode::decode("UTF-8",'这是正文'),
'content is right in ticket display page' );
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ use Test::More;
+ plan skip_all => "Testing the rt-server init sequence in isolation requires Apache"
+ unless ($ENV{RT_TEST_WEB_HANDLER} || '') =~ /^apache/;
+}
+
+use JSON qw(from_json);
+
+use RT::Test
+ tests => undef,
+ plugins => ["Overlays"];
+
+my ($base, $m) = RT::Test->started_ok;
+
+# Check that the overlay was actually loaded
+$m->get_ok("$base/overlay_loaded");
+is $m->content, "yes", "Plugin's RT/User_Local.pm was loaded";
+
+# Check accessible is correct and doesn't need to be rebuilt from overlay
+$m->get_ok("$base/user_accessible");
+ok $m->content, "Received some content";
+
+my $info = from_json($m->content) || {};
+ok $info->{Comments}{public}, "User.Comments is marked public via overlay";
+
+undef $m;
+done_testing;
use HTTP::Request::Common;
use HTTP::Cookies;
use LWP;
-use Encode;
use RT::Test tests => 70;
my $cookie_jar = HTTP::Cookies->new;
use warnings;
use RT::Test tests => 9;
-use Encode;
-# \x{XX} where XX is less than 255 is not treated as unicode code point
my $subject = Encode::decode('latin1', "Sujet accentu\x{e9}");
my $text = Encode::decode('latin1', "Contenu accentu\x{e9}");
$m->post("$baseurl/REST/1.0/ticket/new", [
user => 'root',
pass => 'password',
-# error message from HTTP::Message: content must be bytes
- content => Encode::encode_utf8($content),
+ content => Encode::encode( "UTF-8", $content),
], Content_Type => 'form-data' );
my ($id) = $m->content =~ /Ticket (\d+) created/;
--- /dev/null
+use strict;
+use warnings;
+use RT::Test tests => 11;
+
+RT->Config->Set( UseSideBySideLayout => 0 );
+
+my $root = RT::Test->load_or_create_user( Name => 'root', );
+my ( $status, $msg ) = $root->SetPreferences(
+ $RT::System => {
+ %{ $root->Preferences($RT::System) || {} }, 'UseSideBySideLayout' => 1
+ }
+);
+ok( $status, 'use side by side layout for root' );
+
+my $user_a = RT::Test->load_or_create_user(
+ Name => 'user_a',
+ Password => 'password',
+);
+ok( $user_a->id, 'created user_a' );
+
+ok(
+ RT::Test->set_rights(
+ {
+ Principal => $user_a,
+ Right => ['CreateTicket']
+ },
+ ),
+ 'granted user_a the right of CreateTicket'
+);
+
+my ( $url, $m ) = RT::Test->started_ok;
+$m->login;
+$m->get_ok( $url . '/Ticket/Create.html?Queue=1', "root's ticket create page" );
+$m->content_like( qr/<body [^>]*class="[^>"]*\bsidebyside\b/,
+ 'found sidebyside css for root' );
+
+my $m_a = RT::Test::Web->new;
+ok $m_a->login( 'user_a', 'password' ), 'logged in as user_a';
+$m_a->get_ok( $url . '/Ticket/Create.html?Queue=1',
+ "user_a's ticket create page" );
+$m_a->content_unlike(
+ qr/<body [^>]*class="[^>"]*\bsidebyside\b/,
+ "didn't find sidebyside class for user_a"
+);
+
use RT::Test tests => 43;
-use Encode;
-
my $ru_test = "\x{442}\x{435}\x{441}\x{442}";
my $ru_support = "\x{43f}\x{43e}\x{434}\x{434}\x{435}\x{440}\x{436}\x{43a}\x{430}";
--- /dev/null
+use strict;
+use warnings;
+
+use RT::Test tests => undef;
+
+my ($base, $m) = RT::Test->started_ok;
+ok $m->login, 'logged in';
+
+my @tickets;
+
+diag "create a ticket via the API";
+{
+ my $ticket = RT::Ticket->new( RT->SystemUser );
+ my ($id, $txn, $msg) = $ticket->Create(
+ Queue => 'General',
+ Subject => Encode::decode("UTF-8",'bad subject‽'),
+ );
+ ok $id, 'created a ticket #'. $id or diag "error: $msg";
+ is $ticket->Subject, Encode::decode("UTF-8",'bad subject‽'), 'correct subject';
+ push @tickets, $id;
+}
+
+diag "create a ticket via the web";
+{
+ $m->submit_form_ok({
+ form_name => "CreateTicketInQueue",
+ fields => { Queue => 1 },
+ }, 'create ticket in Queue');
+ $m->submit_form_ok({
+ with_fields => {
+ Subject => Encode::decode("UTF-8",'bad subject #2‽'),
+ },
+ }, 'create ticket');
+ $m->content_contains(Encode::decode("UTF-8",'bad subject #2‽'), 'correct subject');
+ push @tickets, 2;
+}
+
+diag "create a ticket via the web without a unicode subject";
+{
+ $m->submit_form_ok({
+ with_fields => { Queue => 1 },
+ }, 'create ticket in Queue');
+ $m->submit_form_ok({
+ with_fields => {
+ Subject => 'a fine subject #3',
+ },
+ }, 'create ticket');
+ $m->content_contains('a fine subject #3', 'correct subject');
+ push @tickets, 3;
+}
+
+for my $tid (@tickets) {
+ diag "ticket #$tid";
+ diag "add a reply which adds to the subject, but without an attachment";
+ {
+ $m->goto_ticket($tid);
+ $m->follow_link_ok({ id => 'page-actions-reply' }, "Actions -> Reply");
+ $m->submit_form_ok({
+ with_fields => {
+ UpdateSubject => Encode::decode("UTF-8",'bad subject‽ without attachment'),
+ UpdateContent => 'testing unicode txn subjects',
+ },
+ button => 'SubmitTicket',
+ }, 'submit reply');
+ $m->content_contains(Encode::decode("UTF-8",'bad subject‽ without attachment'), "found txn subject");
+ }
+
+ diag "add a reply which adds to the subject with an attachment";
+ {
+ $m->goto_ticket($tid);
+ $m->follow_link_ok({ id => 'page-actions-reply' }, "Actions -> Reply");
+ $m->submit_form_ok({
+ with_fields => {
+ UpdateSubject => Encode::decode("UTF-8",'bad subject‽ with attachment'),
+ UpdateContent => 'testing unicode txn subjects',
+ Attach => RT::Test::get_relocatable_file('bpslogo.png', '..', 'data'),
+ },
+ button => 'SubmitTicket',
+ }, 'submit reply');
+ $m->content_contains(Encode::decode("UTF-8",'bad subject‽ with attachment'), "found txn subject");
+ }
+}
+
+undef $m;
+done_testing;
use strict;
use warnings;
-use utf8;
use RT::Test tests => undef;
my ( $url, $m ) = RT::Test->started_ok;
$m->submit_form_ok({ with_fields => { Lang => 'ja'} },
"Change to Japanese");
$m->text_contains("Lang changed from (no value) to 'ja'");
-$m->text_contains("実名", "Page content is japanese");
+$m->text_contains(Encode::decode("UTF-8","実名"), "Page content is japanese");
# we only changed one field, and it wasn't the default, so this feedback is
# spurious and annoying
# This message shows up in Japanese
# $m->text_contains("Lang changed from 'ja' to 'en_us'");
-$m->text_contains("Langは「'ja'」から「'en_us'」に変更されました");
+$m->text_contains(Encode::decode("UTF-8","Langは「'ja'」から「'en_us'」に変更されました"));
$m->text_contains("Real Name", "Page content is english");
# Check for a lack of spurious updates
$m->submit_form_ok({ with_fields => { Lang => 'ja'} },
"Back briefly to Japanese");
$m->text_contains("Lang changed from 'en_us' to 'ja'");
-$m->text_contains("実名", "Page content is japanese");
+$m->text_contains(Encode::decode("UTF-8","実名"), "Page content is japanese");
$m->submit_form_ok({ with_fields => { Lang => ''} },
"And set to the default");
-$m->text_contains("Langは「'ja'」から「(値なし)」に変更されました");
+$m->text_contains(Encode::decode("UTF-8","Langは「'ja'」から「(値なし)」に変更されました"));
$m->text_contains("Real Name", "Page content is english");
undef $m;
-
done_testing;
projects / freeside.git / commitdiff