+ maybelink($in);
+ maybelink('http://foobarbaz,http://bleh',qr/[, ]+/);
+ maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', ');
+
+
+In the first form, links the link if it looks like a link. In the
+second form, first splits based on the regex, then reassembles the
+link, linking things that look like links. In the third form, rejoins
+the split links with commas and spaces.
+
+=cut
+
+sub maybelink {
+ my ($links,$regex,$join) = @_;
+ if (not defined $regex and not defined $join) {
+ $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))}
+ {html_escape($1).(length $2?q(<a href=").html_escape($2).q(">).html_escape($2).q(</a>):'').html_escape($3)}geimo;
+ return $links;
+ }
+ $join = ' ' if not defined $join;
+ my @return;
+ my @segments;
+ if (defined $regex) {
+ @segments = split $regex, $links;
+ }
+ else {
+ @segments = ($links);
+ }
+ for my $in (@segments) {
+ if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme
+ push @return, qq{<a href="$in">} . html_escape($in) . '</a>';
+ } else {
+ push @return, html_escape($in);
+ }
+ }
+ return @return?join($join,@return):'';
+}
+
+
+=head2 htmlize_addresslinks
+
+ htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class);
+
+
+Generate a comma-separated list of HTML links to each address given in
+$addresses, which should be a comma-separated list of RFC822
+addresses. $urlfunc should be a reference to a function like mainturl
+or submitterurl which returns the URL for each individual address.
+
+
+=cut
+
+sub htmlize_addresslinks {
+ my ($prefixfunc, $urlfunc, $addresses,$class) = @_;
+ carp "htmlize_addresslinks is deprecated";
+
+ $class = defined $class?qq(class="$class" ):'';
+ if (defined $addresses and $addresses ne '') {
+ my @addrs = getparsedaddrs($addresses);
+ my $prefix = (ref $prefixfunc) ?
+ $prefixfunc->(scalar @addrs):$prefixfunc;
+ return $prefix .
+ join(', ', map
+ { sprintf qq(<a ${class}).
+ 'href="%s">%s</a>',
+ $urlfunc->($_->address),
+ html_escape($_->format) ||
+ '(unknown)'
+ } @addrs
+ );
+ }
+ else {
+ my $prefix = (ref $prefixfunc) ?
+ $prefixfunc->(1) : $prefixfunc;
+ return sprintf '%s<a '.$class.'href="%s">(unknown)</a>',
+ $prefix, $urlfunc->('');
+ }
+}
+
+sub emailfromrfc822{
+ my $addr = getparsedaddrs($_[0] || "");
+ $addr = defined $addr?$addr->address:'';
+ return $addr;
+}
+
+sub mainturl { package_links(maintainer => $_[0], links_only => 1); }
+sub submitterurl { package_links(submitter => $_[0], links_only => 1); }
+sub htmlize_maintlinks {
+ my ($prefixfunc, $maints) = @_;
+ carp "htmlize_maintlinks is deprecated";
+ return htmlize_addresslinks($prefixfunc, \&mainturl, $maints);
+}
+
+=head2 bug_linklist
+
+ bug_linklist($separator,$class,@bugs)
+
+Creates a set of links to C<@bugs> separated by C<$separator> with
+link class C<$class>.
+
+XXX Use L<Params::Validate>; we want to be able to support query
+arguments here too; we should be able to combine bug_links and this
+function into one.
+
+=cut
+
+
+sub bug_linklist{
+ my ($sep,$class,@bugs) = @_;
+ carp "bug_linklist is deprecated; use bug_links instead";
+ return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep);
+}
+
+
+sub add_user {
+ my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_;
+ $seen_users = {} if not defined $seen_users;
+ $bug_usertags = {} if not defined $bug_usertags;
+ $usertags = {} if not defined $usertags;
+ $cats = {} if not defined $cats;
+ $hidden = {} if not defined $hidden;
+ return if exists $seen_users->{$user};
+ $seen_users->{$user} = 1;
+
+ my $u = Debbugs::User::get_user($user);
+
+ my %vis = map { $_, 1 } @{$u->{"visible_cats"}};
+ for my $c (keys %{$u->{"categories"}}) {
+ $cats->{$c} = $u->{"categories"}->{$c};
+ $hidden->{$c} = 1 unless defined $vis{$c};
+ }
+ for my $t (keys %{$u->{"tags"}}) {
+ $usertags->{$t} = [] unless defined $usertags->{$t};
+ push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}};
+ }
+
+ %{$bug_usertags} = ();
+ for my $t (keys %{$usertags}) {
+ for my $b (@{$usertags->{$t}}) {
+ $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b};
+ push @{$bug_usertags->{$b}}, $t;
+ }
+ }
+}
+
+
+
+=head1 Forms
+
+=cut
+
+=head2 form_options_and_normal_param
+
+ my ($form_option,$param) = form_options_and_normal_param(\%param)
+ if $param{form_options};
+ my $form_option = form_options_and_normal_param(\%param)
+ if $param{form_options};
+
+Translates from special form_options to a set of parameters which can
+be used to run the current page.
+
+The idea behind this is to allow complex forms to relatively easily
+cause options that the existing cgi scripts understand to be set.
+
+Currently there are two commands which are understood:
+combine, and concatenate.
+
+=head3 combine
+
+Combine works by entering key,value pairs into the parameters using
+the key field option input field, and the value field option input
+field.
+
+For example, you would have
+
+ <input type="hidden" name="_fo_combine_key_fo_searchkey_value_fo_searchvalue" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_searchkey" value="foo">
+ <input type="text" name="_fo_searchvalue" value="bar">
+
+would yield foo=>'bar' in %param.
+
+=head3 concatenate
+
+Concatenate concatenates values into a single entry in a parameter
+
+For example, you would have
+
+ <input type="hidden" name="_fo_concatentate_into_foo_with_:_fo_blah_fo_bleargh" value="1">
+
+which would combine the _fo_searchkey and _fo_searchvalue input fields, so
+
+ <input type="text" name="_fo_blah" value="bar">
+ <input type="text" name="_fo_bleargh" value="baz">
+
+would yield foo=>'bar:baz' in %param.
+
+
+=cut
+
+my $form_option_leader = '_fo_';
+sub form_options_and_normal_param{
+ my ($orig_param) = @_;
+ # all form_option parameters start with _fo_
+ my ($param,$form_option) = ({},{});
+ for my $key (keys %{$orig_param}) {
+ if ($key =~ /^\Q$form_option_leader\E/) {
+ $form_option->{$key} = $orig_param->{$key};
+ }
+ else {
+ $param->{$key} = $orig_param->{$key};
+ }
+ }
+ # at this point, we check for commands
+ COMMAND: for my $key (keys %{$form_option}) {
+ $key =~ s/^\Q$form_option_leader\E//;
+ if (my ($key_name,$value_name) =
+ $key =~ /combine_key(\Q$form_option_leader\E.+)
+ _value(\Q$form_option_leader\E.+)$/x
+ ) {
+ next unless defined $form_option->{$key_name};
+ next unless defined $form_option->{$value_name};
+ my @keys = make_list($form_option->{$key_name});
+ my @values = make_list($form_option->{$value_name});
+ for my $i (0 .. $#keys) {
+ last if $i > $#values;
+ next if not defined $keys[$i];
+ next if not defined $values[$i];
+ __add_to_param($param,
+ $keys[$i],
+ $values[$i],
+ );
+ }
+ }
+ elsif (my ($field,$concatenate_key,$fields) =
+ $key =~ /concatenate_into_(.+?)((?:_with_[^_])?)
+ ((?:\Q$form_option_leader\E.+?)+)
+ $/x
+ ) {
+ if (length $concatenate_key) {
+ $concatenate_key =~ s/_with_//;
+ }
+ else {
+ $concatenate_key = ':';
+ }
+ my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g;
+ my %field_list;
+ my $max_num = 0;
+ for my $f (@fields) {
+ next COMMAND unless defined $form_option->{$f};
+ $field_list{$f} = [make_list($form_option->{$f})];
+ $max_num = max($max_num,$#{$field_list{$f}});
+ }
+ for my $i (0 .. $max_num) {
+ next unless @fields == grep {$i <= $#{$field_list{$_}} and
+ defined $field_list{$_}[$i]} @fields;
+ __add_to_param($param,
+ $field,
+ join($concatenate_key,
+ map {$field_list{$_}[$i]} @fields
+ )
+ );
+ }
+ }
+ }
+ return wantarray?($form_option,$param):$form_option;
+}
+
+=head2 option_form
+
+ print option_form(template=>'pkgreport_options',
+ param => \%param,
+ form_options => $form_options,
+ )
+
+
+
+=cut
+
+sub option_form{
+ my %param = validate_with(params => \@_,
+ spec => {template => {type => SCALAR,
+ },
+ variables => {type => HASHREF,
+ default => {},
+ },
+ language => {type => SCALAR,
+ optional => 1,
+ },
+ param => {type => HASHREF,
+ default => {},
+ },
+ form_options => {type => HASHREF,
+ default => {},
+ },
+ },
+ );
+
+ # First, we need to see if we need to add particular types of
+ # parameters
+ my $variables = dclone($param{variables});
+ $variables->{param} = dclone($param{param});
+ for my $key (keys %{$param{form_option}}) {
+ # strip out leader; shouldn't be anything here without one,
+ # but skip stupid things anyway
+ next unless $key =~ s/^\Q$form_option_leader\E//;
+ if ($key =~ /^add_(.+)$/) {
+ # this causes a specific parameter to be added
+ __add_to_param($variables->{param},
+ $1,
+ ''
+ );
+ }
+ elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) {
+ next unless exists $variables->{param}{$1};
+ if (ref $variables->{param}{$1} eq 'ARRAY' and
+ defined $2 and
+ defined $variables->{param}{$1}[$2]
+ ) {
+ splice @{$variables->{param}{$1}},$2,1;
+ }
+ else {
+ delete $variables->{param}{$1};
+ }
+ }
+ # we'll add extra comands here once I figure out what they
+ # should be
+ }
+ # now at this point, we're ready to create the template
+ return Debbugs::Text::fill_in_template(template=>$param{template},
+ (exists $param{language}?(language=>$param{language}):()),
+ variables => $variables,
+ hole_var => {'&html_escape' => \&html_escape,
+ },
+ );
+}
+
+sub __add_to_param{
+ my ($param,$key,@values) = @_;
+
+ if (exists $param->{$key} and not
+ ref $param->{$key}) {
+ @{$param->{$key}} = [$param->{$key},
+ @values
+ ];
+ }
+ else {
+ push @{$param->{$key}}, @values;
+ }
+}
+
+
+
+=head1 misc
+
+=cut
+
+=head2 maint_decode
+
+ maint_decode
+
+Decodes the funky maintainer encoding.
+
+Don't ask me what in the world it does.
+
+=cut
+
+sub maint_decode {
+ my @input = @_;
+ return () unless @input;
+ my @output;
+ for my $input (@input) {
+ my $decoded = $input;
+ $decoded =~ s/-([^_]+)/-$1_-/g;
+ $decoded =~ s/_/-20_/g;
+ $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/;
+ $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/;
+ $decoded =~ s/\./-2e_/g;
+ $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge;
+ push @output,$decoded;
+ }
+ wantarray ? @output : $output[0];
+}
+
+=head1 cache
+
+=head2 calculate_etags
+
+ calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]);
+
+=cut
+
+sub calculate_etags {
+ my %param =
+ validate_with(params => \@_,
+ spec => {files => {type => ARRAYREF,
+ default => [],
+ },
+ additional_data => {type => ARRAYREF,
+ default => [],
+ },
+ },
+ );
+ my @additional_data = @{$param{additional_data}};
+ for my $file (@{$param{files}}) {
+ my $st = stat($file) or warn "Unable to stat $file: $!";
+ push @additional_data,$st->mtime;
+ push @additional_data,$st->size;
+ }
+ return(md5_hex(join('',sort @additional_data)));
+}
+
+=head2 etag_does_not_match
+
+ etag_does_not_match(cgi=>$q,files=>[qw(list of files)],
+ additional_data=>[qw(any additional data)])
+
+
+Checks to see if the CGI request contains an etag which matches the calculated
+etag.
+
+If there wasn't an etag given, or the etag given doesn't match, return the etag.
+
+If the etag does match, return 0.
+
+=cut
+
+sub etag_does_not_match {
+ my %param =
+ validate_with(params => \@_,
+ spec => {files => {type => ARRAYREF,
+ default => [],
+ },
+ additional_data => {type => ARRAYREF,
+ default => [],
+ },
+ cgi => {type => OBJECT},
+ },
+ );
+ my $submitted_etag =
+ $param{cgi}->http('if-none-match');
+ my $etag =
+ calculate_etags(files=>$param{files},
+ additional_data=>$param{additional_data});
+ if (not defined $submitted_etag or
+ length($submitted_etag) != 32
+ or $etag ne $submitted_etag
+ ) {
+ return $etag;
+ }
+ if ($etag eq $submitted_etag) {
+ return 0;
+ }
+}