$title

# common functions for the DCC whitelist CGI scripts. # --S-LICENSE-- # $Revision: 1.35 $ # @configure_input@ package common; use strict; use integer; use 5.004; use Fcntl qw(:DEFAULT :flock); use POSIX qw(strftime); BEGIN { use Exporter(); our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(Exporter); @EXPORT = qw(&html_head &html_footer &html_str_encode &html_whine &html_die &punt2 &url_encode &common_buttons &read_whiteclnt &read_whitedefs &undo_whiteclnt &ck_new_white_entry &newest_whiteclnt_bak &parse_type_value &chg_white_entry &parse_thold_value &write_whiteclnt &parse_log_msg &msg2path &get_log_msgs $cgibin $logdir $logout_tmpdir $user_dir %query $user $hostname $main_whiteclnt $whiteclnt $thold_cks $thold_cks_cmn %conf_cks_tholds $list_log_url $list_log_link $list_msg_link $edit_url $edit_link $passwd_url $passwd_link $logoutID $url_ques $url_suffix $sub_white $form_hidden $msg $msg_date $msg_helo $msg_ip $msg_client_name $msg_env_from @msg_env_to $msg_mail_host $msg_from $msg_subject $msg_hdrs $msg_body $msg_cksums $msg_result %msgs_cache %msgs_date %msgs_result %msgs_from %msgs_subject $msg_day_first $msg_day_last $msg_first $msg_last $msg_newer $msg_part_num @msgs_num $sub_hdrs $DCC_HOMEDIR $DCCM_ENABLE $DCCM_ARGS $DCCM_USERDIRS $DCCM_REJECT_AT $DCCM_CKSUMS $DCCIFD_ENABLE $DCCIFD_ARGS $DCCIFD_REJECT_AT $DCCIFD_USERDIRS $DCCIFD_CKSUMS $GREY_CLIENT_ARGS $DNSBL_ARGS $REP_ARGS $whiteclnt_version $whiteclnt_notify $whiteclnt_notify_pat $whiteclnt_lock $whiteclnt_cur_key $whiteclnt_change_log); %EXPORT_TAGS = (); @EXPORT_OK = @EXPORT; } our @EXPORT_OK; our ($cgibin, $logdir, $logout_tmpdir, $user_dir); our (%query, $user, $hostname, $main_whiteclnt, $whiteclnt, # path to the per-user whitelist file $thold_cks, # checksums that can have thresholds $thold_cks_cmn, %conf_cks_tholds, $list_log_url, $list_log_link, $list_msg_link, $edit_url, $edit_link, $passwd_url, $passwd_link, $logoutID, $url_ques, $url_suffix, $form_hidden); # 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 =