# -*- Mode: perl; indent-tabs-mode: nil -*- # # The contents of this file are subject to the Mozilla Public # License Version 1.1 (the "License"); you may not use this file # except in compliance with the License. You may obtain a copy of # the License at http://www.mozilla.org/MPL/ # # Software distributed under the License is distributed on an "AS # IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or # implied. See the License for the specific language governing # rights and limitations under the License. # # The Original Code is the Bugzilla Bug Tracking System. # # The Initial Developer of the Original Code is Netscape Communications # Corporation. Portions created by Netscape are # Copyright (C) 1998 Netscape Communications Corporation. All # Rights Reserved. # # Contributor(s): Terry Weissman <terry@mozilla.org> # Dan Mosedale <dmose@mozilla.org> # Jake <jake@acutex.net> # Bradley Baetz <bbaetz@cs.mcgill.ca> # Christopher Aillon <christopher@aillon.com> # Contains some global variables and routines used throughout bugzilla. use diagnostics; use strict; # Shut up misguided -w warnings about "used only once". For some reason, # "use vars" chokes on me when I try it here. sub globals_pl_sillyness { my $zz; $zz = @main::SqlStateStack; $zz = @main::chooseone; $zz = $main::contenttypes; $zz = @main::default_column_list; $zz = $main::defaultqueryname; $zz = @main::dontchange; $zz = @main::enterable_products; $zz = %main::keywordsbyname; $zz = @main::legal_bug_status; $zz = @main::legal_components; $zz = @main::legal_keywords; $zz = @main::legal_opsys; $zz = @main::legal_platform; $zz = @main::legal_priority; $zz = @main::legal_product; $zz = @main::legal_severity; $zz = @main::legal_target_milestone; $zz = @main::legal_versions; $zz = @main::milestoneurl; $zz = %main::proddesc; $zz = @main::prodmaxvotes; $zz = $main::superusergroupset; $zz = $main::template; $zz = $main::userid; $zz = $main::vars; } # # Here are the --LOCAL-- variables defined in 'localconfig' that we'll use # here # $::db_host = "localhost"; $::db_port = 3306; $::db_name = "bugs"; $::db_user = "bugs"; $::db_pass = ""; do 'localconfig'; use DBI; use Date::Format; # For time2str(). use Date::Parse; # For str2time(). #use Carp; # for confess use RelationSet; # Use standard Perl libraries for cross-platform file/directory manipulation. use File::Spec; # Some environment variables are not taint safe delete @::ENV{'PATH', 'IFS', 'CDPATH', 'ENV', 'BASH_ENV'}; # Cwd.pm in perl 5.6.1 gives a warning if $::ENV{'PATH'} isn't defined # Set this to '' so that we don't get warnings cluttering the logs on every # system call $::ENV{'PATH'} = ''; # Ignore SIGTERM and SIGPIPE - this prevents DB corruption. If the user closes # their browser window while a script is running, the webserver sends these # signals, and we don't want to die half way through a write. $::SIG{TERM} = 'IGNORE'; $::SIG{PIPE} = 'IGNORE'; # Contains the version string for the current running Bugzilla. $::param{'version'} = '2.15'; $::dontchange = "--do_not_change--"; $::chooseone = "--Choose_one:--"; $::defaultqueryname = "(Default query)"; $::unconfirmedstate = "UNCONFIRMED"; $::dbwritesallowed = 1; # Adding a global variable for the value of the superuser groupset. # Joe Robins, 7/5/00 $::superusergroupset = "9223372036854775807"; #sub die_with_dignity { # my ($err_msg) = @_; # print $err_msg; # confess($err_msg); #} #$::SIG{__DIE__} = \&die_with_dignity; # Some files in the data directory must be world readable iff we don't have # a webserver group. Call this function to do this. sub ChmodDataFile($$) { my ($file, $mask) = @_; my $perm = 0770; if ((stat('data'))[2] & 0002) { $perm = 0777; } $perm = $perm & $mask; chmod $perm,$file; } sub ConnectToDatabase { my ($useshadow) = (@_); if (!defined $::db) { my $name = $::db_name; if ($useshadow && Param("shadowdb") && Param("queryagainstshadowdb")) { $name = Param("shadowdb"); $::dbwritesallowed = 0; } $::db = DBI->connect("DBI:mysql:host=$::db_host;database=$name;port=$::db_port", $::db_user, $::db_pass) || die "Bugzilla is currently broken. Please try again later. " . "If the problem persists, please contact " . Param("maintainer") . ". The error you should quote is: " . $DBI::errstr; } } sub ReconnectToShadowDatabase { if (Param("shadowdb") && Param("queryagainstshadowdb")) { SendSQL("USE " . Param("shadowdb")); $::dbwritesallowed = 0; } } my $shadowchanges = 0; sub SyncAnyPendingShadowChanges { if ($shadowchanges) { my $pid; FORK: { if ($pid = fork) { # create a fork # parent code runs here $shadowchanges = 0; return; } elsif (defined $pid) { # child process code runs here my $redir = ($^O =~ /MSWin32/i) ? "NUL" : "/dev/null"; open STDOUT,">$redir"; open STDERR,">$redir"; exec("./syncshadowdb","--") or die "Unable to exec syncshadowdb: $!"; # the idea was that passing the second parameter tricks it into # using execvp instead of running a shell. Not really necessary since # there are no shell meta-characters, but it passes our tinderbox # test that way. :) http://bugzilla.mozilla.org/show_bug.cgi?id=21253 } elsif ($! =~ /No more process/) { # recoverable fork error, try again in 5 seconds sleep 5; redo FORK; } else { # something weird went wrong die "Can't create background process to run syncshadowdb: $!"; } } } } # This is used to manipulate global state used by SendSQL(), # MoreSQLData() and FetchSQLData(). It provides a way to do another # SQL query without losing any as-yet-unfetched data from an existing # query. Just push the current global state, do your new query and fetch # any data you need from it, then pop the current global state. # @::SQLStateStack = (); sub PushGlobalSQLState() { push @::SQLStateStack, $::currentquery; push @::SQLStateStack, [ @::fetchahead ]; } sub PopGlobalSQLState() { die ("PopGlobalSQLState: stack underflow") if ( $#::SQLStateStack < 1 ); @::fetchahead = @{pop @::SQLStateStack}; $::currentquery = pop @::SQLStateStack; } sub SavedSQLStates() { return ($#::SqlStateStack + 1) / 2; } my $dosqllog = (-e "data/sqllog") && (-w "data/sqllog"); sub SqlLog { if ($dosqllog) { my ($str) = (@_); open(SQLLOGFID, ">>data/sqllog") || die "Can't write to data/sqllog"; if (flock(SQLLOGFID,2)) { # 2 is magic 'exclusive lock' const. # if we're a subquery (ie there's pushed global state around) # indent to indicate the level of subquery-hood # for (my $i = SavedSQLStates() ; $i > 0 ; $i--) { print SQLLOGFID "\t"; } print SQLLOGFID time2str("%D %H:%M:%S $$", time()) . ": $str\n"; } flock(SQLLOGFID,8); # '8' is magic 'unlock' const. close SQLLOGFID; } } # This is from the perlsec page, slightly modifed to remove a warning # From that page: # This function makes use of the fact that the presence of # tainted data anywhere within an expression renders the # entire expression tainted. # Don't ask me how it works... sub is_tainted { return not eval { my $foo = join('',@_), kill 0; 1; }; } sub SendSQL { my ($str, $dontshadow) = (@_); # Don't use DBI's taint stuff yet, because: # a) We don't want out vars to be tainted (yet) # b) We want to know who called SendSQL... # Is there a better way to do b? if (is_tainted($str)) { die "Attempted to send tainted string '$str' to the database"; } my $iswrite = ($str =~ /^(INSERT|REPLACE|UPDATE|DELETE)/i); if ($iswrite && !$::dbwritesallowed) { die "Evil code attempted to write stuff to the shadow database."; } if ($str =~ /^LOCK TABLES/i && $str !~ /shadowlog/ && $::dbwritesallowed) { $str =~ s/^LOCK TABLES/LOCK TABLES shadowlog WRITE, /i; } # If we are shutdown, we don't want to run queries except in special cases if (Param('shutdownhtml')) { if ($0 =~ m:[\\/]((do)?editparams.cgi|syncshadowdb)$:) { $::ignorequery = 0; } else { $::ignorequery = 1; return; } } SqlLog($str); $::currentquery = $::db->prepare($str); if (!$::currentquery->execute) { my $errstr = $::db->errstr; # Cut down the error string to a reasonable.size $errstr = substr($errstr, 0, 2000) . ' ... ' . substr($errstr, -2000) if length($errstr) > 4000; die "$str: " . $errstr; } SqlLog("Done"); if (!$dontshadow && $iswrite && Param("shadowdb")) { my $q = SqlQuote($str); my $insertid; if ($str =~ /^(INSERT|REPLACE)/i) { SendSQL("SELECT LAST_INSERT_ID()"); $insertid = FetchOneColumn(); } SendSQL("INSERT INTO shadowlog (command) VALUES ($q)", 1); if ($insertid) { SendSQL("SET LAST_INSERT_ID = $insertid"); } $shadowchanges++; } } sub MoreSQLData { # $::ignorequery is set in SendSQL if ($::ignorequery) { return 0; } if (defined @::fetchahead) { return 1; } if (@::fetchahead = $::currentquery->fetchrow_array) { return 1; } return 0; } sub FetchSQLData { # $::ignorequery is set in SendSQL if ($::ignorequery) { return; } if (defined @::fetchahead) { my @result = @::fetchahead; undef @::fetchahead; return @result; } return $::currentquery->fetchrow_array; } sub FetchOneColumn { my @row = FetchSQLData(); return $row[0]; } @::default_column_list = ("severity", "priority", "platform", "owner", "status", "resolution", "summary"); sub AppendComment { my ($bugid,$who,$comment) = (@_); $comment =~ s/\r\n/\n/g; # Get rid of windows-style line endings. $comment =~ s/\r/\n/g; # Get rid of mac-style line endings. if ($comment =~ /^\s*$/) { # Nothin' but whitespace. return; } my $whoid = DBNameToIdAndCheck($who); SendSQL("INSERT INTO longdescs (bug_id, who, bug_when, thetext) " . "VALUES($bugid, $whoid, now(), " . SqlQuote($comment) . ")"); SendSQL("UPDATE bugs SET delta_ts = now() WHERE bug_id = $bugid"); } sub GetFieldID { my ($f) = (@_); SendSQL("SELECT fieldid FROM fielddefs WHERE name = " . SqlQuote($f)); my $fieldid = FetchOneColumn(); if (!$fieldid) { my $q = SqlQuote($f); SendSQL("REPLACE INTO fielddefs (name, description) VALUES ($q, $q)"); SendSQL("SELECT LAST_INSERT_ID()"); $fieldid = FetchOneColumn(); } return $fieldid; } sub lsearch { my ($list,$item) = (@_); my $count = 0; foreach my $i (@$list) { if ($i eq $item) { return $count; } $count++; } return -1; } # Generate a string which, when later interpreted by the Perl compiler, will # be the same as the given string. sub PerlQuote { my ($str) = (@_); return SqlQuote($str); # The below was my first attempt, but I think just using SqlQuote makes more # sense... # $result = "'"; # $length = length($str); # for (my $i=0 ; $i<$length ; $i++) { # my $c = substr($str, $i, 1); # if ($c eq "'" || $c eq '\\') { # $result .= '\\'; # } # $result .= $c; # } # $result .= "'"; # return $result; } # Given the name of a global variable, generate Perl code that, if later # executed, would restore the variable to its current value. sub GenerateCode { my ($name) = (@_); my $result = $name . " = "; if ($name =~ /^\$/) { my $value = eval($name); if (ref($value) eq "ARRAY") { $result .= "[" . GenerateArrayCode($value) . "]"; } else { $result .= PerlQuote(eval($name)); } } elsif ($name =~ /^@/) { my @value = eval($name); $result .= "(" . GenerateArrayCode(\@value) . ")"; } elsif ($name =~ '%') { $result = ""; foreach my $k (sort { uc($a) cmp uc($b)} eval("keys $name")) { $result .= GenerateCode("\$" . substr($name, 1) . "{" . PerlQuote($k) . "}"); } return $result; } else { die "Can't do $name -- unacceptable variable type."; } $result .= ";\n"; return $result; } sub GenerateArrayCode { my ($ref) = (@_); my @list; foreach my $i (@$ref) { push @list, PerlQuote($i); } return join(',', @list); } sub GenerateVersionTable { ConnectToDatabase(); SendSQL("select value, program from versions order by value"); my @line; my %varray; my %carray; while (@line = FetchSQLData()) { my ($v,$p1) = (@line); if (!defined $::versions{$p1}) { $::versions{$p1} = []; } push @{$::versions{$p1}}, $v; $varray{$v} = 1; } SendSQL("select value, program from components order by value"); while (@line = FetchSQLData()) { my ($c,$p) = (@line); if (!defined $::components{$p}) { $::components{$p} = []; } my $ref = $::components{$p}; push @$ref, $c; $carray{$c} = 1; } my $dotargetmilestone = 1; # This used to check the param, but there's # enough code that wants to pretend we're using # target milestones, even if they don't get # shown to the user. So we cache all the data # about them anyway. my $mpart = $dotargetmilestone ? ", milestoneurl" : ""; SendSQL("select product, description, votesperuser, disallownew$mpart from products ORDER BY product"); $::anyvotesallowed = 0; while (@line = FetchSQLData()) { my ($p, $d, $votesperuser, $dis, $u) = (@line); $::proddesc{$p} = $d; if (!$dis) { push @::enterable_products, $p; } if ($dotargetmilestone) { $::milestoneurl{$p} = $u; } $::prodmaxvotes{$p} = $votesperuser; if ($votesperuser > 0) { $::anyvotesallowed = 1; } } my $cols = LearnAboutColumns("bugs"); @::log_columns = @{$cols->{"-list-"}}; foreach my $i ("bug_id", "creation_ts", "delta_ts", "lastdiffed") { my $w = lsearch(\@::log_columns, $i); if ($w >= 0) { splice(@::log_columns, $w, 1); } } @::log_columns = (sort(@::log_columns)); @::legal_priority = SplitEnumType($cols->{"priority,type"}); @::legal_severity = SplitEnumType($cols->{"bug_severity,type"}); @::legal_platform = SplitEnumType($cols->{"rep_platform,type"}); @::legal_opsys = SplitEnumType($cols->{"op_sys,type"}); @::legal_bug_status = SplitEnumType($cols->{"bug_status,type"}); @::legal_resolution = SplitEnumType($cols->{"resolution,type"}); # 'settable_resolution' is the list of resolutions that may be set # directly by hand in the bug form. Start with the list of legal # resolutions and remove 'MOVED' and 'DUPLICATE' because setting # bugs to those resolutions requires a special process. # @::settable_resolution = @::legal_resolution; my $w = lsearch(\@::settable_resolution, "DUPLICATE"); if ($w >= 0) { splice(@::settable_resolution, $w, 1); } my $z = lsearch(\@::settable_resolution, "MOVED"); if ($z >= 0) { splice(@::settable_resolution, $z, 1); } my @list = sort { uc($a) cmp uc($b)} keys(%::versions); @::legal_product = @list; my $tmpname = "data/versioncache.$$"; open(FID, ">$tmpname") || die "Can't create $tmpname"; print FID "#\n"; print FID "# DO NOT EDIT!\n"; print FID "# This file is automatically generated at least once every\n"; print FID "# hour by the GenerateVersionTable() sub in globals.pl.\n"; print FID "# Any changes you make will be overwritten.\n"; print FID "#\n"; print FID GenerateCode('@::log_columns'); print FID GenerateCode('%::versions'); foreach my $i (@list) { if (!defined $::components{$i}) { $::components{$i} = []; } } @::legal_versions = sort {uc($a) cmp uc($b)} keys(%varray); print FID GenerateCode('@::legal_versions'); print FID GenerateCode('%::components'); @::legal_components = sort {uc($a) cmp uc($b)} keys(%carray); print FID GenerateCode('@::legal_components'); foreach my $i('product', 'priority', 'severity', 'platform', 'opsys', 'bug_status', 'resolution') { print FID GenerateCode('@::legal_' . $i); } print FID GenerateCode('@::settable_resolution'); print FID GenerateCode('%::proddesc'); print FID GenerateCode('@::enterable_products'); print FID GenerateCode('%::prodmaxvotes'); print FID GenerateCode('$::anyvotesallowed'); if ($dotargetmilestone) { # reading target milestones in from the database - matthew@zeroknowledge.com SendSQL("SELECT value, product FROM milestones ORDER BY sortkey, value"); my @line; my %tmarray; @::legal_target_milestone = (); while(@line = FetchSQLData()) { my ($tm, $pr) = (@line); if (!defined $::target_milestone{$pr}) { $::target_milestone{$pr} = []; } push @{$::target_milestone{$pr}}, $tm; if (!exists $tmarray{$tm}) { $tmarray{$tm} = 1; push(@::legal_target_milestone, $tm); } } print FID GenerateCode('%::target_milestone'); print FID GenerateCode('@::legal_target_milestone'); print FID GenerateCode('%::milestoneurl'); } SendSQL("SELECT id, name FROM keyworddefs ORDER BY name"); while (MoreSQLData()) { my ($id, $name) = FetchSQLData(); push(@::legal_keywords, $name); $name = lc($name); $::keywordsbyname{$name} = $id; } print FID GenerateCode('@::legal_keywords'); print FID GenerateCode('%::keywordsbyname'); print FID "1;\n"; close FID; rename $tmpname, "data/versioncache" || die "Can't rename $tmpname to versioncache"; ChmodDataFile('data/versioncache', 0666); } sub GetKeywordIdFromName { my ($name) = (@_); $name = lc($name); return $::keywordsbyname{$name}; } # Returns the modification time of a file. sub ModTime { my ($filename) = (@_); my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($filename); return $mtime; } # This proc must be called before using legal_product or the versions array. $::VersionTableLoaded = 0; sub GetVersionTable { return if $::VersionTableLoaded; my $mtime = ModTime("data/versioncache"); if (!defined $mtime || $mtime eq "") { $mtime = 0; } if (time() - $mtime > 3600) { use Token; Token::CleanTokenTable(); GenerateVersionTable(); } require 'data/versioncache'; if (!defined %::versions) { GenerateVersionTable(); do 'data/versioncache'; if (!defined %::versions) { die "Can't generate file data/versioncache"; } } $::VersionTableLoaded = 1; } # Validates a given username as a new username # returns 1 if valid, 0 if invalid sub ValidateNewUser { my ($username, $old_username) = @_; if(DBname_to_id($username) != 0) { return 0; } # Reject if the new login is part of an email change which is # still in progress SendSQL("SELECT eventdata FROM tokens WHERE tokentype = 'emailold' AND eventdata like '%:$username' OR eventdata like '$username:%'"); if (my ($eventdata) = FetchSQLData()) { # Allow thru owner of token if($old_username && ($eventdata eq "$old_username:$username")) { return 1; } return 0; } return 1; } sub InsertNewUser { my ($username, $realname) = (@_); # Generate a new random password for the user. my $password = GenerateRandomPassword(); my $cryptpassword = Crypt($password); # Determine what groups the user should be in by default # and add them to those groups. PushGlobalSQLState(); SendSQL("select bit, userregexp from groups where userregexp != ''"); my $groupset = "0"; while (MoreSQLData()) { my @row = FetchSQLData(); # Modified -Joe Robins, 2/17/00 # Making this case insensitive, since usernames are email addresses, # and could be any case. if ($username =~ m/$row[1]/i) { $groupset .= "+ $row[0]"; # Silly hack to let MySQL do the math, # not Perl, since we're dealing with 64 # bit ints here, and I don't *think* Perl # does that. } } # Insert the new user record into the database. $username = SqlQuote($username); $realname = SqlQuote($realname); $cryptpassword = SqlQuote($cryptpassword); SendSQL("INSERT INTO profiles (login_name, realname, cryptpassword, groupset) VALUES ($username, $realname, $cryptpassword, $groupset)"); PopGlobalSQLState(); # Return the password to the calling code so it can be included # in an email sent to the user. return $password; } # Removes all entries from logincookies for $userid, except for the # optional $keep, which refers the logincookies.cookie primary key. # (This is useful so that a user changing their password stays logged in) sub InvalidateLogins { my ($userid, $keep) = @_; my $remove = "DELETE FROM logincookies WHERE userid = $userid"; if (defined $keep) { $remove .= " AND cookie != " . SqlQuote($keep); } SendSQL($remove); } sub GenerateRandomPassword { my ($size) = @_; # Generated passwords are eight characters long by default. $size ||= 8; # The list of characters that can appear in a randomly generated password. # Note that users can put any character into a password they choose themselves. my @pwchars = (0..9, 'A'..'Z', 'a'..'z', '-', '_', '!', '@', '#', '$', '%', '^', '&', '*'); # The number of characters in the list. my $pwcharslen = scalar(@pwchars); # Generate the password. my $password = ""; for ( my $i=0 ; $i<$size ; $i++ ) { $password .= $pwchars[rand($pwcharslen)]; } # Return the password. return $password; } sub SelectVisible { my ($query, $userid, $usergroupset) = @_; # Run the SQL $query with the additional restriction that # the bugs can be seen by $userid. $usergroupset is provided # as an optimisation when this is already known, eg from CGI.pl # If not present, it will be obtained from the db. # Assumes that 'bugs' is mentioned as a table name. You should # also make sure that bug_id is qualified bugs.bug_id! # Your query must have a WHERE clause. This is unlikely to be a problem. # Also, note that mySQL requires aliases for tables to be locked, as well # This means that if you change the name from selectVisible_cc (or add # additional tables), you will need to update anywhere which does a # LOCK TABLE, and then calls routines which call this $usergroupset = 0 unless $userid; unless (defined($usergroupset)) { PushGlobalSQLState(); SendSQL("SELECT groupset FROM profiles WHERE userid = $userid"); $usergroupset = FetchOneColumn(); PopGlobalSQLState(); } # Users are authorized to access bugs if they are a member of all # groups to which the bug is restricted. User group membership and # bug restrictions are stored as bits within bitsets, so authorization # can be determined by comparing the intersection of the user's # bitset with the bug's bitset. If the result matches the bug's bitset # the user is a member of all groups to which the bug is restricted # and is authorized to access the bug. # A user is also authorized to access a bug if she is the reporter, # or member of the cc: list of the bug and the bug allows users in those # roles to see the bug. The boolean fields reporter_accessible and # cclist_accessible identify whether or not those roles can see the bug. # Bit arithmetic is performed by MySQL instead of Perl because bitset # fields in the database are 64 bits wide (BIGINT), and Perl installations # may or may not support integers larger than 32 bits. Using bitsets # and doing bitset arithmetic is probably not cross-database compatible, # however, so these mechanisms are likely to change in the future. my $replace = " "; if ($userid) { $replace .= "LEFT JOIN cc selectVisible_cc ON bugs.bug_id = selectVisible_cc.bug_id AND selectVisible_cc.who = $userid " } $replace .= "WHERE ((bugs.groupset & $usergroupset) = bugs.groupset "; if ($userid) { # There is a mysql bug affecting v3.22 and 3.23 (at least), where this will # cause all rows to be returned! We work arround this by adding an not isnull # test to the JOINed cc table. See http://lists.mysql.com/cgi-ez/ezmlm-cgi?9:mss:11417 # Its needed, even though it shouldn't be $replace .= "OR (bugs.reporter_accessible = 1 AND bugs.reporter = $userid) OR (bugs.cclist_accessible = 1 AND selectVisible_cc.who = $userid AND not isnull(selectVisible_cc.who))"; } $replace .= ") AND "; $query =~ s/\sWHERE\s/$replace/i; return $query; } sub CanSeeBug { # Note that we pass in the usergroupset, since this is known # in most cases (ie viewing bugs). Maybe make this an optional # parameter? my ($id, $userid, $usergroupset) = @_; # Query the database for the bug, retrieving a boolean value that # represents whether or not the user is authorized to access the bug. PushGlobalSQLState(); SendSQL(SelectVisible("SELECT bugs.bug_id FROM bugs WHERE bugs.bug_id = $id", $userid, $usergroupset)); my $ret = defined(FetchSQLData()); PopGlobalSQLState(); return $ret; } sub ValidatePassword { # Determines whether or not a password is valid (i.e. meets Bugzilla's # requirements for length and content). If the password is valid, the # function returns boolean false. Otherwise it returns an error message # (synonymous with boolean true) that can be displayed to the user. # If a second password is passed in, this function also verifies that # the two passwords match. my ($password, $matchpassword) = @_; if ( length($password) < 3 ) { return "The password is less than three characters long. It must be at least three characters."; } elsif ( length($password) > 16 ) { return "The password is more than 16 characters long. It must be no more than 16 characters."; } elsif ( $matchpassword && $password ne $matchpassword ) { return "The two passwords do not match."; } return 0; } sub Crypt { # Crypts a password, generating a random salt to do it. # Random salts are generated because the alternative is usually # to use the first two characters of the password itself, and since # the salt appears in plaintext at the beginning of the crypted # password string this has the effect of revealing the first two # characters of the password to anyone who views the crypted version. my ($password) = @_; # The list of characters that can appear in a salt. Salts and hashes # are both encoded as a sequence of characters from a set containing # 64 characters, each one of which represents 6 bits of the salt/hash. # The encoding is similar to BASE64, the difference being that the # BASE64 plus sign (+) is replaced with a forward slash (/). my @saltchars = (0..9, 'A'..'Z', 'a'..'z', '.', '/'); # Generate the salt. We use an 8 character (48 bit) salt for maximum # security on systems whose crypt uses MD5. Systems with older # versions of crypt will just use the first two characters of the salt. my $salt = ''; for ( my $i=0 ; $i < 8 ; ++$i ) { $salt .= $saltchars[rand(64)]; } # Crypt the password. my $cryptedpassword = crypt($password, $salt); # Return the crypted password. return $cryptedpassword; } sub DBID_to_real_or_loginname { my ($id) = (@_); PushGlobalSQLState(); SendSQL("SELECT login_name,realname FROM profiles WHERE userid = $id"); my ($l, $r) = FetchSQLData(); PopGlobalSQLState(); if (!defined $r || $r eq "") { return $l; } else { return "$l ($r)"; } } sub DBID_to_name { my ($id) = (@_); # $id should always be a positive integer if ($id =~ m/^([1-9][0-9]*)$/) { $id = $1; } else { $::cachedNameArray{$id} = "__UNKNOWN__"; } if (!defined $::cachedNameArray{$id}) { PushGlobalSQLState(); SendSQL("select login_name from profiles where userid = $id"); my $r = FetchOneColumn(); PopGlobalSQLState(); if (!defined $r || $r eq "") { $r = "__UNKNOWN__"; } $::cachedNameArray{$id} = $r; } return $::cachedNameArray{$id}; } sub DBname_to_id { my ($name) = (@_); PushGlobalSQLState(); SendSQL("select userid from profiles where login_name = @{[SqlQuote($name)]}"); my $r = FetchOneColumn(); PopGlobalSQLState(); # $r should be a positive integer, this makes Taint mode happy if (defined $r && $r =~ m/^([1-9][0-9]*)$/) { return $1; } else { return 0; } } sub DBNameToIdAndCheck { my ($name) = (@_); my $result = DBname_to_id($name); if ($result > 0) { return $result; } $name = html_quote($name); ThrowUserError("The name <TT>$name</TT> is not a valid username. Either you misspelled it, or the person has not registered for a Bugzilla account."); } # Use trick_taint() when you know that there is no way that the data # in a scalar can be tainted, but taint mode still bails on it. # WARNING!! Using this routine on data that really could be tainted # defeats the purpose of taint mode. It should only be # used on variables that cannot be touched by users. sub trick_taint { $_[0] =~ /^(.*)$/s; $_[0] = $1; return (defined($_[0])); } sub detaint_natural { $_[0] =~ /^(\d+)$/; $_[0] = $1; return (defined($_[0])); } # This routine quoteUrls contains inspirations from the HTML::FromText CPAN # module by Gareth Rees <garethr@cre.canon.co.uk>. It has been heavily hacked, # all that is really recognizable from the original is bits of the regular # expressions. sub quoteUrls { my ($text) = (@_); return $text unless $text; my $base = Param('urlbase'); my $protocol = join '|', qw(afs cid ftp gopher http https mid news nntp prospero telnet wais); my $count = 0; # Now, quote any "#" characters so they won't confuse stuff later $text =~ s/#/%#/g; # Next, find anything that looks like a URL or an email address and # pull them out the the text, replacing them with a "##<digits>## # marker, and writing them into an array. All this confusion is # necessary so that we don't match on something we've already replaced, # which can happen if you do multiple s///g operations. my @things; while ($text =~ s%((mailto:)?([\w\.\-\+\=]+\@[\w\-]+(?:\.[\w\-]+)+)\b| (\b((?:$protocol):[^ \t\n<>"]+[\w/])))%"##$count##"%exo) { my $item = $&; $item = value_quote($item); if ($item !~ m/^$protocol:/o && $item !~ /^mailto:/) { # We must have grabbed this one because it looks like an email # address. $item = qq{<A HREF="mailto:$item">$item</A>}; } else { $item = qq{<A HREF="$item">$item</A>}; } $things[$count++] = $item; } # Either a comment string or no comma and a compulsory #. while ($text =~ s/\bbug(\s|%\#)*(\d+),?\s*comment\s*(\s|%\#)(\d+)/"##$count##"/ei) { my $item = $&; my $bugnum = $2; my $comnum = $4; $item = GetBugLink($bugnum, $item); $item =~ s/(id=\d+)/$1#c$comnum/; $things[$count++] = $item; } while ($text =~ s/\bcomment(\s|%\#)*(\d+)/"##$count##"/ei) { my $item = $&; my $num = $2; $item = value_quote($item); $item = qq{<A HREF="#c$num">$item</A>}; $things[$count++] = $item; } while ($text =~ s/\bbug(\s|%\#)*(\d+)/"##$count##"/ei) { my $item = $&; my $num = $2; $item = GetBugLink($num, $item); $things[$count++] = $item; } while ($text =~ s/\b(Created an )?attachment(\s|%\#)*(\(id=)?(\d+)\)?/"##$count##"/ei) { my $item = $&; my $num = $4; $item = value_quote($item); # Not really necessary, since we know # there's no special chars in it. $item = qq{<a href="attachment.cgi?id=$num&action=view">$item</a>}; $things[$count++] = $item; } while ($text =~ s/\*\*\* This bug has been marked as a duplicate of (\d+) \*\*\*/"##$count##"/ei) { my $item = $&; my $num = $1; my $bug_link; $bug_link = GetBugLink($num, $num); $item =~ s@\d+@$bug_link@; $things[$count++] = $item; } $text = value_quote($text); $text =~ s/\
/\n/g; # Stuff everything back from the array. for (my $i=0 ; $i<$count ; $i++) { $text =~ s/##$i##/$things[$i]/e; } # And undo the quoting of "#" characters. $text =~ s/%#/#/g; return $text; } # This is a new subroutine written 12/20/00 for the purpose of processing a # link to a bug. It can be called using "GetBugLink (<BugNumber>, <LinkText>);" # Where <BugNumber> is the number of the bug and <LinkText> is what apprears # between '<a>' and '</a>'. sub GetBugLink { my ($bug_num, $link_text) = (@_); detaint_natural($bug_num) || die "GetBugLink() called with non-integer bug number"; # If we've run GetBugLink() for this bug number before, %::buglink # will contain an anonymous array ref of relevent values, if not # we need to get the information from the database. if (! defined $::buglink{$bug_num}) { # Make sure any unfetched data from a currently running query # is saved off rather than overwritten PushGlobalSQLState(); SendSQL("SELECT bugs.bug_status, resolution, short_desc, groupset " . "FROM bugs WHERE bugs.bug_id = $bug_num"); # If the bug exists, save its data off for use later in the sub if (MoreSQLData()) { my ($bug_state, $bug_res, $bug_desc, $bug_grp) = FetchSQLData(); # Initialize these variables to be "" so that we don't get warnings # if we don't change them below (which is highly likely). my ($pre, $title, $post) = ("", "", ""); $title = $bug_state; if ($bug_state eq $::unconfirmedstate) { $pre = "<i>"; $post = "</i>"; } elsif (! IsOpenedState($bug_state)) { $pre = "<strike>"; $title .= " $bug_res"; $post = "</strike>"; } if ($bug_grp == 0 || CanSeeBug($bug_num, $::userid, $::usergroupset)) { $title .= " - $bug_desc"; } $::buglink{$bug_num} = [$pre, value_quote($title), $post]; } else { # Even if there's nothing in the database, we want to save a blank # anonymous array in the %::buglink hash so the query doesn't get # run again next time we're called for this bug number. $::buglink{$bug_num} = []; } # All done with this sidetrip PopGlobalSQLState(); } # Now that we know we've got all the information we're gonna get, let's # return the link (which is the whole reason we were called :) my ($pre, $title, $post) = @{$::buglink{$bug_num}}; # $title will be undefined if the bug didn't exist in the database. if (defined $title) { return qq{$pre<a href="show_bug.cgi?id=$bug_num" title="$title">$link_text</a>$post}; } else { return qq{$link_text}; } } sub GetLongDescriptionAsText { my ($id, $start, $end) = (@_); my $result = ""; my $count = 0; my ($query) = ("SELECT profiles.login_name, longdescs.bug_when, " . " longdescs.thetext " . "FROM longdescs, profiles " . "WHERE profiles.userid = longdescs.who " . "AND longdescs.bug_id = $id "); if ($start && $start =~ /[1-9]/) { # If the start is all zeros, then don't do this (because we want to # not emit a leading "Additional Comments" line in that case.) $query .= "AND longdescs.bug_when > '$start'"; $count = 1; } if ($end) { $query .= "AND longdescs.bug_when <= '$end'"; } $query .= "ORDER BY longdescs.bug_when"; SendSQL($query); while (MoreSQLData()) { my ($who, $when, $text) = (FetchSQLData()); if ($count) { $result .= "\n\n------- Additional Comments From $who".Param('emailsuffix')." ". time2str("%Y-%m-%d %H:%M", str2time($when)) . " -------\n"; } $result .= $text; $count++; } return $result; } sub GetComments { my ($id) = (@_); my @comments; SendSQL("SELECT profiles.realname, profiles.login_name, date_format(longdescs.bug_when,'%Y-%m-%d %H:%i'), longdescs.thetext FROM longdescs, profiles WHERE profiles.userid = longdescs.who AND longdescs.bug_id = $id ORDER BY longdescs.bug_when"); while (MoreSQLData()) { my %comment; ($comment{'name'}, $comment{'email'}, $comment{'time'}, $comment{'body'}) = FetchSQLData(); $comment{'email'} .= Param('emailsuffix'); $comment{'name'} = $comment{'name'} || $comment{'email'}; push (@comments, \%comment); } return \@comments; } # Fills in a hashtable with info about the columns for the given table in the # database. The hashtable has the following entries: # -list- the list of column names # <name>,type the type for the given name sub LearnAboutColumns { my ($table) = (@_); my %a; SendSQL("show columns from $table"); my @list = (); my @row; while (@row = FetchSQLData()) { my ($name,$type) = (@row); $a{"$name,type"} = $type; push @list, $name; } $a{"-list-"} = \@list; return \%a; } # If the above returned a enum type, take that type and parse it into the # list of values. Assumes that enums don't ever contain an apostrophe! sub SplitEnumType { my ($str) = (@_); my @result = (); if ($str =~ /^enum\((.*)\)$/) { my $guts = $1 . ","; while ($guts =~ /^\'([^\']*)\',(.*)$/) { push @result, $1; $guts = $2; } } return @result; } # This routine is largely copied from Mysql.pm. sub SqlQuote { my ($str) = (@_); # if (!defined $str) { # confess("Undefined passed to SqlQuote"); # } $str =~ s/([\\\'])/\\$1/g; $str =~ s/\0/\\0/g; # If it's been SqlQuote()ed, then it's safe, so we tell -T that. trick_taint($str); return "'$str'"; } sub UserInGroup { my ($groupname) = (@_); if ($::usergroupset eq "0") { return 0; } ConnectToDatabase(); PushGlobalSQLState(); SendSQL("select (bit & $::usergroupset) != 0 from groups where name = " . SqlQuote($groupname)); my $bit = FetchOneColumn(); PopGlobalSQLState(); if ($bit) { return 1; } return 0; } sub BugInGroup { my ($bugid, $groupname) = (@_); my $groupbit = GroupNameToBit($groupname); PushGlobalSQLState(); SendSQL("SELECT (bugs.groupset & $groupbit) != 0 FROM bugs WHERE bugs.bug_id = $bugid"); my $bugingroup = FetchOneColumn(); PopGlobalSQLState(); return $bugingroup; } sub GroupExists { my ($groupname) = (@_); ConnectToDatabase(); SendSQL("select count(*) from groups where name=" . SqlQuote($groupname)); my $count = FetchOneColumn(); return $count; } # Given the name of an existing group, returns the bit associated with it. # If the group does not exist, returns 0. # !!! Remove this function when the new group system is implemented! sub GroupNameToBit { my ($groupname) = (@_); ConnectToDatabase(); PushGlobalSQLState(); SendSQL("SELECT bit FROM groups WHERE name = " . SqlQuote($groupname)); my $bit = FetchOneColumn() || 0; PopGlobalSQLState(); return $bit; } # Determines whether or not a group is active by checking # the "isactive" column for the group in the "groups" table. # Note: This function selects groups by bit rather than by name. sub GroupIsActive { my ($groupbit) = (@_); $groupbit ||= 0; ConnectToDatabase(); SendSQL("select isactive from groups where bit=$groupbit"); my $isactive = FetchOneColumn(); return $isactive; } # Determines if the given bug_status string represents an "Opened" bug. This # routine ought to be paramaterizable somehow, as people tend to introduce # new states into Bugzilla. sub IsOpenedState { my ($state) = (@_); if (grep($_ eq $state, OpenStates())) { return 1; } return 0; } # This sub will return an array containing any status that # is considered an open bug. sub OpenStates { return ('NEW', 'REOPENED', 'ASSIGNED', $::unconfirmedstate); } sub RemoveVotes { my ($id, $who, $reason) = (@_); ConnectToDatabase(); my $whopart = ""; if ($who) { $whopart = " AND votes.who = $who"; } SendSQL("SELECT profiles.login_name, profiles.userid, votes.count, " . "products.votesperuser, products.maxvotesperbug " . "FROM profiles " . "LEFT JOIN votes ON profiles.userid = votes.who " . "LEFT JOIN bugs USING(bug_id) " . "LEFT JOIN products USING(product)" . "WHERE votes.bug_id = $id " . $whopart); my @list; while (MoreSQLData()) { my ($name, $userid, $oldvotes, $votesperuser, $maxvotesperbug) = (FetchSQLData()); push(@list, [$name, $userid, $oldvotes, $votesperuser, $maxvotesperbug]); } if (0 < @list) { foreach my $ref (@list) { my ($name, $userid, $oldvotes, $votesperuser, $maxvotesperbug) = (@$ref); my $s; $maxvotesperbug = $votesperuser if ($votesperuser < $maxvotesperbug); # If this product allows voting and the user's votes are in # the acceptable range, then don't do anything. next if $votesperuser && $oldvotes <= $maxvotesperbug; # If the user has more votes on this bug than this product # allows, then reduce the number of votes so it fits my $newvotes = $votesperuser ? $maxvotesperbug : 0; my $removedvotes = $oldvotes - $newvotes; $s = $oldvotes == 1 ? "" : "s"; my $oldvotestext = "You had $oldvotes vote$s on this bug."; $s = $removedvotes == 1 ? "" : "s"; my $removedvotestext = "You had $removedvotes vote$s removed from this bug."; my $newvotestext; if ($newvotes) { SendSQL("UPDATE votes SET count = $newvotes " . "WHERE bug_id = $id AND who = $userid"); $s = $newvotes == 1 ? "" : "s"; $newvotestext = "You still have $newvotes vote$s on this bug." } else { SendSQL("DELETE FROM votes WHERE bug_id = $id AND who = $userid"); $newvotestext = "You have no more votes remaining on this bug."; } # Notice that we did not make sure that the user fit within the $votesperuser # range. This is considered to be an acceptable alternative to losing votes # during product moves. Then next time the user attempts to change their votes, # they will be forced to fit within the $votesperuser limit. # Now lets send the e-mail to alert the user to the fact that their votes have # been reduced or removed. my $sendmailparm = '-ODeliveryMode=deferred'; if (Param('sendmailnow')) { $sendmailparm = ''; } if (open(SENDMAIL, "|/usr/lib/sendmail $sendmailparm -t -i")) { my %substs; $substs{"to"} = $name; $substs{"bugid"} = $id; $substs{"reason"} = $reason; $substs{"votesremoved"} = $removedvotes; $substs{"votesold"} = $oldvotes; $substs{"votesnew"} = $newvotes; $substs{"votesremovedtext"} = $removedvotestext; $substs{"votesoldtext"} = $oldvotestext; $substs{"votesnewtext"} = $newvotestext; $substs{"count"} = $removedvotes . "\n " . $newvotestext; my $msg = PerformSubsts(Param("voteremovedmail"), \%substs); print SENDMAIL $msg; close SENDMAIL; } } SendSQL("SELECT SUM(count) FROM votes WHERE bug_id = $id"); my $v = FetchOneColumn(); $v ||= 0; SendSQL("UPDATE bugs SET votes = $v, delta_ts = delta_ts " . "WHERE bug_id = $id"); } } sub Param ($) { my ($value) = (@_); if (defined $::param{$value}) { return $::param{$value}; } # See if it is a dynamically-determined param (can't be changed by user). if ($value eq "commandmenu") { return GetCommandMenu(); } if ($value eq "settingsmenu") { return GetSettingsMenu(); } # Um, maybe we haven't sourced in the params at all yet. if (stat("data/params")) { # Write down and restore the version # here. That way, we get around # anyone who maliciously tries to tweak the version number by editing # the params file. Not to mention that in 2.0, there was a bug that # wrote the version number out to the params file... my $v = $::param{'version'}; require "data/params"; $::param{'version'} = $v; } if (defined $::param{$value}) { return $::param{$value}; } # Well, that didn't help. Maybe it's a new param, and the user # hasn't defined anything for it. Try and load a default value # for it. require "defparams.pl"; WriteParams(); if (defined $::param{$value}) { return $::param{$value}; } # We're pimped. die "Can't find param named $value"; } # Take two comma or space separated strings and return what # values were removed from or added to the new one. sub DiffStrings { my ($oldstr, $newstr) = @_; # Split the old and new strings into arrays containing their values. $oldstr =~ s/[\s,]+/ /g; $newstr =~ s/[\s,]+/ /g; my @old = split(" ", $oldstr); my @new = split(" ", $newstr); my (@remove, @add) = (); # Find values that were removed foreach my $value (@old) { push (@remove, $value) if !grep($_ eq $value, @new); } # Find values that were added foreach my $value (@new) { push (@add, $value) if !grep($_ eq $value, @old); } my $removed = join (", ", @remove); my $added = join (", ", @add); return ($removed, $added); } sub PerformSubsts { my ($str, $substs) = (@_); $str =~ s/%([a-z]*)%/(defined $substs->{$1} ? $substs->{$1} : Param($1))/eg; return $str; } # Min and max routines. sub min { my $min = shift(@_); foreach my $val (@_) { $min = $val if $val < $min; } return $min; } sub max { my $max = shift(@_); foreach my $val (@_) { $max = $val if $val > $max; } return $max; } # Trim whitespace from front and back. sub trim { my ($str) = @_; $str =~ s/^\s+//g; $str =~ s/\s+$//g; return $str; } ############################################################################### # Global Templatization Code # Use the template toolkit (http://www.template-toolkit.org/) to generate # the user interface using templates in the "template/" subdirectory. use Template; # Create the global template object that processes templates and specify # configuration parameters that apply to all templates processed in this script. # IMPORTANT - If you make any configuration changes here, make sure to make # them in t/004.template.t and checksetup.pl. You may also need to change the # date settings were last changed - see the comments in checksetup.pl for # details $::template ||= Template->new( { # Colon-separated list of directories containing templates. INCLUDE_PATH => "template/en/custom:template/en/default" , # Remove white-space before template directives (PRE_CHOMP) and at the # beginning and end of templates and template blocks (TRIM) for better # looking, more compact content. Use the plus sign at the beginning # of directives to maintain white space (i.e. [%+ DIRECTIVE %]). PRE_CHOMP => 1 , TRIM => 1 , COMPILE_DIR => 'data/', # Functions for processing text within templates in various ways. FILTERS => { # Render text in strike-through style. strike => sub { return "<strike>" . $_[0] . "</strike>" } , # Returns the text with backslashes, single/double quotes, # and newlines/carriage returns escaped for use in JS strings. js => sub { my ($var) = @_; $var =~ s/([\\\'\"])/\\$1/g; $var =~ s/\n/\\n/g; $var =~ s/\r/\\r/g; return $var; } , html => \&html_quote , # This subroutine in CGI.pl escapes characters in a variable # or value string for use in a query string. It escapes all # characters NOT in the regex set: [a-zA-Z0-9_\-.]. The 'uri' # filter should be used for a full URL that may have # characters that need encoding. url_quote => \&url_quote , } , } ) || DisplayError("Template creation failed: " . Template->error()) && exit; # Use the Toolkit Template's Stash module to add utility pseudo-methods # to template variables. use Template::Stash; # Add "contains***" methods to list variables that search for one or more # items in a list and return boolean values representing whether or not # one/all/any item(s) were found. $Template::Stash::LIST_OPS->{ contains } = sub { my ($list, $item) = @_; return grep($_ eq $item, @$list); }; $Template::Stash::LIST_OPS->{ containsany } = sub { my ($list, $items) = @_; foreach my $item (@$items) { return 1 if grep($_ eq $item, @$list); } return 0; }; sub GetOutputFormats { # Builds a set of possible output formats for a script by looking for # format files in the appropriate template directories as specified by # the template include path, the sub-directory parameter, and the # template name parameter. # This function is relevant for scripts with one basic function whose # results can be represented in multiple formats, f.e. buglist.cgi, # which has one function (query and display of a list of bugs) that can # be represented in multiple formats (i.e. html, rdf, xml, etc.). # It is *not* relevant for scripts with several functions but only one # basic output format, f.e. editattachstatuses.cgi, which not only lists # statuses but also provides adding, editing, and deleting functions. # (although it may be possible to make this function applicable under # these circumstances with minimal modification). # Format files have names that look like SCRIPT-FORMAT.EXT.tmpl, where # SCRIPT is the name of the CGI script being invoked, SUBDIR is the name # of the template sub-directory, FORMAT is the name of the format, and EXT # is the filename extension identifying the content type of the output. # When a format file is found, a record for that format is added to # the hash of format records, indexed by format name, with each record # containing the name of the format file, its filename extension, # and its content type (obtained by reference to the $::contenttypes # hash defined in localconfig). my ($subdir, $script) = @_; # A set of output format records, indexed by format name, each record # containing template, extension, and contenttype fields. my $formats = {}; # Get the template include path from the template object. my $includepath = $::template->context->{ LOAD_TEMPLATES }->[0]->include_path(); # Loop over each include directory in reverse so that format files # earlier in the path override files with the same name later in # the path (i.e. "custom" formats override "default" ones). foreach my $path (reverse @$includepath) { # Get the list of files in the given sub-directory if it exists. my $dirname = File::Spec->catdir($path, $subdir); opendir(SUBDIR, $dirname) || next; my @files = readdir SUBDIR; closedir SUBDIR; # Loop over each file in the sub-directory looking for format files # (files whose name looks like SCRIPT-FORMAT.EXT.tmpl). foreach my $file (@files) { if ($file =~ /^\Q$script\E-(.+)\.(.+)\.(tmpl)$/) { $formats->{$1} = { 'template' => $file , 'extension' => $2 , 'contenttype' => $::contenttypes->{$2} || "text/plain" , }; } } } return $formats; } sub ValidateOutputFormat { my ($format, $script, $subdir) = @_; # If the script name is undefined, assume the script currently being # executed, deriving its name from Perl's built-in $0 (program name) var. if (!defined($script)) { my ($volume, $dirs, $filename) = File::Spec->splitpath($0); $filename =~ /^(.+)\.cgi$/; $script = $1 || DisplayError("Could not determine the name of the script.") && exit; } # If the format name is undefined or the default format is specified, # do not do any validation but instead return the default format. if (!defined($format) || $format eq "default") { return { 'template' => "$script.html.tmpl" , 'extension' => "html" , 'contenttype' => "text/html" , }; } # If the subdirectory name is undefined, assume the script name. $subdir = $script if !defined($subdir); # Get the list of output formats supported by this script. my $formats = GetOutputFormats($subdir, $script); # Validate the output format requested by the user. if (!$formats->{$format}) { my $escapedname = html_quote($format); DisplayError("The <em>$escapedname</em> output format is not supported by this script. Supported formats (besides the default HTML format) are <em>" . join("</em>, <em>", map(html_quote($_), keys(%$formats))) . "</em>."); exit; } # Return the validated output format. return $formats->{$format}; } ############################################################################### # Add a "substr" method to the Template Toolkit's "scalar" object # that returns a substring of a string. $Template::Stash::SCALAR_OPS->{ substr } = sub { my ($scalar, $offset, $length) = @_; return substr($scalar, $offset, $length); }; # Add a "truncate" method to the Template Toolkit's "scalar" object # that truncates a string to a certain length. $Template::Stash::SCALAR_OPS->{ truncate } = sub { my ($string, $length, $ellipsis) = @_; $ellipsis ||= ""; return $string if !$length || length($string) <= $length; my $strlen = $length - length($ellipsis); my $newstr = substr($string, 0, $strlen) . $ellipsis; return $newstr; }; # Define the global variables and functions that will be passed to the UI # template. Additional values may be added to this hash before templates # are processed. $::vars = { # Function for retrieving global parameters. 'Param' => \&Param , # Function for processing global parameters that contain references # to other global parameters. 'PerformSubsts' => \&PerformSubsts , # Generic linear search function 'lsearch' => \&lsearch , # UserInGroup - you probably want to cache this 'UserInGroup' => \&UserInGroup , # SyncAnyPendingShadowChanges - called in the footer to sync the shadowdb 'SyncAnyPendingShadowChanges' => \&SyncAnyPendingShadowChanges , # User Agent - useful for detecting in templates 'user_agent' => $ENV{'HTTP_USER_AGENT'} , }; 1;