$title

#! @PERL@ -wT -I@cgibin@ # check this file by running it separately, and so keep the leading comment # This contains old version of common functions for DCC whitelist CGI scripts # for old installations that expect it. They should change to the new # module scheme. # --S-LICENSE-- # $Revision: 1.122 $ # @configure_input@ use strict 'subs'; use integer; use 5.004; use Fcntl qw(:DEFAULT :flock); use POSIX qw(strftime); # global variables # $DCCM_USERDIRS, # from dcc_conf # $whiteclnt, # path to the per-user whitelist file # %query, # $thold_cks, # checksums that can have thresholds # $user, # $hostname, # $user_dir, # $edit_url, # $list_log_url, # $list_log_link, # $list_msg_link, # $edit_url, $edit_link, # $passwd_url, $passwd_link, # $logoutID, # $url_ques, $url_suffix, # $sub_white, # 'subsitute' headers from dcc_conf # $form_hidden # state for main form # quiet Perl taint checks with a path that should work everywhere for # the few commands these scripts use. $ENV{PATH}="@libexecdir@:/sbin:/bin:/usr/sbin:/usr/bin"; # check_user() must be called before html_head() return check_user(); sub debug_time { my($label) = @_; my($str); return if (!$query{debug}); my(@ts, $ts); require 'sys/syscall.ph'; $ts = pack("LL", ()); syscall(&SYS_gettimeofday, $ts, 0); @ts = unpack("LL", $ts); chomp($label); $str = sprintf "%30s", $label; $str .= strftime(" %X", localtime($ts[0])); $str .= sprintf ".%03d", $ts[1]/1000; $str .= sprintf " %5.3f", $_ foreach times; $str .= "\n"; print STDERR $str; } sub debug_printf { my($label, $str) = @_; return if (!$query{debug}); $str =~ s/\n/\\n/g; print STDERR "$label='$str'\n"; } # emit HTTP/HTML header sub html_head { my($title, # title of the web page $refresh_url) = @_; # next step in re-login sequence if not null my($header, $style); print < $title EOF print "\n" if ($refresh_url); # Use header if supplied # it is mostly text for the start of the , # but it can also contain ... $header = "\n"; if (open(HEADER, "$user_dir/header") || open(HEADER, "@cgibin@/header")) { my $line; $header .= $line while ($line =

); close(HEADER); } # Use our style if the supplied header has none $style = ""; $style .= "$1\n" if ($header =~ s/(\h*]*rel=['"]?stylesheet[^>]*>)//si); $style .= "$1\n" if ($header =~ s/(\h*]*>.*<\/STYLE>)//si); $style = < EOF print <

$title

$header EOF } sub html_footer { if (open(FOOTER, "$user_dir/footer") || open(FOOTER, "@cgibin@/footer")) { my $line; print $line while ($line =