interchange-5.7.7.orig/0000755000000000000000000000000011575303570011654 5ustar interchange-5.7.7.orig/code/0000755000000000000000000000000011624451637012571 5ustar interchange-5.7.7.orig/code/Filter/0000755000000000000000000000000011624451637014016 5ustar interchange-5.7.7.orig/code/Filter/acl2hash.filter0000644000000000000000000000175211352565025016712 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: acl2hash.filter,v 1.3 2007-03-30 23:40:44 pajamian Exp $ CodeDef acl2hash Filter CodeDef acl2hash Description acl2hash CodeDef acl2hash Visibility private CodeDef acl2hash Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/cgi.filter0000644000000000000000000000111011352565025015753 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: cgi.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef cgi Filter CodeDef cgi Description Get CGI value of variable CodeDef cgi Routine <convert_date({ fmt => $fmt, body => $time}); } EOR interchange-5.7.7.orig/code/Filter/crypt.filter0000644000000000000000000000116411352565025016363 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: crypt.filter,v 1.5 2007-03-30 23:40:44 pajamian Exp $ CodeDef crypt Filter CodeDef crypt Description Crypt CodeDef crypt Routine < $locale }); } EOR interchange-5.7.7.orig/code/Filter/date2time.filter0000644000000000000000000000256511352565025017106 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: date2time.filter,v 1.6 2007-03-30 23:40:44 pajamian Exp $ CodeDef date2time Filter CodeDef date2time Description Date to UNIX time (deprecated - use datetime2epoch instead) CodeDef date2time Visibility private CodeDef date2time Routine < 1 } @_ }; HTML::Entities::decode_entities($val) if $val =~ /&/; $val =~ s/\0+//g; my $re = $opt->{undef} ? qr:^(\d*)[-/]+(\d*)[-/]+(\d*)(.*)$: : qr:^(\d+)[-/]+(\d+)[-/]+(\d+)(.*)$: ; return $val unless $val =~ /$re/; my ($year, $month, $day, $timeval); if (length($1) == 4) { # ISO date style 2003-03-20 ($year, $month, $day) = ($1, $2, $3); } else { # U.S. date style 3/20/2003 or 3/20/03 ($year, $month, $day) = ($3, $1, $2); } $timeval = $4; if ($opt->{undef}) { # return nothing (undef, which DBI treats as SQL NULL) for an # empty date (all zeroes or nothing at all) return unless grep /[1-9]/, ($year, $month, $day); } # Y2K fun: Try to guess intent of year "03" as "2003" if (length($year) < 4) { $year = $year < 50 ? $year + 2000 : $year + 1900; } my ($date_format, $time_format); if ($opt->{iso}) { $date_format = '%04d-%02d-%02d'; $time_format = 'T%02d:%02d:%02d'; } else { $date_format = '%04d%02d%02d'; $time_format = '%02d%02d'; } my $time; if ($timeval =~ /^:(\d{1,4})\s*$/) { # accept traditional Interchange date_time widget times # of format '0130', e.g. '20080201:0130' $time = sprintf('%04d', $1); $time = sprintf($time_format, substr($time, 0, 2), substr($time, 2, 2)); } elsif ( # accept times of format '1:30', '1:30:05', # to support PostgreSQL's timestamp with time zone format # e.g. '2008-02-01 01:30:05-07' my ($hours, $minutes, $seconds) = ($timeval =~ /\s(\d\d?):(\d\d?)(?::(\d\d+))/) ) { $time = sprintf($time_format, $hours, $minutes, $seconds); } my $out = sprintf($date_format, $year, $month, $day); $out .= $time if $time and not $opt->{no_time}; return $out; } EOR interchange-5.7.7.orig/code/Filter/datetime2epoch.filter0000644000000000000000000000272311352565025020121 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: datetime2epoch.filter,v 1.2 2007-03-30 23:40:44 pajamian Exp $ CodeDef datetime2epoch Filter CodeDef datetime2epoch Description Date and optional time to seconds since the UNIX Epoch CodeDef datetime2epoch Routine <{ProductFiles}[0]; my $db; unless ($db = dbref($table)) { ::logError("filter dbi_quote cannot find database handle for table '%s'", $table); return; } return $db->quote($val); } EOR interchange-5.7.7.orig/code/Filter/decode_entities.filter0000644000000000000000000000117511352565025020353 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: decode_entities.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef decode_entities Filter CodeDef decode_entities Description Decode HTML entities CodeDef decode_entities Routine <{$startvar} || $val; my $durstring = $CGI->{$durvar}; use Time::Local; if (!length($durstring) && $durvar =~ /^\d+$/) { $durstring = join(' ', $durvar, @extra); } ## Want to allow setting the value directly return $val unless $durstring; $start =~ s/\0+//g; if($start =~ m:(\d+)[-/]+(\d+)[-/]+(\d+):) { my ($yr, $mon, $day) = ($3, $1, $2); my $time; $start =~ /:(\d+)$/ and $time = $1; if(length($yr) < 4) { $yr =~ s/^0//; $yr = $yr < 50 ? $yr + 2000 : $yr + 1900; } $mon =~ s/^0//; $day =~ s/^0//; $start = sprintf("%d%02d%02d", $yr, $mon, $day); return $val unless $time; $start .= sprintf('%04d', $time); } my $time; $start =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)?(\d\d)?/; my ($yr, $mon, $day, $hr, $min) = ($1 || 0, $2 || 1, $3 || 1, $4 || 0, $5 || 0); $mon--; eval { $time = timelocal(0, $min, $hr, $day, $mon, $yr); }; if($@) { logError("bad time value passed to duration filter: %s", $@); return 0; } $time = adjust_time($durstring, $time); return POSIX::strftime("%Y%m%d%H%M%S", localtime($time)); } EOR interchange-5.7.7.orig/code/Filter/encode_entities.filter0000644000000000000000000000140311352565025020357 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: encode_entities.filter,v 1.5 2007-03-30 23:40:44 pajamian Exp $ CodeDef e Filter CodeDef e Alias encode_entities CodeDef entities Filter CodeDef entities Alias encode_entities CodeDef encode_entities Filter CodeDef encode_entities Description Encode HTML entities CodeDef encode_entities Routine < CodeDef encode_special_entities Routine </>/g; return $val; } EOR interchange-5.7.7.orig/code/Filter/encrypt.filter0000644000000000000000000000117011352565025016703 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: encrypt.filter,v 1.5 2007-03-30 23:40:44 pajamian Exp $ CodeDef encrypt Filter CodeDef encrypt Description PGP encrypt CodeDef encrypt Routine <{type}; if($wid =~ /fillin/) { return 'nullselect'; } elsif($wid =~ /select.*multip/) { return 'null_to_comma'; } elsif ($wid =~ /checkbox/) { return 'checkbox null_to_comma'; } return ''; } EOR interchange-5.7.7.orig/code/Filter/gate.filter0000644000000000000000000000116211352565025016140 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: gate.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef gate Filter CodeDef gate Description Gate with scratch CodeDef gate Routine <{$var}; return $val; } EOR interchange-5.7.7.orig/code/Filter/hash2acl.filter0000644000000000000000000000172511352565025016712 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: hash2acl.filter,v 1.3 2007-03-30 23:40:44 pajamian Exp $ CodeDef hash2acl Filter CodeDef hash2acl Description hash2acl CodeDef hash2acl Visibility private CodeDef hash2acl Routine <{$_} = ''; my $val = $_; $val =~ s/,/,/g; $val =~ s/=/=/g; push @opts, "$val=$hash->{$_}"; } $value = join ",", @opts; return $value; } EOR interchange-5.7.7.orig/code/Filter/html2text.filter0000644000000000000000000000114511535625651017161 0ustar # Copyright 2002-2009 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. CodeDef html2text Filter CodeDef html2text Description Simple html2text CodeDef html2text Routine <]*)>\s*%\n%gi; $val =~ s%<[/!a-zA-Z].*?>%%gs; return $val; } EOR interchange-5.7.7.orig/code/Filter/integer.filter0000644000000000000000000000107511352565025016660 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: integer.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef integer Filter CodeDef integer Description Integer CodeDef integer Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/large.filter0000644000000000000000000000116211352565025016312 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: large.filter,v 1.5 2007-03-30 23:40:44 pajamian Exp $ CodeDef large Filter CodeDef large Description HTML large CodeDef large Visibility private CodeDef large Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/last_non_null.filter0000644000000000000000000000124611352565025020072 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: last_non_null.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef last_non_null Filter CodeDef last_non_null Description Reverse combo CodeDef last_non_null Routine <{mv_locale}) { POSIX::setlocale(LC_CTYPE, $Scratch->{mv_locale}); } return lc(shift); } EOR interchange-5.7.7.orig/code/Filter/lcfirst.filter0000644000000000000000000000121611352565025016666 0ustar # Copyright 2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: lcfirst.filter,v 1.1 2007-07-13 08:22:47 racke Exp $ CodeDef lcfirst Filter CodeDef lcfirst Description First character lower case CodeDef lcfirst Routine <{mv_locale}) { POSIX::setlocale(LC_CTYPE, $Scratch->{mv_locale}); } return lcfirst(shift); } EOR interchange-5.7.7.orig/code/Filter/line.filter0000644000000000000000000000114111352565025016144 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: line.filter,v 1.5 2007-03-30 23:40:44 pajamian Exp $ CodeDef line Filter CodeDef line Description First line CodeDef line Routine <]*action=)(["'])(\%5b\w+.*?\%5d)\2} { $1 . $2 . unhexify($3) . $2 }egi; $body =~ s{(<\w+\s+[^>]*href=)(["'])(\%5b\w+.*?\%5d)\2} { $1 . $2 . unhexify($3) . $2 }egi; $body =~ s{(]*src=)(["'])(\%5b\w+.*?\%5d)\2} { $1 . $2 . unhexify($3) . $2 }egi; return $body; } EOR interchange-5.7.7.orig/code/Filter/liven_urls.filter0000644000000000000000000002121511352565025017403 0ustar # Copyright 2005 Davor Ocelic (docelic@mail.inet.hr) # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: liven_urls.filter,v 1.3 2007-03-30 23:40:44 pajamian Exp $ CodeDef liven_urls Filter CodeDef liven_urls Description Make URLs clickable CodeDef liven_urls Routine < <<'ENDR', (?:https?://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)(?:/(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;:@&=])*)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;:@&=])*))*)(?:\?(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;:@&=])*))?)?) ENDR ftp => <<'ENDR', (?:ftp://(?:(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?&=])*)(?::(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?&=])*))?@)?(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?))(?:/(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*))*)(?:;type=[AIDaid])?)?) ENDR mailto => <<'ENDR', (?:mailto:(?:(?:[a-zA-Z\d$\-_.+!*'(),;/?:@&=]|(?:%[a-fA-F\d]{2}))+)) ENDR #news => <<'ENDR', #(?:news:(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;/?:&=])+@(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3})))|(?:[a-zA-Z](?:[a-zA-Z\d]|[_.+-])*)|\*)) #ENDR #nntp => <<'ENDR', #(?:nntp://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)/(?:[a-zA-Z](?:[a-zA-Z\d]|[_.+-])*)(?:/(?:\d+))?) #ENDR #telnet => <<'ENDR', #(?:telnet://(?:(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?&=])*)(?::(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?&=])*))?@)?(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?))/?) #ENDR #gopher => <<'ENDR', #(?:gopher://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)(?:/(?:[a-zA-Z\d$\-_.+!*'(),;/?:@&=]|(?:%[a-fA-F\d]{2}))(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),;/?:@&=]|(?:%[a-fA-F\d]{2}))*)(?:%09(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;:@&=])*)(?:%09(?:(?:[a-zA-Z\d$\-_.+!*'(),;/?:@&=]|(?:%[a-fA-F\d]{2}))*))?)?)?)?) #ENDR #wais => <<'ENDR', #(?:wais://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)/(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*)(?:(?:/(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*)/(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*))|\?(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;:@&=])*))?) #ENDR #file => <<'ENDR', #(?:file://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))|localhost)?/(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*))*)) #ENDR #prospero => <<'ENDR', #(?:prospero://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)/(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&=])*))*)(?:(?:;(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&])*)=(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[?:@&])*)))*) #ENDR #ldap => <<'ENDR', #(?:ldap://(?:(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?))?/(?:(?:(?:(?:(?:(?:(?:[a-zA-Z\d]|%(?:3\d|[46][a-fA-F\d]|[57][Aa\d]))|(?:%20))+|(?:OID|oid)\.(?:(?:\d+)(?:\.(?:\d+))*))(?:(?:%0[Aa])?(?:%20)*)=(?:(?:%0[Aa])?(?:%20)*))?(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*))(?:(?:(?:%0[Aa])?(?:%20)*)\+(?:(?:%0[Aa])?(?:%20)*)(?:(?:(?:(?:(?:[a-zA-Z\d]|%(?:3\d|[46][a-fA-F\d]|[57][Aa\d]))|(?:%20))+|(?:OID|oid)\.(?:(?:\d+)(?:\.(?:\d+))*))(?:(?:%0[Aa])?(?:%20)*)=(?:(?:%0[Aa])?(?:%20)*))?(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*)))*)(?:(?:(?:(?:%0[Aa])?(?:%20)*)(?:[;,])(?:(?:%0[Aa])?(?:%20)*))(?:(?:(?:(?:(?:(?:[a-zA-Z\d]|%(?:3\d|[46][a-fA-F\d]|[57][Aa\d]))|(?:%20))+|(?:OID|oid)\.(?:(?:\d+)(?:\.(?:\d+))*))(?:(?:%0[Aa])?(?:%20)*)=(?:(?:%0[Aa])?(?:%20)*))?(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*))(?:(?:(?:%0[Aa])?(?:%20)*)\+(?:(?:%0[Aa])?(?:%20)*)(?:(?:(?:(?:(?:[a-zA-Z\d]|%(?:3\d|[46][a-fA-F\d]|[57][Aa\d]))|(?:%20))+|(?:OID|oid)\.(?:(?:\d+)(?:\.(?:\d+))*))(?:(?:%0[Aa])?(?:%20)*)=(?:(?:%0[Aa])?(?:%20)*))?(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))*)))*))*(?:(?:(?:%0[Aa])?(?:%20)*)(?:[;,])(?:(?:%0[Aa])?(?:%20)*))?)(?:\?(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+)(?:,(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+))*)?)(?:\?(?:base|one|sub)(?:\?(?:((?:[a-zA-Z\d$\-_.+!*'(),;/?:@&=]|(?:%[a-fA-F\d]{2}))+)))?)?)?) #ENDR #z3950 => <<'ENDR', #(?:(?:z39\.50[rs])://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+)(?:\+(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+))*(?:\?(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+))?)?(?:;esn=(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+))?(?:;rs=(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+)(?:\+(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))+))*)?)) #ENDR #cid => <<'ENDR', #(?:cid:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?:@&=])*)) #ENDR #mid => <<'ENDR', #(?:mid:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?:@&=])*)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[;?:@&=])*))?) #ENDR #vemmi => <<'ENDR', #(?:vemmi://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)(?:/(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[/?:@&=])*)(?:(?:;(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[/?:@&])*)=(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[/?:@&])*))*))?) #ENDR #imap => <<'ENDR', #(?:imap://(?:(?:(?:(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~])+)(?:(?:;[Aa][Uu][Tt][Hh]=(?:\*|(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~])+))))?)|(?:(?:;[Aa][Uu][Tt][Hh]=(?:\*|(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~])+)))(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~])+))?))@)?(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?))/(?:(?:(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~:@/])+)?;[Tt][Yy][Pp][Ee]=(?:[Ll](?:[Ii][Ss][Tt]|[Ss][Uu][Bb])))|(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~:@/])+)(?:\?(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~:@/])+))?(?:(?:;[Uu][Ii][Dd][Vv][Aa][Ll][Ii][Dd][Ii][Tt][Yy]=(?:[1-9]\d*)))?)|(?:(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~:@/])+)(?:(?:;[Uu][Ii][Dd][Vv][Aa][Ll][Ii][Dd][Ii][Tt][Yy]=(?:[1-9]\d*)))?(?:/;[Uu][Ii][Dd]=(?:[1-9]\d*))(?:(?:/;[Ss][Ee][Cc][Tt][Ii][Oo][Nn]=(?:(?:(?:[a-zA-Z\d$\-_.+!*'(),]|(?:%[a-fA-F\d]{2}))|[&=~:@/])+)))?)))?) #ENDR #nfs => <<'ENDR', #(?:nfs:(?:(?://(?:(?:(?:(?:(?:[a-zA-Z\d](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?)\.)*(?:[a-zA-Z](?:(?:[a-zA-Z\d]|-)*[a-zA-Z\d])?))|(?:(?:\d+)(?:\.(?:\d+)){3}))(?::(?:\d+))?)(?:(?:/(?:(?:(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*)(?:/(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*))*)?)))?)|(?:/(?:(?:(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*)(?:/(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*))*)?))|(?:(?:(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*)(?:/(?:(?:(?:[a-zA-Z\d\$\-_.!~*'(),])|(?:%[a-fA-F\d]{2})|[:@&=+])*))*)?))) #ENDR ); # my %regexps chomp $regexps{$_} for keys %regexps; sub { my ($val,$tag,@arg) = @_; @arg or @arg = (qw/http ftp mailto/); @arg = grep { $regexps{$_} } @arg; @arg or return $val; my $match_url = join '|', @regexps{@arg}; $val =~ s/($match_url)/$1<\/a>/gsi; $val } EOR interchange-5.7.7.orig/code/Filter/loc.filter0000644000000000000000000000110211352565025015767 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: loc.filter,v 1.4 2007-03-30 23:40:44 pajamian Exp $ CodeDef loc Filter CodeDef loc Description Localize CodeDef loc Routine <}; my $anchor = $val; if(@arg) { $anchor = join " ", @arg; } $out .= "$anchor"; } EOR interchange-5.7.7.orig/code/Filter/md5.filter0000644000000000000000000000112111352565025015700 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: md5.filter,v 1.5 2007-03-30 23:40:45 pajamian Exp $ CodeDef md5 Filter CodeDef md5 Description MD5 sum CodeDef md5 Routine <{$field}); } $col ||= $field; eval { my $db = database_exists_ref($table) or die errmsg("next_sequential filter: no table '%s'", $table); my $tname = $db->name(); my $q = "SELECT $col FROM $tname"; if($qualifier) { my $qval = $CGI::values{$qualifier}; $qval = $db->quote($qval, $qualifier); $q .= " WHERE $qualifier = $qval"; } $q .= " ORDER BY $col desc"; #::logDebug("constructed query $q for next_sequential"); my $ary = $db->query($q) or die errmsg("next_sequential filter query failed: %s", $q); return 1 unless @$ary; $val = $ary->[0][0]; $val++; }; if($@) { logError($@); return undef; } return $val; } EOR interchange-5.7.7.orig/code/Filter/no_white.filter0000644000000000000000000000114611352565025017036 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: no_white.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef no_white Filter CodeDef no_white Description No whitespace CodeDef no_white Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/qb_safe.filter0000644000000000000000000000122111352565025016614 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: qb_safe.filter,v 1.8 2007-03-30 23:40:45 pajamian Exp $ CodeDef qb_safe Filter CodeDef qb_safe Description Safe for Quickbooks CodeDef qb_safe Visibility private CodeDef qb_safe Routine <])}{ ($allowed{lc $2} ? '<' : '<') . $1 }ge; return $val; } EOR interchange-5.7.7.orig/code/Filter/roman.filter0000644000000000000000000000223711352565025016340 0ustar # Copyright 2005 Cursor Software Limited (http://www.cursor.biz/) # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: roman.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef roman Filter CodeDef roman Description Integer to Roman numerals CodeDef roman Visibility private CodeDef roman Routine <= 0; $i--) { $buf .= $numerals[$i]->[$digits[$i]]; } return $buf; } EOR interchange-5.7.7.orig/code/Filter/round.filter0000644000000000000000000000125411352565025016351 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: round.filter,v 1.4 2007-11-15 01:14:14 jon Exp $ CodeDef round Filter CodeDef round Description Round numeric value to the specified number of decimal places (default 2) CodeDef round Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/space_to_nbsp.filter0000644000000000000000000000127311352565025020042 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: space_to_nbsp.filter,v 1.3 2007-03-30 23:40:45 pajamian Exp $ CodeDef space_to_nbsp Filter CodeDef space_to_nbsp Description All SPACE to nbsp CodeDef space_to_nbsp Routine <{filter_sql_no_backslash}; return $val; } EOR interchange-5.7.7.orig/code/Filter/strftime.filter0000644000000000000000000000142411352565025017056 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: strftime.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef strftime Filter CodeDef strftime Description Date from UNIX time CodeDef strftime Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/strip.filter0000644000000000000000000000115711352565025016365 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: strip.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef strip Filter CodeDef strip Description Trim whitespace CodeDef strip Routine <//s; # replace these container tags with a space $val =~ s{]*)?>}{ }ig; # replace these self-closing tags with a space $val =~ s{<[bh]r(?:\s*/|\s[^>]*)?>}{ }ig; # remove all remaining tags and leave no space $val =~ s{]*>}{}g; # collapse all whitespace, as HTML does when rendering anyway, # to facilitate truncating at a certain number of characters $val =~ s{\A\s+}{}; $val =~ s{\s+\z}{}; $val =~ s{\s+}{ }g; return $val; } EOR interchange-5.7.7.orig/code/Filter/tabbed.filter0000644000000000000000000000114411352565025016441 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: tabbed.filter,v 1.5 2007-03-30 23:40:45 pajamian Exp $ CodeDef tabbed Filter CodeDef tabbed Description Newline to TAB CodeDef tabbed Routine <!g; $val =~ s!\r\r!!g; $val =~ s!\r?\n!!g; $val =~ s!\r!!g; return $val; } EOR interchange-5.7.7.orig/code/Filter/textarea_get.filter0000644000000000000000000000117211352565025017675 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: textarea_get.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef textarea_get Filter CodeDef textarea_get Description Textarea GET CodeDef textarea_get Routine <' . shift(@_) . ''; } EOR interchange-5.7.7.orig/code/Filter/uc.filter0000644000000000000000000000127611352565025015635 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: uc.filter,v 1.6 2007-03-30 23:40:45 pajamian Exp $ CodeDef upper Filter CodeDef upper Alias uc CodeDef uc Filter CodeDef uc Description Upper case CodeDef uc Routine <{mv_locale}) { POSIX::setlocale(LC_CTYPE, $Scratch->{mv_locale}); } return uc(shift); } EOR interchange-5.7.7.orig/code/Filter/ucfirst.filter0000644000000000000000000000121611352565025016677 0ustar # Copyright 2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: ucfirst.filter,v 1.1 2007-07-13 08:22:47 racke Exp $ CodeDef ucfirst Filter CodeDef ucfirst Description First character upper case CodeDef ucfirst Routine <{mv_locale}) { POSIX::setlocale(LC_CTYPE, $Scratch->{mv_locale}); } return ucfirst(shift); } EOR interchange-5.7.7.orig/code/Filter/unix.filter0000644000000000000000000000114311352565025016202 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: unix.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef unix Filter CodeDef unix Description DOS to UNIX newlines CodeDef unix Routine < 'isfile', })) { return tag_value_extended($vn, { file_contents => 1 }); } else { return $fn; } } EOR interchange-5.7.7.orig/code/Filter/urldecode.filter0000644000000000000000000000140111352565025017162 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: urldecode.filter,v 1.5 2007-09-21 16:15:48 kwalsh Exp $ CodeDef url Filter CodeDef url Alias urldecode CodeDef urld Filter CodeDef urld Alias urldecode CodeDef urldecode Filter CodeDef urldecode Description URL decode CodeDef urldecode Routine <{VALUE} CodeDef value Visibility private CodeDef value Routine <{$_[0]}; } EOR interchange-5.7.7.orig/code/Filter/vars_and_comments.filter0000644000000000000000000000137411352565025020727 0ustar # Copyright 2004-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: vars_and_comments.filter,v 1.5 2007-03-30 23:40:45 pajamian Exp $ CodeDef vars_and_comments Filter CodeDef vars_and_comments Description Vars/comments CodeDef vars_and_comments Visibility private CodeDef vars_and_comments Routine <{Locale}; return $val unless defined $Vend::Cfg->{Locale}{$val}; return $Vend::Cfg->{Locale}{$val}; } EOR interchange-5.7.7.orig/code/Filter/zerofix.filter0000644000000000000000000000112511352565025016705 0ustar # Copyright 2002-2007 Interchange Development Group and others # Copyright 1996-2002 Red Hat, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: zerofix.filter,v 1.4 2007-03-30 23:40:45 pajamian Exp $ CodeDef zerofix Filter CodeDef zerofix Description Strip leading zeros CodeDef zerofix Routine <{name}; my $fn = $opt->{form_name} || 'flex_editor'; my $rn = $opt->{js_check_name} || "${fn}_${name}_required"; my $lab = $opt->{label}; $lab ||= $name; my $exist = $opt->{prepend} || ''; my $undef_message = $Tag->jsq( errmsg( "%s (%s): requires entry, currently %s", $lab, $name, errmsg('undefined'), ) ); my $blank_message = $Tag->jsq( errmsg( "%s (%s): requires entry, currently %s", $lab, $name, errmsg('blank'), ) ); my $whitespace_message = $Tag->jsq( errmsg( "%s (%s): requires entry, currently %s", $lab, $name, errmsg('whitespace'), ) ); my $script = < function $rn (el, frm) { var nm = el.name; if(el.value == undefined) { alert($undef_message); return false; } if(el.value.length == 0) { alert($blank_message); return false; } if(el.value.match(/^\\s*\$/)) { alert($whitespace_message); return false; } return true; } EOS if($exist) { $opt->{prepend} = "$script\n$exist"; } else { $opt->{prepend} = $script; } my $call = "$rn(this,this.form)"; if(my $ejs = $opt->{js}) { if($ejs =~ s{(^|\s+)onchange\s*=\s*"(.*)"}{ my $pre = $1; my $ex = $2; qq[${pre}onBlur="if($call) { $ex }"]; }ie ) { $opt->{js} = $ejs; } else { $opt->{js} =~ s/\s+$//; $opt->{js} .= qq{ onBlur="$call"}; } } else { $opt->{js} = qq{ onBlur="$call"}; } return; } EOR interchange-5.7.7.orig/code/OrderCheck/0000755000000000000000000000000011624451637014602 5ustar interchange-5.7.7.orig/code/OrderCheck/always_fail.oc0000644000000000000000000000116011352565025017411 0ustar # Copyright 2006-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: always_fail.oc,v 1.2 2007-03-30 23:40:48 pajamian Exp $ CodeDef always_fail OrderCheck 1 CodeDef always_fail Description Always fails CodeDef always_fail Routine <record_exists($value); } else { #::logDebug("Doing foreign key check, tab=$tab col=$col value=$value"); $used = $db->foreign($value, $col); } #::logDebug("Checking exists, tab=$tab col=$col, used=$used"); if($used) { return (1, $name, ''); } else { $msg = errmsg( "Key %s does not exist in %s, try again.", $value, $tab, ) unless $msg; return(0, $name, $msg); } } EOR interchange-5.7.7.orig/code/OrderCheck/filter.oc0000644000000000000000000000201411535625651016407 0ustar # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: filter.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $ CodeDef filter OrderCheck 1 CodeDef filter Description Passes filter unchanged CodeDef filter Routine < $adjust }, "%Y%m%d%H%M", ); # reject invalid dates if($value !~ /^[12]\d\d\d[01]\d[0123]\d(?:[0-2]\d[0-5]\d(?:[0-5]\d)?)?$/) { return (0, $name, $message); } if($value lt $current) { return (0, $name, $message); } return (1, $name, ''); } EOR interchange-5.7.7.orig/code/OrderCheck/isbn.oc0000644000000000000000000000326011535625651016061 0ustar # Copyright 2008,2009 Interchange Development Group # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. CodeDef isbn OrderCheck 1 CodeDef isbn Description ISBN-10/ISBN-13 check digit verification CodeDef isbn Routine < 0; $i--) { my $d = $digits[10 - $i]; if ($d =~ /[Xx]/) { if ($i == 1) { $d = 10; } else { return (undef, $var, errmsg("'%s' not a valid isbn number", $val)); } } $sum += $d * $i; } return ( $sum%11 ? 0 : 1, $var, '' ); } elsif (@digits == 13) { # ISBN-13/EAN number if ($len == 10) { return (0, $var, errmsg("'%s' not a valid isbn-10 number", $val)); } for (my $i = 0; $i < 12; $i++) { if ($i % 2) { $sum += 3 * $digits[$i]; } else { $sum += $digits[$i]; } } if ($modulo = $sum % 10) { $check_digit = 10 - $modulo; } if (pop(@digits) == $check_digit) { # verification successful return (1, $var, ''); } } } return (undef, $var, errmsg("'%s' not a valid isbn number", $val)); } EOR interchange-5.7.7.orig/code/OrderCheck/length.oc0000644000000000000000000000202411535625651016404 0ustar # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: length.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $ CodeDef length OrderCheck 1 CodeDef length Description String length CodeDef length Routine < $max) { $msg = errmsg( "%s length %s more than maximum length %s.", $name, $len, $max) if ! $msg; return(0, $name, $msg); } return (1, $name, ''); } EOR interchange-5.7.7.orig/code/OrderCheck/match.oc0000644000000000000000000000117211352565025016215 0ustar # Copyright 2007 Interchange Development Group (http://www.icdevgroup.org/) # Licensed under the GNU GPL v2. See file LICENSE for details. # $Id: match.oc,v 1.1 2007-05-04 14:36:00 mheins Exp $ CodeDef match OrderCheck 1 CodeDef match Description Matches another CGI variable, possibly for password verify CodeDef match Routine <{$other} ne $value) { $msg = errmsg( "%s doesn't match %s.", $name, $other, ) if ! $msg; return(0, $name, $msg); } return (1, $name, ''); } EOR interchange-5.7.7.orig/code/OrderCheck/natural.oc0000644000000000000000000000146111352565025016570 0ustar # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: natural.oc,v 1.4 2008-04-28 12:08:38 docelic Exp $ CodeDef natural OrderCheck CodeDef natural Description Natural number CodeDef natural Routine < 0 and "$value" eq int($value)) { return (1, $name, ''); } $code =~ s/\\/\\\\/g; $code =~ s/^\s*(["'])(.+?)\1$/$2/; if ($code =~ /\S/) { return (0, $name, $code); } else { return (0, $name, 'no natural number'); } } EOR interchange-5.7.7.orig/code/OrderCheck/numeric.oc0000644000000000000000000000126311535625651016571 0ustar # Copyright 2010 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. CodeDef numeric OrderCheck CodeDef numeric Description Numeric CodeDef numeric Routine <record_exists($value); } else { #::logDebug("Doing foreign key check, tab=$tab col=$col value=$value"); $used = $db->foreign($value, $col); } #::logDebug("Checking unique, tab=$tab col=$col, used=$used"); if(! $used) { return (1, $name, ''); } else { $msg = errmsg( "Key %s already exists in %s, try again.", $value, $tab, ) unless $msg; return(0, $name, $msg); } } EOR interchange-5.7.7.orig/code/SystemTag/0000755000000000000000000000000011624451637014511 5ustar interchange-5.7.7.orig/code/SystemTag/accessories.coretag0000644000000000000000000000203011352565025020350 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: accessories.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag accessories Order code arg UserTag accessories addAttr UserTag accessories attrAlias db table UserTag accessories attrAlias base table UserTag accessories attrAlias database table UserTag accessories attrAlias col column UserTag accessories attrAlias row code UserTag accessories attrAlias field column UserTag accessories attrAlias key code UserTag accessories PosNumber 2 UserTag accessories Version $Revision: 1.4 $ UserTag accessories MapRoutine Vend::Interpolate::tag_accessories interchange-5.7.7.orig/code/SystemTag/accounting.coretag0000644000000000000000000000345611352565025020214 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: accounting.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag accounting Order function UserTag accounting addAttr UserTag accounting Version $Revision: 1.5 $ UserTag accounting Routine <{Accounting}; my $enable; if($account_super{$func}) { eval { $enable = $Vend::admin && $Tag->if_mm('super'); }; } elsif($account_admin{$func}) { $enable = $Vend::admin; } else { $enable = 1; } if(! $enable) { die errmsg("Function '%s' not enabled for current user level.", $func); } if(my $sys = $opt->{system}) { my $former = $Vend::Cfg->{Accounting}; $Vend::Cfg->{Accounting} = $Vend::Cfg->{Accounting_repository}{$sys} or do { logError( "Failed to change accounting system to %s, returning to %s.", $opt->{system}, $former->{Class}, ); $Vend::Cfg->{Accounting} = $former; return undef; }; } my $a = $Vend::Cfg->{Accounting} or do { logError("No accounting system present. Aborting."); return undef; }; my $class = $a->{Class}; my $self = new $class; my $can; unless( $can = $self->can($func) ) { logError( "No function '%s' in accounting system %s. Aborting.", $func, $class, ); return undef; } return $can if $opt->{can_do_function}; return $self->$func($opt); } EOR interchange-5.7.7.orig/code/SystemTag/area.coretag0000644000000000000000000000123111352565025016757 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: area.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $ UserTag href Alias area UserTag area Order href arg UserTag area addAttr UserTag area Implicit secure secure UserTag area PosNumber 2 UserTag area Version $Revision: 1.6 $ UserTag area MapRoutine Vend::Interpolate::tag_area interchange-5.7.7.orig/code/SystemTag/assign.coretag0000644000000000000000000000227311352565025017342 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: assign.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag assign addAttr UserTag assign PosNumber 0 UserTag assign Version $Revision: 1.5 $ UserTag assign Routine <{clear}) { delete $Vend::Session->{assigned}; return; } $Vend::Session->{assigned} ||= {}; for(keys %$opt) { next unless $_assignable{$_}; my $value = $opt->{$_}; $value =~ s/^\s+//; $value =~ s/\s+$//; if($value =~ /^-?\d+\.?\d*$/) { $Vend::Session->{assigned}{$_} = $value; } else { logError( "Attempted assign of non-numeric '%s' to %s. Deleted.", $value, $_, ); delete $Vend::Session->{assigned}{$_}; } } return; } EOR interchange-5.7.7.orig/code/SystemTag/attr_list.coretag0000644000000000000000000000146711535625651020074 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: attr_list.coretag,v 1.8 2008-07-12 19:27:12 docelic Exp $ UserTag attr_list addAttr UserTag attr_list hasEndTag UserTag attr_list PosNumber 0 UserTag attr_list noRearrange UserTag attr_list Version $Revision: 1.8 $ UserTag attr_list Routine <{hash} ) { $opt = $opt->{hash}; } return Vend::Interpolate::tag_attr_list($body, $opt); } EOR interchange-5.7.7.orig/code/SystemTag/banner.coretag0000644000000000000000000000651011352565025017321 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: banner.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag banner Order category UserTag banner addAttr UserTag banner PosNumber 1 UserTag banner Version $Revision: 1.6 $ UserTag banner Routine <{table} || 'banner'; my $c_field; my $append = ''; if($category) { $append = ' AND '; $append .= ($opt->{c_field} || 'category'); $category =~ s/'/''/g; $append .= " = '$category'"; } my $db = database_exists_ref($t); if(! $db) { my $weight_file = "$dir/total_weight"; return undef if -f $weight_file; $t = "no banners db $t\n"; Vend::Util::writefile( $weight_file, $t, $opt); ::logError($t); return undef; } my $w_field = $opt->{w_field} || 'weight'; my $b_field = $opt->{b_field} || 'banner'; my $q = "select $w_field, $b_field from $t where $w_field >= 1$append"; my $banners = $db->query({ query => $q, st => 'db', }); my $i = 0; for(@$banners) { my ($weight, $text) = @$_; for(1 .. $weight) { Vend::Util::writefile(">$dir/$i", $text, $opt); $i++; } } Vend::Util::writefile(">$dir/total_weight", $i, $opt); } sub tag_weighted_banner { my ($category, $opt) = @_; my $dir = catfile($Vend::Cfg->{ScratchDir}, 'Banners'); mkdir $dir, 0777 if ! -d $dir; if($category) { my $c = $category; $c =~ s/\W//g; $dir .= "/$c"; } my $statfile = $Vend::Cfg->{ConfDir}; $statfile .= "/status.$Vend::Cat"; my $start_time; if($opt->{once}) { $start_time = 0; } elsif(! -f $statfile) { Vend::Util::writefile( $statfile, "banners initialized " . time() . "\n"); $start_time = time(); } else { $start_time = (stat(_))[9]; } my $weight_file = "$dir/total_weight"; initialize_banner_directory($dir, $category, $opt) if ( ! -f $weight_file or (stat(_))[9] < $start_time ); my $n = int( rand( readfile($weight_file) ) ); return Vend::Util::readfile("$dir/$n"); } return tag_weighted_banner($place, $opt) if $opt->{weighted}; my $table = $opt->{table} || 'banner'; my $r_field = $opt->{r_field} || 'rotate'; my $b_field = $opt->{b_field} || 'banner'; my $sep = $opt->{separator} || ':'; my $delim = $opt->{delimiter} || "{or}"; $place = 'default' if ! $place; my $totrot; do { my $banner_data; $totrot = tag_data($table, $r_field, $place); if(! length $totrot) { # No banner present unless ($place =~ /$sep/ or $place eq 'default') { $place = 'default'; redo; } } elsif ($totrot) { my $current = $::Scratch->{"rotate_$place"}++ || 0; my $data = tag_data($table, $b_field, $place); my(@banners) = split /\Q$delim/, $data; return '' unless @banners; return $banners[$current % scalar(@banners)]; } else { return tag_data($table, $b_field, $place); } } while $place =~ s/(.*)$sep.*/$1/; return; } EOR interchange-5.7.7.orig/code/SystemTag/calc.coretag0000644000000000000000000000115311352565025016754 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: calc.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag calc hasEndTag UserTag calc Interpolate UserTag calc Version $Revision: 1.4 $ UserTag calc MapRoutine Vend::Interpolate::tag_calc interchange-5.7.7.orig/code/SystemTag/calcn.coretag0000644000000000000000000000110411352565025017126 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: calcn.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag calcn hasEndTag UserTag calcn Version $Revision: 1.4 $ UserTag calcn MapRoutine Vend::Interpolate::tag_calc interchange-5.7.7.orig/code/SystemTag/captcha.coretag0000644000000000000000000001503011352565025017454 0ustar # Copyright 2006-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: captcha.coretag,v 1.4 2007-03-30 23:55:57 pajamian Exp $ UserTag captcha Order function UserTag captcha attrAlias func function UserTag captcha addAttr UserTag captcha Description Generate captcha codes for authentication check UserTag captcha Version $Revision: 1.4 $ UserTag captcha Routine <{captcha}; } $opt->{length} ||= 4; my $en = $opt->{error_name} || 'captcha'; my $subdir = $opt->{image_subdir} || $::Variable->{CAPTCHA_IMAGE_SUBDIR} || 'captcha'; my $tmpdir = "$Vend::Cfg->{ScratchDir}/$subdir"; mkdir($tmpdir) unless -d $tmpdir; my $imgdir = $opt->{image_location} || $::Variable->{CAPTCHA_IMAGE_LOCATION}; unless ($imgdir ) { if(! $Global::NoAbsolute and $::Variable->{DOCROOT}) { $imgdir = "$::Variable->{DOCROOT}$::Variable->{IMAGE_DIR}/$subdir"; } else { $imgdir = "images/$subdir"; } } my $imgpath = $opt->{image_path} || $::Variable->{CAPTCHA_IMAGE_PATH} || "$::Variable->{IMAGE_DIR}/$subdir"; my $captcha = Authen::Captcha->new( data_folder => $tmpdir, output_folder => $imgdir, ); my $guess = $opt->{guess} || $CGI::values{mv_captcha_guess}; my $code = $opt->{source}; if($func eq 'check') { my $check_against = $code || $Vend::Session->{captcha}; my $status = $captcha->check_code($guess, $check_against); if($status > 0) { return $status; } elsif($status == 0) { $Tag->error( { name => $en, set => "Code not checked: error" }); return 0; } elsif($status == -1) { $Tag->error( { name => $en, set => "Code expired" }); return 0; } elsif($status == -2) { $Tag->error( { name => $en, set => "Code never generated" }); return 0; } elsif($status == -3) { $Tag->error( { name => $en, set => "Code doesn't match" }); return 0; } } else { my $save_u = umask($::Variable->{CAPTCHA_UMASK} || 2); if($opt->{reset}) { undef $Vend::Captcha; delete $Vend::Session->{captcha}; } if($Vend::Captcha) { $code ||= $Vend::Session->{captcha}; } if($func eq 'code' and $code) { return $code; } eval { unless( Vend::File::allowed_file($imgdir, 1) ) { my $msg = errmsg("No permission to write directory '%s'", $imgdir); $Tag->error( { name => $en, set => $msg }); return 0; } mkdir($imgdir) unless -d $imgdir; if(! $code) { $code = $Vend::Session->{captcha} = $captcha->generate_code($opt->{length}); $Vend::Captcha = $code; } umask $save_u; }; if($@) { $Tag->error( { name => $en, set => "Error: $@" }); return ''; } if($func eq 'code') { return $code; } # Now probably an image function. unless ($func =~ /ima?ge?/) { $Tag->error({ name => $en, set => errmsg("Unknown function %s", $func), }); return undef; } my $path = $opt->{relative} ? "$subdir/$code.png" : "$imgpath/$code.png"; if(! $opt->{name_only}) { return $Tag->image($path); } else { return $path; } } } EOR UserTag captcha Documentation <{captcha}). There are several functions. =over 4 =item check Checks the captcha source code (presumably from the previous page) against the guess. If it matches, returns 1. If not, returns 0 and puts error in $Tag->error. =item code Returns the generated code. Generates one if not done previously in session. =item image Returns an IMG tag as generated by Interchange's [image] tag. If the name-only=1 option is passed, no surrounding IMG tag will be generated, only the image name. If the C option is passed, that name will not be prefaced with the ImageDir. =back The additional options are: =over 4 =item guess The input from the user when the function is C. Default is the contents of [cgi mv_captcha_guess]. =item image-subdir The image subdirectory (based in images directory) which will be used. =item image-path The base path for URL generation. Default is the Interchange IMAGE_DIR variable. =item image-location The directory where image files will be generated. Default is the Interchange IMAGE_DIR variable based in the Interchange DOCROOT variable, with the subdirectory above, i.e. C<[var DOCROOT][var IMAGE_DIR]/captcha>. =item length Length of the input for the captcha. Default is 4 characters. =item name-only When set, tells the image function to not generate an HTML IMG tag. =item relative When set, tells the image function (when in name-only mode) to return relative path. =item reset Normally only one captcha code / image will be generated per page transaction. If this is set, you can generate another one -- though you would have to take care of saving the generated code yourself, as $Session->{captcha} is overwritten. =item source The captcha base to guess against for the C function. Default is the contents of the last-generated captcha, or [cgi mv_captcha_source]. =back =head1 EXAMPLE [if cgi mv_captcha_guess] [tmp good][captcha check][/tmp] [if scratch good] You guessed right! [else] Sorry, try again. [/else] [/if]
[/if] [captcha function=image]
[error auto=1] =head1 PREREQUISITES Authen::Captcha =head1 AUTHOR Mike Heins, . EOD interchange-5.7.7.orig/code/SystemTag/cart.coretag0000644000000000000000000000116611352565025017007 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: cart.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag cart Order name UserTag cart PosNumber 1 UserTag cart Version $Revision: 1.6 $ UserTag cart MapRoutine Vend::Interpolate::tag_cart interchange-5.7.7.orig/code/SystemTag/catch.coretag0000644000000000000000000000355711352565025017146 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: catch.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $ UserTag catch Order label UserTag catch addAttr UserTag catch hasEndTag UserTag catch Version $Revision: 1.7 $ UserTag catch Routine <{try}{$label}; $body = pull_if($body); if ( $opt->{exact} ) { #---------------------------------------------------------------- # Convert multiple errors to 'or' list and compile it. # Note also the " at (eval ...)" kludge to strip the line numbers $patt = $error; $patt =~ s/(?: +at +\(eval .+\).+)?\n\s*/|/g; $patt =~ s/^\s*//; $patt =~ s/\|$//; $patt = qr($patt); #---------------------------------------------------------------- } my @found; while ($body =~ s{ \[/ (.+?) /\] (.*?) \[/ (?:\1)?/? \]}{}sx ) { my $re; my $emsg = $2; eval { $re = qr{$1} }; next if $@; if($emsg =~ $patt) { push @found, $emsg; } next unless $error =~ $re; push @found, $emsg; last; } if(@found) { $body = join $opt->{joiner} || "\n", @found; } else { $body =~ s/\$ERROR\$/$error/g; } $body =~ s/\s+$//; $body =~ s/^\s+//; if($opt->{error_set}) { set_error($body, $opt->{error_set}); } if($opt->{error_scratch}) { $::Scratch->{$opt->{error_scratch}} = 1; } return '' if $opt->{hide}; return $body; } EOR interchange-5.7.7.orig/code/SystemTag/cgi.coretag0000644000000000000000000000225611352565025016621 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: cgi.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag cgi Order name UserTag cgi addAttr UserTag cgi PosNumber 1 UserTag cgi Version $Revision: 1.6 $ UserTag cgi Routine <{set} if defined $opt->{set}; $value = defined $CGI::values{$var} ? ($CGI::values{$var}) : ''; if ($value) { # Eliminate any Interchange tags $value =~ s~<([A-Za-z]*[^>]*\s+[Mm][Vv]\s*=\s*)~<$1~g; $value =~ s/\[/[/g; } if($opt->{filter}) { $value = filter_value($opt->{filter}, $value, $var); $CGI::values{$var} = $value unless $opt->{keep}; } return '' if $opt->{hide}; $value =~ s/{enable_html}; return $value; } EOR interchange-5.7.7.orig/code/SystemTag/charge.coretag0000644000000000000000000000122711352565025017305 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: charge.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag charge Order route UserTag charge addAttr UserTag charge PosNumber 1 UserTag charge Version $Revision: 1.5 $ UserTag charge MapRoutine Vend::Payment::charge interchange-5.7.7.orig/code/SystemTag/checked.coretag0000644000000000000000000000311111352565025017434 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: checked.coretag,v 1.9 2007-03-30 23:40:49 pajamian Exp $ UserTag checked Order name value UserTag checked addAttr UserTag checked Implicit multiple multiple UserTag checked Implicit default default UserTag checked PosNumber 2 UserTag checked Version $Revision: 1.9 $ UserTag checked Routine <{cgi} ? $CGI::values{$field} : $::Values->{$field}; return ' checked="checked"' if ! length($ref) and $opt->{default}; if(! $opt->{case}) { $ref = lc($ref); $value = lc($value); } return ' checked="checked"' if $ref eq $value; if ($opt->{delimiter}) { $opt->{multiple} = 1; } if ($opt->{multiple}) { my $be; my $ee; $opt->{delimiter} = "\0" unless defined $opt->{delimiter}; if (length $opt->{delimiter}) { my $del = Vend::Interpolate::get_joiner($opt->{delimiter}, "\0"); $be = '(?:^|' . $del . ')'; ; $ee = '(?:$|' . $del . ')'; ; } else { $be = ''; $ee = ''; } my $regex = qr/$be\Q$value\E$ee/; return ' checked="checked"' if $ref =~ $regex; } return ''; } EOR interchange-5.7.7.orig/code/SystemTag/comment.coretag0000644000000000000000000000130011352565025017506 0ustar # Copyright 2005-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: comment.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $ # This tag exists to strip out any [comment]...[/comment] blocks # that weren't caught by &Vend::Interpolate::vars_and_comments, # e.g. in reparsed output from [perl] blocks UserTag comment Version $Revision: 1.2 $ UserTag comment hasEndTag UserTag comment Routine <{space}) { $::Control = $Tmp->{$opt->{space}} ||= []; return set_tmp('control_index', 0); } else { ($::Scratch->{control_index} = 0, return) if $opt->{reset}; return set_tmp('control_index', ++$::Scratch->{control_index}); } } $name = lc $name; $name =~ s/-/_/g; $opt ||= {}; if (! defined $default and $opt->{set}) { $::Control->[$::Scratch->{control_index}]{$name} = $::Scratch->{$name}; return; } return defined $::Control->[$::Scratch->{control_index}]{$name} ? ( $::Control->[$::Scratch->{control_index}]{$name} || $default ) : ( length($::Scratch->{$name}) ? ($::Scratch->{$name}) : $default ) } EOR interchange-5.7.7.orig/code/SystemTag/control_set.coretag0000644000000000000000000000214611352565025020410 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: control_set.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag control-set Order index UserTag control-set addAttr UserTag control-set hasEndTag UserTag control-set PosNumber 1 UserTag control-set Version $Revision: 1.4 $ UserTag control-set Routine <{control_index} || 0; $inc = 1; } while($body =~ m{\[([-\w]+)\](.*)\[/\1\]}sg) { my $name = lc $1; my $val = $2; $name =~ s/-/_/g; $::Control->[$index]{$name} = $val; } $::Scratch->{control_index}++; return; } EOR interchange-5.7.7.orig/code/SystemTag/counter.coretag0000644000000000000000000000140511352565025017531 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: counter.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag counter Order file UserTag counter addAttr UserTag counter attrAlias name file UserTag counter PosNumber 1 UserTag counter Version $Revision: 1.6 $ UserTag counter MapRoutine Vend::Interpolate::tag_counter UserTag fcounter Alias counter interchange-5.7.7.orig/code/SystemTag/currency.coretag0000644000000000000000000000153311352565025017706 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: currency.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag currency Order convert noformat UserTag currency hasEndTag UserTag currency Interpolate UserTag currency addAttr UserTag currency PosNumber 2 UserTag currency Version $Revision: 1.5 $ UserTag currency Routine <{default} = !(length $default) ? 'default' : $default; return tag_value($var, $opt); } EOR interchange-5.7.7.orig/code/SystemTag/deliver.coretag0000644000000000000000000000515111535625651017513 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: deliver.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $ UserTag deliver Order type UserTag deliver HasEndTag UserTag deliver addAttr UserTag deliver Version $Revision: 1.8 $ UserTag deliver Routine <{file}) { return undef unless -f $opt->{file}; my ($tmp, %rfopt); # determine mime type devoid of explicit value $type ||= Vend::Util::mime_type($opt->{file}); # avoid encoding of binary files if ($type !~ m{^text/}i) { $rfopt{encoding} = 'raw'; } $tmp = readfile($opt->{file}, undef, undef, \%rfopt); $out = \$tmp; } elsif(ref $body) { $out = $body; } elsif(length $body) { $out = \$body; } ## This is a bounce, returns if($opt->{location}) { $type = Vend::Util::header_data_scrub($type); $opt->{status} = Vend::Util::header_data_scrub($opt->{status}); $opt->{location} = Vend::Util::header_data_scrub($opt->{location}); $type and $Tag->tag( { op => 'header', name => 'Content-Type', content => $type, } ); $Tag->tag( { op => 'header', name => 'Status', content => $opt->{status} || '302 moved', } ); $Tag->tag( { op => 'header', name => 'Location', content => $opt->{location}, } ); if(! $body) { $body = qq{Redirecting to %s.}; $body = errmsg($body, $opt->{location}, $opt->{location}); } ::response($body); $Vend::Sent = 1; return 1; } $type ||= 'application/octet-stream'; $Tag->tag( { op => 'header', name => 'Status', content => $opt->{status} } ) if $opt->{status}; $Tag->tag( { op => 'header', name => 'Content-Type', content => $type } ); if($opt->{get_encrypted}) { $opt->{get_encrypted} = 1 unless $opt->{get_encrypted} =~ /^\d+$/; my $idx = $opt->{get_encrypted}; while ($idx--) { $$out =~ s/.*?(---+BEGIN PGP MESSAGE--+)/$1/s; } $$out =~ s/(---+END PGP MESSAGE---+).*/$1\n/s; } if($opt->{extra_headers}) { my @lines = grep /\S/, split /[\r\n]+/, $opt->{extra_headers}; for(@lines) { my ($header, $val) = split /:/, $_; $Tag->tag( { op => 'header', name => $header, content => $val, } ); } } $::Pragma->{download} = 1; ::response($out); $Vend::Sent = 1; return 1; } EOR interchange-5.7.7.orig/code/SystemTag/description.coretag0000644000000000000000000000120611352565025020374 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: description.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag description Order code base UserTag description PosNumber 2 UserTag description Version $Revision: 1.4 $ UserTag description MapRoutine Vend::Data::product_description interchange-5.7.7.orig/code/SystemTag/discount.coretag0000644000000000000000000000333311352565025017704 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: discount.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $ UserTag discount Order code UserTag discount AddAttr UserTag discount attrAlias space discount_space UserTag discount hasEndTag UserTag discount PosNumber 1 UserTag discount Version $Revision: 1.7 $ UserTag discount Routine <{discount_space} and $Vend::Session->{discount} and $Vend::DiscountSpaceName)) { $::Discounts = $Vend::Session->{discount} = $Vend::Session->{discount_space}{ $Vend::DiscountSpaceName = 'main' } ||= ($Vend::Session->{discount} || {}); } my $dspace; if ($Vend::Cfg->{DiscountSpacesOn} and $dspace = $opt->{discount_space}) { $dspace = $Vend::Session->{discount_space}{$dspace} ||= {}; } else { $dspace = $::Discounts; } if($opt->{subtract}) { $value = <{subtract}; \$tmp = 0 if \$tmp < 0; return \$tmp; EOF } elsif ($opt->{level}) { $value = <{level}; my \$tmp = \$s / \$q; return \$s - \$tmp; EOF } $dspace->{$code} = $value; delete $dspace->{$code} unless defined $value and $value; return ''; } EOR interchange-5.7.7.orig/code/SystemTag/discount_space.coretag0000644000000000000000000000610411352565025021056 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: discount_space.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag discount_space Documentation <{discount}. This is fine except when you start using multiple shopping carts to represent different portions of the store and fundamentally different transactions; any common item codes will result in one cart's discounts leaking into that of the other cart... Consequently, we can use a discount space to give a different namespace to various discounts. This can be used in parallel with mv_cartname for different shopping carts. Set up a master hash of different discount namespaces in the session. Treat the default one as 'main' (like Interchange does with the cart). When discount space is called and a name is given, point the $Vend::Session->{discount} to the appropriate hashref held in this master hash. Some options: clear - this will empty the discounts for the space specified, after switching to that space. current - this will not change the namespace; it simply returns the current space name. EOF UserTag discount_space order name UserTag discount_space AttrAlias space name UserTag discount_space AddAttr UserTag discount_space Version $Revision: 1.6 $ UserTag discount_space Routine <{clear}' Current: '$opt->{current}'"); unless ($Vend::Session->{discount} and $Vend::Session->{discount_space}) { # Initialize the discount space hash, and just assign whatever's in # the current discount hash to it as the 'main' entry. # Furthermore, instantiate the discount hash if it doesn't already exist, otherwise # the linkage between that hashref and the discount_space hashref might break... #::logDebug('Tag discount-space: initializing discount_space hash; first call to this tag for this session.'); $::Discounts = $Vend::Session->{discount} = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName = 'main'} ||= ($Vend::Session->{discount} || {}); $Vend::Session->{discount_space}{main} = $Vend::Session->{discount} ||= {}; } logError('Discount-space tag called but discount spaces are deactivated in this catalog.'), return undef unless $Vend::Cfg->{DiscountSpacesOn}; return ($Vend::DiscountSpaceName ||= 'main') if $opt->{current}; $::Discounts = $Vend::Session->{discount} = $Vend::Session->{discount_space}{$namespace} ||= {}; $Vend::DiscountSpaceName = $namespace; #::logDebug("Tag discount-space: set discount space to '$namespace'"); %$::Discounts = () if $opt->{clear}; return undef; } EOF interchange-5.7.7.orig/code/SystemTag/dump.coretag0000644000000000000000000000121111352565025017012 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: dump.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag dump Order key UserTag dump addAttr UserTag dump PosNumber 1 UserTag dump Version $Revision: 1.5 $ UserTag dump MapRoutine ::full_dump interchange-5.7.7.orig/code/SystemTag/either.coretag0000644000000000000000000000152411352565025017334 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: either.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag either hasEndTag UserTag either PosNumber 0 UserTag either NoReparse 1 UserTag either Version $Revision: 1.6 $ UserTag either Routine < 1 } if ! $opt; my $ref = $Vend::Session->{errors}; if($ref->{$var} and ! $opt->{overwrite}) { $ref->{$var} .= errmsg(" AND "); } else { $ref->{$var} = ''; } $ref->{$var} .= $error; return tag_error($var, $opt); } sub tag_error { my($var, $opt) = @_; $Vend::Session->{errors} = {} unless defined $Vend::Session->{errors}; if($opt->{set}) { $opt->{keep} = 1 unless defined $opt->{keep}; my $error = delete $opt->{set}; return set_error($error, $var, $opt); } my $err_ref = $Vend::Session->{errors}; my $text; my @errors; my $found_error = ''; if($opt->{auto}) { $opt->{all} = 1; $opt->{show_error} = 1; $opt->{std_label} = 0; $opt->{show_var} = 1 unless defined $opt->{show_var}; $opt->{joiner} = '
  • ' unless length $opt->{joiner}; $opt->{text} ||= '%s'; $opt->{list_container} ||= 'ul'; my $out = ''; $out .= "<$opt->{list_container}"; for(qw/ class style extra /) { next unless $opt->{$_}; if($_ eq 'extra') { $out .= ' ' . $opt->{$_}; } else { $out .= ' ' . qq{$_="$opt->{$_}"}; } } $out .= '>'; $out .= $opt->{joiner}; $opt->{header} ||= $out; $opt->{footer} ||= "{list_container}>"; } $text = $opt->{text} if $opt->{text}; #::logDebug("tag_error: var=$var text=$text opt=" . ::uneval($opt)); #::logDebug("tag_error: var=$var text=$text"); if($opt->{all}) { $opt->{joiner} = "\n" unless defined $opt->{joiner}; for(sort keys %$err_ref) { my $err = $err_ref->{$_}; delete $err_ref->{$_} unless $opt->{keep}; next unless $err; $found_error++; my $string = ''; if ($opt->{show_label}) { if ($string = $Vend::Session->{errorlabels}{$_}) { $string =~ s/[:\s]+$//; $string .= " ($_)" if $opt->{show_var}; $string .= ": "; } else { # Use the variable name unless Locale has a default label. my $label = errmsg("error_label_${_}"); $label = $_ if $label eq "error_label_${_}"; $string .= "($label): "; } } else { $string .= "$_: " if $opt->{show_var}; } $string .= $err; push @errors, $string; } #::logDebug("error all=1 found=$found_error contents='@errors'"); return $found_error unless $text || $opt->{show_error}; $text .= "%s" if $text !~ /\%s/; $text = pull_else($text, $found_error); return '' unless @errors; @errors = map { filter_value($opt->{filter}, $_) } @errors if $opt->{filter}; my $etext = sprintf $text, join($opt->{joiner}, @errors); return join "", $opt->{header}, $etext, $opt->{footer}; } $found_error = ! (not $err_ref->{$var}); my $err = $err_ref->{$var} || ''; delete $err_ref->{$var} unless $opt->{keep}; #::logDebug("error found=$found_error contents='$err'"); return !(not $found_error) unless $opt->{std_label} || $text || $opt->{show_error}; $err = filter_value($opt->{filter}, $err) if $opt->{filter}; if($opt->{std_label}) { # store the error label in user's session for later # possible use in [error show_label=1] calls $Vend::Session->{errorlabels}{$var} = $opt->{std_label}; if($text) { # do nothing } elsif(defined $::Variable->{MV_ERROR_STD_LABEL}) { $text = $::Variable->{MV_ERROR_STD_LABEL}; } else { my $contrast = $::Variable->{CSS_CONTRAST} || 'mv_contrast'; $text = <{LABEL} (%s) [else]{REQUIRED }{LABEL}{REQUIRED }[/else] EOF } $text =~ s/{LABEL}/$opt->{std_label}/g; $text =~ s/{REQUIRED\s+([^}]*)}/$opt->{required} ? $1 : ''/ge; $err =~ s/\s+$//; } $text = '' unless defined $text; $text .= '%s' unless ($text =~ /\%s/ || length $::Variable->{MV_ERROR_STD_LABEL}); $text = pull_else($text, $found_error); $text =~ s/\%s/$err/; return $text; } sub { return tag_error(@_); } EOR interchange-5.7.7.orig/code/SystemTag/export.coretag0000644000000000000000000000140711352565025017375 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: export.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag export Order table UserTag export addAttr UserTag export attrAlias base table UserTag export attrAlias database table UserTag export PosNumber 1 UserTag export Version $Revision: 1.5 $ UserTag export MapRoutine Vend::Interpolate::export interchange-5.7.7.orig/code/SystemTag/field.coretag0000644000000000000000000000157111352565025017141 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: field.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag field Order name code UserTag field attrAlias column name UserTag field attrAlias col name UserTag field attrAlias row code UserTag field attrAlias field name UserTag field attrAlias key code UserTag field PosNumber 2 UserTag field Version $Revision: 1.4 $ UserTag field MapRoutine Vend::Data::product_field interchange-5.7.7.orig/code/SystemTag/file.coretag0000644000000000000000000000177011352565025016776 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: file.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag file Order name type UserTag file PosNumber 2 UserTag file Version $Revision: 1.6 $ UserTag file Routine <{mv_no_session_id}; return qq{}; } EOR interchange-5.7.7.orig/code/SystemTag/handling.coretag0000644000000000000000000000156311352565025017643 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: handling.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag handling Order mode UserTag handling addAttr UserTag handling attrAlias tables table UserTag handling attrAlias carts cart UserTag handling attrAlias modes mode UserTag handling attrAlias name mode UserTag handling PosNumber 1 UserTag handling Version $Revision: 1.5 $ UserTag handling MapRoutine Vend::Interpolate::tag_handling interchange-5.7.7.orig/code/SystemTag/harness.coretag0000644000000000000000000000251611352565025017521 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: harness.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag harness addAttr UserTag harness hasEndTag UserTag harness PosNumber 0 UserTag harness Version $Revision: 1.4 $ UserTag harness Routine <{expected} || 'OK'; $input =~ s:^\s+::; $input =~ s:\s+$::; $input =~ s:\s*\[expected\](.*)\[/expected\]\s*::s and $expected = $1; $input =~ s:\[not\](.*)\[/not\]::s and $not = $1; my $name = $Test++; $name = $opt->{name} if defined $opt->{name}; my $result; eval { $result = Vend::Interpolate::interpolate_html($input); }; if($@) { my $msg = "DIED in test $name. \$\@: $@"; #::logDebug($msg); return $msg; } if($expected) { return "NOT OK $name: $result!=$expected" unless $result =~ /$expected/; } if($not) { return "NOT OK $name: $result==$not" unless $result !~ /$not/; } return "OK $name"; } EOR interchange-5.7.7.orig/code/SystemTag/html_table.coretag0000644000000000000000000000123211352565025020163 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: html_table.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag html-table addAttr UserTag html-table hasEndTag UserTag html-table PosNumber 0 UserTag html-table Version $Revision: 1.4 $ UserTag html-table MapRoutine Vend::Interpolate::html_table interchange-5.7.7.orig/code/SystemTag/image.tag0000644000000000000000000001657111542522521016270 0ustar # Copyright 2002-2011 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. UserTag image Order src UserTag image AttrAlias geometry makesize UserTag image AttrAlias resize makesize UserTag image AddAttr UserTag image Version 1.25 UserTag image Routine <{descriptionfields} || $::Variable->{DESCRIPTIONFIELDS} || $Vend::Cfg->{DescriptionField}; @descriptionfields = qw( description ) if ! @descriptionfields; my @imagefields = grep /\S/, split /\s+/, $opt->{imagefields} || $::Variable->{IMAGEFIELDS}; @imagefields = qw( image ) if ! @imagefields; my @imagesuffixes = qw( jpg gif png jpeg ); my $filere = qr/\.\w{2,4}$/; my $absurlre = qr!^(?i:https?)://!; if ($opt->{ui}) { # unless no image dir specified, add locale string my $locale = $Scratch->{mv_locale} ? $Scratch->{mv_locale} : 'en_US'; $imagedir = $::Variable->{UI_IMAGE_DIR} || $Global::Variable->{UI_IMAGE_DIR}; $imagedirsecure = $::Variable->{UI_IMAGE_DIR} || $Global::Variable->{UI_IMAGE_DIR}; for ($imagedir, $imagedirsecure) { if ($_) { $_ .= '/' if substr($_, -1, 1) ne '/'; $_ .= $locale . '/'; } } } else { $imagedir = $Vend::Cfg->{ImageDir}; $imagedirsecure = $Vend::Cfg->{ImageDirSecure} || $imagedir ; } # make sure there's a trailing slash on directories for ($imagedir, $imagedirsecure) { $_ .= '/' if $_ and substr($_, -1, 1) ne '/'; } if (defined $opt->{secure}) { $secure = $opt->{secure} ? 1 : 0; } else { $secure = $CGI::secure; } $imagedircurrent = $secure ? $imagedirsecure : $imagedir; return $imagedircurrent if $opt->{dir_only}; $opt->{getsize} = 1 unless defined $opt->{getsize} or (defined($opt->{height}) and defined($opt->{width})); $opt->{imagesubdir} ||= $::Scratch->{mv_imagesubdir} if defined $::Scratch->{mv_imagesubdir}; $opt->{default} ||= $::Scratch->{mv_imagedefault} if defined $::Scratch->{mv_imagedefault}; if ($opt->{sku}) { $sku = $opt->{sku}; } else { # assume src option is a sku if it doesn't look like a filename if ($src !~ /$filere/) { $sku = $src; undef $src; } } if($opt->{name_only} and $src) { my $ret = $src =~ /$absurlre/ ? $src : "$imagedircurrent$src"; $ret =~ s/%(?!25)/%25/g; return $ret; } if ($src =~ /$absurlre/) { # we have no way to check validity or create/read sizes of full URLs, # so we just assume they're good $image = $src; } else { my @srclist; push @srclist, $src if $src; if ($sku) { # check all products tables for image fields for ( @{$Vend::Cfg->{ProductFiles}} ) { my $db = Vend::Data::database_exists_ref($_) or die "Bad database $_?"; $db = $db->ref(); my $view = $db->row_hash($sku) if $db->record_exists($sku); if (ref $view eq 'HASH') { for (@imagefields) { push @srclist, $view->{$_} if $view->{$_}; } # grab product description for alt attribute unless (defined $opt->{alt}) { for (@descriptionfields) { ($opt->{alt} = $view->{$_}, last) if $view->{$_}; } } } } } push @srclist, $sku if $sku; push @srclist, $opt->{default} if $opt->{default}; if ($opt->{imagesubdir}) { $opt->{imagesubdir} .= '/' unless $opt->{imagesubdir} =~ m:/$:; } my $dr = $::Variable->{DOCROOT}; my $id = $imagedircurrent; $id =~ s:/+$::; $id =~ s:/~[^/]+::; IMAGE_EXISTS: for my $try (@srclist) { ($image = $try, last) if $try =~ /$absurlre/; $try = $opt->{imagesubdir} . $try; my @trylist; if ($try and $try !~ /$filere/) { @trylist = map { "$try.$_" } @imagesuffixes; } else { @trylist = ($try); } for (@trylist) { if ($id and m{^[^/]}) { if ($opt->{force} or ($dr and -f "$dr$id/$_")) { $image = $_; $path = "$dr$id/$_"; } } elsif (m{^/}) { if ($opt->{force} or ($dr and -f "$dr/$_")) { $image = $_; $path = "$dr/$_"; } } last IMAGE_EXISTS if $image; } } return unless $image; return 1 if $opt->{exists_only}; my $mask; if($opt->{makesize} and $path) { my $dir = $path; $dir =~ s:/([^/]+$)::; my $fn = $1; my $siz = $opt->{makesize}; MOGIT: { # Support complete mogrify -geometry syntax # This matches: AxB, A or xB, followed by 0, 1, or 2 [+-]number # specs, followed by none or one of @!%><. $siz =~ m{^(()|\d+())(x\d+\3|x\d+\2|\3)([+-]\d+){0,2}([@!%><])?$} or do { logError("%s: Unable to make image with bad size '%s'", 'image tag', $siz); last MOGIT; }; (my $siz_path = $siz) =~ s:[^\dx]::g; $dir .= "/$siz_path"; my $newpath = "$dir/$fn"; if(-f $newpath) { if($opt->{check_date}) { my $mod1 = -M $newpath; my $mod2 = -M $path; unless ($mod2 < $mod1) { $image =~ s:(/?)([^/]+$):$1$siz_path/$2:; $path = $newpath; last MOGIT; } } else { $image =~ s:(/?)([^/]+$):$1$siz_path/$2:; $path = $newpath; last MOGIT; } } $mask = umask(02); unless(-d $dir) { File::Path::mkpath($dir); } my $mgkpath = $newpath; my $ext; $mgkpath =~ s/\.(\w+)$/.mgk/ and $ext = $1; File::Copy::copy($path, $newpath) or do { logError("%s: Unable to create image '%s'", 'image tag', $newpath); last MOGIT; }; my $exec = $Global::Variable->{IMAGE_MOGRIFY}; if(! $exec) { my @dirs = split /:/, "/usr/X11R6/bin:$ENV{PATH}"; for(@dirs) { next unless -x "$_/mogrify"; $exec = "$_/mogrify"; $Global::Variable->{IMAGE_MOGRIFY} = $exec; last; } } last MOGIT unless $exec; system qq{$exec -geometry "$siz" '$newpath'}; if($?) { logError("%s: Unable to mogrify image '%s'", 'image tag', $newpath); last MOGIT; } if(-f $mgkpath) { rename $mgkpath, $newpath or die "Could not overwrite image with new one!"; } $image =~ s:(/?)([^/]+$):$1$siz_path/$2:; $path = $newpath; } } umask($mask) if defined $mask; if ($opt->{getsize} and $path) { eval { require Image::Size; my ($width, $height) = Image::Size::imgsize($path); $opt->{height} = $height if defined($height) and not exists($opt->{height}); $opt->{width} = $width if defined($width) and not exists($opt->{width}); if ($opt->{size_scratch_prefix}) { Vend::Interpolate::set_tmp($opt->{size_scratch_prefix} . '_' . $_, $opt->{$_}) for qw/width height/; } }; } } $image = $imagedircurrent . $image unless $image =~ /$absurlre/ or substr($image, 0, 1) eq '/'; $image =~ s/%(?!25)/%25/g; return $image if $opt->{src_only}; $opt->{title} = $opt->{alt} if ! defined $opt->{title} and $opt->{alt}; my $opts = ''; for (qw: width height alt title border hspace vspace align valign style class name id :) { if (defined $opt->{$_}) { my $val = $opt->{$_}; $val = HTML::Entities::encode($val) if $val =~ /\W/; $opts .= qq{ $_="$val"}; } } if($opt->{extra}) { $opts .= " $opt->{extra}"; } $image =~ s/"/"/g; return qq{}; } EOR interchange-5.7.7.orig/code/SystemTag/import.coretag0000644000000000000000000000153011352565025017363 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: import.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag import Order table type UserTag import addAttr UserTag import attrAlias base table UserTag import attrAlias database table UserTag import hasEndTag UserTag import Interpolate UserTag import PosNumber 2 UserTag import Version $Revision: 1.5 $ UserTag import MapRoutine Vend::Data::import_text interchange-5.7.7.orig/code/SystemTag/include.coretag0000644000000000000000000000217711352565025017504 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: include.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $ UserTag include Order file locale UserTag include PosNumber 2 UserTag include Version $Revision: 1.8 $ UserTag include Routine <{include_depth} ||= 0; my $limit = $Vend::Cfg->{Limit}{include_depth} || 10; if($::Instance->{include_depth}++ >= $limit) { logOnce( 'error', "Depth of include (%s) exceeds limit of %s for file %s.", $::Instance->{include_depth}, $limit, $file, ); return; } my $out = Vend::Interpolate::interpolate_html( Vend::Util::readfile($file, undef, $locale) ); $::Instance->{include_depth}--; return $out; } EOR interchange-5.7.7.orig/code/SystemTag/index.coretag0000644000000000000000000000140711352565025017163 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: index.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag index Order table UserTag index addAttr UserTag index attrAlias base table UserTag index attrAlias database table UserTag index PosNumber 1 UserTag index Version $Revision: 1.5 $ UserTag index MapRoutine Vend::Data::index_database interchange-5.7.7.orig/code/SystemTag/input_filter.coretag0000644000000000000000000000154511352565025020563 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: input_filter.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag input-filter Order name UserTag input-filter addAttr UserTag input-filter attrAlias var name UserTag input-filter attrAlias variable name UserTag input-filter attrAlias ops op UserTag input-filter hasEndTag UserTag input-filter PosNumber 1 UserTag input-filter Version $Revision: 1.5 $ UserTag input-filter MapRoutine Vend::Interpolate::input_filter interchange-5.7.7.orig/code/SystemTag/item_list.coretag0000644000000000000000000000264411352565025020051 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: item_list.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $ UserTag item-list Order name UserTag item-list addAttr UserTag item-list attrAlias cart name UserTag item-list attrAlias space discount_space UserTag item-list hasEndTag UserTag item-list Version $Revision: 1.7 $ UserTag item-list Routine <{$cart} ||= []) : $Vend::Items; my $oldspace; $oldspace = Vend::Interpolate::switch_discount_space($opt->{discount_space}) if defined $opt->{discount_space}; $items = [ reverse @$items ] if $opt->{reverse}; my $obj = { mv_results => $items }; $opt->{prefix} = 'item' unless defined $opt->{prefix}; # LEGACY list_compat($opt->{prefix}, \$text); # END LEGACY # store the output temporarily, as we need to switch back to the old discount space... my $output = labeled_list($opt, $text, $obj); Vend::Interpolate::switch_discount_space($oldspace) if defined $oldspace; return $output; } EOR interchange-5.7.7.orig/code/SystemTag/levies.coretag0000644000000000000000000000144011352565025017340 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: levies.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag levies Order group UserTag levies addAttr UserTag levies PosNumber 1 UserTag levies Version $Revision: 1.5 $ UserTag levies Routine <{recalculate}, $opt->{cart}, $opt); return $cost unless $opt->{hide}; return ''; } EOR interchange-5.7.7.orig/code/SystemTag/levy_list.coretag0000644000000000000000000000201011352565025020055 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: levy_list.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag levy-list Order name UserTag levy-list addAttr UserTag levy-list attrAlias cart name UserTag levy-list hasEndTag UserTag levy-list Version $Revision: 1.5 $ UserTag levy-list Routine <{levies} ||= {}; my $obj = { mv_results => $cart ? ($lev->{$cart} ||= [] ) : ($lev->{$Vend::CurrentCart || 'main'} ||= [] ) }; return if ! $text; $opt->{prefix} = 'levy' unless defined $opt->{prefix}; return labeled_list($opt, $text, $obj); } EOR interchange-5.7.7.orig/code/SystemTag/local.coretag0000644000000000000000000000604411352565025017150 0ustar # Copyright 2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: local.coretag,v 1.2 2007-08-09 13:40:52 pajamian Exp $ UserTag local Order scratch UserTag local attrAlias scratches scratch UserTag local attrAlias value values UserTag local posNumber 1 UserTag local hasEndTag UserTag local addAttr UserTag local Description Tag to localize scratch and/or values for block UserTag local Routine <{extra}; for my $top (qw/ values scratch /, @extra) { exists $Vend::Session->{$top} or do { $delete_top{$top} = 1; next; }; my $v = $Vend::Session->{$top}; unless (ref($v) eq 'HASH') { if(! ref $v) { $settings{$top} = $v; } else { $settings{$top} = dclone($v); } next; } my @values = Text::ParseWords::shellwords($opt->{$top}); for(@values) { if( ! exists $v->{$_}) { $delete{$top}{$_} = 1; } elsif(! ref $v->{$_}) { $settings{$top}{$_} = $v->{$_}; } else { $settings{$top}{$_} = dclone($v->{$_}); } } } my $result = interpolate_html($body); for my $top (qw/ values scratch /, @extra) { if(my $d = $delete_top{$top}) { delete $Vend::Session->{$top}; next; } unless (ref($settings{$top}) eq 'HASH') { $Vend::Session->{$top} = $settings{$top}; next; } my $s = $settings{$top}; my $d = $delete{$top}; my $v = $Vend::Session->{$top}; for(keys %$d) { delete $v->{$_}; } for(keys %$s) { $v->{$_} = $settings{$top}{$_}; } } return $result; } EOR UserTag local Documentation <{raw}) { if (ref $opt->{arg} eq 'ARRAY') { @args = @{ $opt->{arg} }; } elsif (ref $opt->{arg} eq 'HASH') { @args = map { $opt->{arg}->{$_} } sort keys %{ $opt->{arg} }; } elsif (! ref $opt->{arg}) { @args = $opt->{arg}; } } if ($opt->{locale}) { # we only mess with scratch mv_locale because # Vend::Util::find_locale_bit uses it to determine current locale $startlocale = $::Scratch->{mv_locale}; Vend::Util::setlocale($opt->{locale}, undef, { persist => 1 }); } if ($opt->{inline}) { $message = Vend::Util::find_locale_bit($body); } else { $message = $body; } if ($key) { if ($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$key}) { $message = $Vend::Cfg->{Locale}{$key}; } elsif ($Global::Locale and defined $Global::Locale->{$key}) { $message = $Global::Locale->{$key}; } } if ($opt->{raw}) { $out = $message; } else { $out = errmsg($message, @args); } if ($opt->{locale}) { $::Scratch->{mv_locale} = $startlocale; Vend::Util::setlocale(); } return $out; } EOR interchange-5.7.7.orig/code/SystemTag/mvasp.coretag0000644000000000000000000000147711352565025017211 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: mvasp.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag mvasp Order tables UserTag mvasp addAttr UserTag mvasp attrAlias table tables UserTag mvasp Gobble UserTag mvasp hasEndTag UserTag mvasp PosNumber 1 UserTag mvasp NoReparse UserTag mvasp Version $Revision: 1.5 $ UserTag mvasp MapRoutine Vend::Interpolate::mvasp interchange-5.7.7.orig/code/SystemTag/nitems.coretag0000644000000000000000000000122711352565025017353 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: nitems.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag nitems Order name UserTag nitems addAttr UserTag nitems PosNumber 1 UserTag nitems Version $Revision: 1.5 $ UserTag nitems MapRoutine Vend::Util::tag_nitems interchange-5.7.7.orig/code/SystemTag/onfly.coretag0000644000000000000000000000123311352565025017200 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: onfly.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag onfly Order code quantity UserTag onfly addAttr UserTag onfly PosNumber 2 UserTag onfly Version $Revision: 1.4 $ UserTag onfly MapRoutine Vend::Order::onfly interchange-5.7.7.orig/code/SystemTag/options.coretag0000644000000000000000000000123411352565025017545 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: options.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag options Order code UserTag options addAttr UserTag options PosNumber 1 UserTag options Version $Revision: 1.5 $ UserTag options MapRoutine Vend::Options::tag_options interchange-5.7.7.orig/code/SystemTag/order.coretag0000644000000000000000000000367611352565025017201 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: order.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $ UserTag order Order code quantity UserTag order attrAlias item code UserTag order attrAlias sku code UserTag order attrAlias table base UserTag order attrAlias database base UserTag order attrAlias db base UserTag order attrAlias mv_ib base UserTag order attrAlias href page UserTag order attrAlias variant mv_sku UserTag order addAttr UserTag order PosNumber 2 UserTag order Version $Revision: 1.7 $ UserTag order Routine <{base}") if($opt->{base}); push(@parms, "mv_cartname=$opt->{cart}") if($opt->{cart}); push(@parms, "mv_order_quantity=$quantity") if($quantity); push @parms, "mv_sku=$opt->{mv_sku}" if $opt->{mv_sku}; $opt->{form} .= "\n" . join "\n", @parms; $opt->{page} = find_special_page('order') unless $opt->{page}; if ($opt->{area}) { return tag_area($opt->{page}, $opt->{arg}, $opt); } else { return tag_page($opt->{page}, $opt->{arg}, $opt); } } EOR interchange-5.7.7.orig/code/SystemTag/output_to.tag0000644000000000000000000000140211352565025017240 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: output_to.tag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag output-to Order name UserTag output-to addAttr UserTag output-to hasEndTag UserTag output-to Version $Revision: 1.4 $ UserTag output-to Routine <{code} ||= $code; my $oldspace; $oldspace = Vend::Interpolate::switch_discount_space($ref->{discount_space}) if defined $ref->{discount_space}; my $amount = Vend::Data::item_price($ref); $amount = discount_price($code, $amount, $ref->{quantity}) if $ref->{discount}; Vend::Interpolate::switch_discount_space($oldspace) if defined $oldspace; return currency( $amount, $ref->{noformat}, undef, $ref ); } EOR interchange-5.7.7.orig/code/SystemTag/process.coretag0000644000000000000000000000346111352565025017534 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: process.coretag,v 1.13 2007-10-31 11:25:53 kwalsh Exp $ UserTag process-target Alias process UserTag process-order Alias process UserTag process Order target secure UserTag process addAttr UserTag process Version $Revision: 1.13 $ UserTag process Routine <{href} || $Vend::Cfg->{ProcessPage}; $opt->{add_dot_html} = $::Scratch->{mv_add_dot_html} unless defined $opt->{add_dot_html}; if($opt->{download_name}) { $page .= "/$opt->{download_name}"; } elsif (Vend::Util::is_yes($opt->{add_dot_html})) { $page .= '.html' unless $page =~ m{(?:/|\.html?)$}; } my $url; if($secure) { $url = $Vend::Cfg->{SecurePostURL} || $Vend::Cfg->{SecureURL}; } else { $url = $Vend::Cfg->{PostURL} || $Vend::Cfg->{VendURL}; } $url =~ s,/*$,/,; $url .= $page; if($Global::TolerateGet and ! $opt->{no_session}) { my @args; push @args, "$::VN->{mv_session_id}=$Vend::SessionID" unless $::Scratch->{no_session_id}; push @args, "$::VN->{mv_pc}=" . ++$Vend::Session->{pageCount} unless $::Scratch->{no_count}; push @args, "$::VN->{mv_cat}=" . ++$Vend::Cat if $Vend::VirtualCat; if(@args) { $url .= '?'; $url .= join($Global::UrlJoiner, @args); } } return $url unless $target; return qq{$url" target="$target}; } EOR interchange-5.7.7.orig/code/SystemTag/profile.coretag0000644000000000000000000000124011352565025017507 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: profile.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag profile Order name UserTag profile addAttr UserTag profile PosNumber 1 UserTag profile Version $Revision: 1.5 $ UserTag profile MapRoutine Vend::Interpolate::tag_profile interchange-5.7.7.orig/code/SystemTag/query.coretag0000644000000000000000000000136111352565025017220 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: query.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag query Order sql UserTag query addAttr UserTag query attrAlias base table UserTag query hasEndTag UserTag query PosNumber 1 UserTag query Version $Revision: 1.4 $ UserTag query MapRoutine Vend::Interpolate::query interchange-5.7.7.orig/code/SystemTag/read_cookie.coretag0000644000000000000000000000111611352565025020315 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: read_cookie.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag read-cookie Order name UserTag read-cookie Version $Revision: 1.5 $ UserTag read-cookie MapRoutine Vend::Util::read_cookie interchange-5.7.7.orig/code/SystemTag/record.coretag0000644000000000000000000000316411352565025017334 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: record.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag record addAttr UserTag record attrAlias column col UserTag record attrAlias code key UserTag record attrAlias field col UserTag record PosNumber 0 UserTag record Version $Revision: 1.4 $ UserTag record Routine <{table}}; return undef if ! $db; $db = $db->ref(); # This can be called from Perl my (@cols, @vals); my $hash = $opt->{col}; my $filter = $opt->{filter}; return undef unless defined $opt->{key}; my $key = $opt->{key}; return undef unless ref $hash; undef $filter unless ref $filter; @cols = keys %$hash; @vals = values %$hash; RESOLVE: { my $i = -1; for(@cols) { $i++; if(! defined $db->test_column($_) ) { splice (@cols, $i, 1); my $tmp = splice (@vals, $i, 1); ::logError("bad field %s in record update, value=%s", $_, $tmp); redo RESOLVE; } next unless defined $filter->{$_}; $vals[$i] = filter_value($filter->{$_}, $vals[$i], $_); } } my $status; eval { my $status = $db->set_slice($key, \@cols, \@vals); }; if($@) { return $@ if $opt->{show_error}; } return $status; } EOR interchange-5.7.7.orig/code/SystemTag/region.coretag0000644000000000000000000000145411352565025017341 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: region.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag region addAttr UserTag region attrAlias args arg UserTag region attrAlias params arg UserTag region attrAlias search arg UserTag region hasEndTag UserTag region PosNumber 0 UserTag region Version $Revision: 1.4 $ UserTag region MapRoutine Vend::Interpolate::region interchange-5.7.7.orig/code/SystemTag/row.coretag0000644000000000000000000001040511535625651016666 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: row.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag row Order width UserTag row hasEndTag UserTag row Interpolate UserTag row PosNumber 1 UserTag row Version $Revision: 1.4 $ UserTag row Routine <'"] + | ".*?" | '.*?' ) + > }{}gsx; } return length($txt); }; $usable = $spec{'width'} - $spec{'gutter'}; return "BAD_WIDTH" if $usable < 1; if($spec{'align'} =~ /^[ln]/i) { $f = sub { $_[0] . ' ' x ($usable - $len->($_[0])) . ' ' x $spec{'gutter'}; }; } elsif($spec{'align'} =~ /^r/i) { $f = sub { ' ' x ($usable - $len->($_[0])) . $_[0] . ' ' x $spec{'gutter'}; }; } elsif($spec{'align'} =~ /^i/i) { $spec{'wrap'} = 0; $usable = 9999; $f = sub { @_ }; } else { return "BAD JUSTIFICATION SPECIFICATION: $spec{'align'}"; } $append = ''; if($spec{'spacing'} > 1) { $append .= "\n" x ($spec{'spacing'} - 1); } if($spec{'align'} =~ /^n/i) { @lines = split(/\r?\n/, $text); } elsif(is_yes($spec{'wrap'}) and length($text) > $usable) { @lines = wrap($text,$usable); } elsif($spec{'align'} =~ /^i/i) { $lines[0] = ' ' x $spec{'width'}; $lines[1] = $text . ' ' x $spec{'gutter'}; } elsif (! $spec{'html'}) { $lines[0] = substr($text,0,$usable); } foreach $line (@lines) { push @out , &{$f}($line); for($i = 1; $i < $spec{'spacing'}; $i++) { push @out, ''; } } @out; } sub wrap { my ($str, $width) = @_; my @a = (); my ($l, $b); for (;;) { $str =~ s/^ +//; $l = length($str); last if $l == 0; if ($l <= $width) { push @a, $str; last; } $b = rindex($str, " ", $width - 1); if ($b == -1) { push @a, substr($str, 0, $width); $str = substr($str, $width); } else { push @a, substr($str, 0, $b); $str = substr($str, $b + 1); } } return @a; } sub { my($width,$text) = @_; my($col,$spec); my(@lines); my(@len); my(@out); my($i,$j,$k); my($x,$y,$line); $i = 0; while( $text =~ s!\[col(?:umn)?\s+ ([^\]]+) \] ((?s:.)*?) \[/col(?:umn)?\] !!ix ) { $spec = $1; $col = $2; $lines[$i] = []; @{$lines[$i]} = tag_column($spec,$col); # Discover X dimension $len[$i] = length(${$lines[$i]}[0]); if(defined ${$lines[$i]}[1] and ${$lines[$i]}[1] =~ /^<\s*input\s+/i) { shift @{$lines[$i]}; } $i++; } my $totlen = 0; for(@len) { $totlen += $_ } if ($totlen > $width) { return " B A D R O W S P E C I F I C A T I O N - columns too wide.\n" } # Discover y dimension $j = $#{$lines[0]}; for ($k = 1; $k < $i; $k++) { $j = $#{$lines[$k]} > $j ? $#{$lines[$k]} : $j; } for($y = 0; $y <= $j; $y++) { $line = ''; for($x = 0; $x < $i; $x++) { if(defined ${$lines[$x]}[$y]) { $line .= ${$lines[$x]}[$y]; $line =~ s/\s+$// if ($i - $x) == 1; } elsif (($i - $x) > 1) { $line .= ' ' x $len[$x]; } else { $line =~ s/\s+$//; } } push @out, $line; } join "\n", @out; } EOR interchange-5.7.7.orig/code/SystemTag/salestax.coretag0000644000000000000000000000156211352565025017702 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: salestax.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $ UserTag salestax Order name noformat UserTag salestax attrAlias cart name UserTag salestax attrAlias space discount_space UserTag salestax addAttr UserTag salestax PosNumber 2 UserTag salestax Version $Revision: 1.8 $ UserTag salestax Routine <{$var}; if($opt->{filter}) { $value = filter_value($opt->{filter}, $value, $var); $::Scratch->{$var} = $value unless $opt->{keep}; } return $value; } EOR interchange-5.7.7.orig/code/SystemTag/scratchd.coretag0000644000000000000000000000146411352565025017652 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: scratchd.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag scratchd Order name UserTag scratchd PosNumber 1 UserTag scratchd addAttr UserTag scratchd Version $Revision: 1.6 $ UserTag scratchd Routine <{$var}; if ($opt->{filter}) { $value = filter_value($opt->{filter}, $value, $var); } return $value; } EOR interchange-5.7.7.orig/code/SystemTag/search.coretag0000644000000000000000000000105311535625651017323 0ustar # Copyright 2002-2009 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. UserTag search Order search UserTag search addAttr UserTag search Version $Revision: 1.5 $ UserTag search MapRoutine Vend::Page::do_search interchange-5.7.7.orig/code/SystemTag/search_region.coretag0000644000000000000000000000155311352565025020666 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: search_region.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag search-region Order arg UserTag search-region addAttr UserTag search-region attrAlias args arg UserTag search-region attrAlias params arg UserTag search-region attrAlias search arg UserTag search-region hasEndTag UserTag search-region PosNumber 0 UserTag search-region Version $Revision: 1.4 $ UserTag search-region MapRoutine Vend::Interpolate::tag_search_region interchange-5.7.7.orig/code/SystemTag/selected.coretag0000644000000000000000000000311611352565025017643 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: selected.coretag,v 1.9 2007-03-30 23:40:49 pajamian Exp $ UserTag selected Order name value UserTag selected addAttr UserTag selected PosNumber 2 UserTag selected Version $Revision: 1.9 $ UserTag selected Routine <{cgi} ? $CGI::values{$field} : $::Values->{$field}; return ' selected="selected"' if ! length($ref) and $opt->{default}; if(! $opt->{case}) { $ref = lc($ref); $value = lc($value); } my $r = ''; return ' selected="selected"' if $ref eq $value; if ($opt->{delimiter}) { $opt->{multiple} = 1; } if ($opt->{multiple}) { my $be; my $ee; $opt->{delimiter} = "\0" unless defined $opt->{delimiter}; if (length $opt->{delimiter}) { my $del = Vend::Interpolate::get_joiner($opt->{delimiter}, "\0"); $be = '(?:^|' . $del . ')'; ; $ee = '(?:$|' . $del . ')'; ; } else { $be = ''; $ee = ''; } my $regex = qr/$be\Q$value\E$ee/; return ' selected="selected"' if $ref =~ $regex; } return ''; } EOR interchange-5.7.7.orig/code/SystemTag/set.coretag0000644000000000000000000000123611352565025016647 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: set.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag set Order name UserTag set hasEndTag UserTag set PosNumber 1 UserTag set Version $Revision: 1.5 $ UserTag set MapRoutine Vend::Interpolate::set_scratch interchange-5.7.7.orig/code/SystemTag/set_cookie.coretag0000644000000000000000000000114711535625651020206 0ustar # Copyright 2002-2008 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: set_cookie.coretag,v 1.7 2008-09-13 04:28:56 jon Exp $ UserTag set-cookie Order name value expire domain path secure UserTag set-cookie Version $Revision: 1.7 $ UserTag set-cookie MapRoutine Vend::Util::set_cookie interchange-5.7.7.orig/code/SystemTag/seti.coretag0000644000000000000000000000130711352565025017017 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: seti.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag seti Order name UserTag seti hasEndTag UserTag seti Interpolate UserTag seti PosNumber 1 UserTag seti Version $Revision: 1.5 $ UserTag seti MapRoutine Vend::Interpolate::set_scratch interchange-5.7.7.orig/code/SystemTag/setlocale.coretag0000644000000000000000000000124411352565025020026 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: setlocale.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag setlocale Order locale currency UserTag setlocale addAttr UserTag setlocale PosNumber 2 UserTag setlocale Version $Revision: 1.4 $ UserTag setlocale MapRoutine Vend::Util::setlocale interchange-5.7.7.orig/code/SystemTag/shipping.coretag0000644000000000000000000000155411352565025017700 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: shipping.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag shipping Order mode UserTag shipping addAttr UserTag shipping attrAlias tables table UserTag shipping attrAlias carts cart UserTag shipping attrAlias modes mode UserTag shipping attrAlias name mode UserTag shipping PosNumber 1 UserTag shipping Version $Revision: 1.5 $ UserTag shipping MapRoutine Vend::Ship::tag_shipping interchange-5.7.7.orig/code/SystemTag/shipping_desc.coretag0000644000000000000000000000122011352565025020664 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: shipping_desc.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $ UserTag shipping-description Alias shipping-desc UserTag shipping-desc Order mode key UserTag shipping-desc Version $Revision: 1.6 $ UserTag shipping-desc MapRoutine Vend::Ship::tag_shipping_desc interchange-5.7.7.orig/code/SystemTag/soap.coretag0000644000000000000000000000145711352565025017023 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: soap.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $ UserTag soap Order call uri proxy UserTag soap addAttr UserTag soap PosNumber 3 UserTag soap Version $Revision: 1.6 $ UserTag soap MapRoutine Vend::SOAP::tag_soap UserTag soap_entity addAttr UserTag soap_entity Version $Revision: 1.6 $ UserTag soap_entity MapRoutine Vend::SOAP::tag_soap_entity interchange-5.7.7.orig/code/SystemTag/strip.coretag0000644000000000000000000000123311352565025017212 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: strip.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag strip hasEndTag UserTag strip PosNumber 0 UserTag strip Version $Revision: 1.4 $ UserTag strip Routine <{discount_space}, $opt->{nodiscount}), $noformat, undef, $opt); } EOR interchange-5.7.7.orig/code/SystemTag/tag.coretag0000644000000000000000000000137011352565025016626 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: tag.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag tag Order op arg UserTag tag addAttr UserTag tag attrAlias description arg UserTag tag hasEndTag UserTag tag PosNumber 2 UserTag tag Version $Revision: 1.4 $ UserTag tag MapRoutine Vend::Interpolate::do_tag interchange-5.7.7.orig/code/SystemTag/time.coretag0000644000000000000000000000130011352565025017002 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: time.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag time Order locale UserTag time addAttr UserTag time hasEndTag UserTag time PosNumber 1 UserTag time Version $Revision: 1.4 $ UserTag time MapRoutine Vend::Interpolate::mvtime interchange-5.7.7.orig/code/SystemTag/timed_build.coretag0000644000000000000000000000135511352565025020337 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: timed_build.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag timed-build Order file UserTag timed-build addAttr UserTag timed-build Gobble UserTag timed-build hasEndTag UserTag timed-build PosNumber 1 UserTag timed-build Version $Revision: 1.4 $ UserTag timed-build MapRoutine Vend::Interpolate::timed_build interchange-5.7.7.orig/code/SystemTag/tmp.coretag0000644000000000000000000000130211352565025016646 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: tmp.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag tmp Order name UserTag tmp hasEndTag UserTag tmp Interpolate UserTag tmp PosNumber 1 UserTag tmp Version $Revision: 1.5 $ UserTag tmp MapRoutine Vend::Interpolate::set_tmp interchange-5.7.7.orig/code/SystemTag/tmpn.coretag0000644000000000000000000000123311352565025017027 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: tmpn.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag tmpn Order name UserTag tmpn hasEndTag UserTag tmpn PosNumber 1 UserTag tmpn Version $Revision: 1.5 $ UserTag tmpn MapRoutine Vend::Interpolate::set_tmp interchange-5.7.7.orig/code/SystemTag/total_cost.coretag0000644000000000000000000000160311352565025020225 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: total_cost.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $ UserTag total-cost Order name noformat UserTag total-cost attrAlias cart name UserTag total-cost attrAlias space discount_space UserTag total-cost PosNumber 2 UserTag total-cost addAttr UserTag total-cost Version $Revision: 1.7 $ UserTag total-cost Routine <{discount_space}), $noformat, undef, $opt); } EOR interchange-5.7.7.orig/code/SystemTag/tree.coretag0000644000000000000000000001672711352565025017026 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: tree.coretag,v 1.12 2007-07-18 00:16:26 jon Exp $ UserTag tree Order table master subordinate start UserTag tree addAttr UserTag tree attrAlias sub subordinate UserTag tree hasEndTag UserTag tree Version $Revision: 1.12 $ UserTag tree Routine <{file}) { my $delim = $opt->{delimiter} || "\t"; my $s = $opt->{subordinate} || 'code'; my $l = $opt->{level_field} || 'msort'; $delim = qr/$delim/; my @lines = split /\n/, readfile($opt->{file}); my $hdr = shift @lines; my @fields = split $delim, $hdr; my $i = 1; for(@lines) { my $ref = {}; @{$ref}{@fields} = split $delim, $_; $ref->{$s} = $i++; push @passed, $ref; push @start, $ref if $ref->{$l} == 0; } $nodb = 1; } my $db; unless($nodb) { $db = ::database_exists_ref($table) or return error_opt($opt, "Database %s doesn't exist", $table); $db->column_exists($parent) or return error_opt($opt, "Parent column %s doesn't exist", $parent); $db->column_exists($sub) or return error_opt($opt, "Subordinate column %s doesn't exist", $sub); } my $basewhere; WHEREBASE: { my @keys; my @things; if($opt->{multiple_start}) { @keys = split /[\0,\s]+/, $start_item; } else { @keys = $start_item; } unless($nodb) { for(@keys) { push @things, "$parent = " . $db->quote($_, $parent); } } $basewhere = join " OR ", @things; } my @outline = (1); if(defined $opt->{outline}) { $opt->{outline} =~ s/[^a-zA-Z0-9]+//g; @outline = split //, $opt->{outline}; @outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2; } my $mult = ( int($opt->{spacing}) || 10 ); my $keyfield; $keyfield = $db->config('KEY') unless $nodb; $opt->{code_field} = $keyfield if ! $opt->{code_field}; my $sort = ''; if($opt->{sort}) { $sort .= ' '; $sort .= 'ORDER BY ' unless $opt->{sort} =~ /^\s*order\s+by\s+/i; my @sort; @sort = ref $opt->{sort} ? @{$opt->{sort}} : ( $opt->{sort} ); for(@sort) { s/\s*[=:]\s*([rnxf]).*//; $_ .= " DESC" if $1 eq 'r'; } $sort .= join ", ", @sort; undef $opt->{sort}; } my $where = ''; unless($nodb) { if( my $f = $db->config('HIDE_FIELD')) { $where .= " AND $f <> 1"; } } if($opt->{where}) { $where .= " AND ($opt->{where})"; } my $qb = "SELECT * FROM $table WHERE $basewhere$where$sort"; #::logDebug("tree tag initial query=$qb"); my $ary; if($nodb) { $ary = \@start; } else { $ary = $db->query( { hashref => 1, sql => $qb, }); } my $memo; if( $opt->{memo} ) { $memo = ($::Scratch->{$opt->{memo}} ||= {}); my $toggle; if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) { $memo->{$toggle} = ! $memo->{$toggle}; } } if($opt->{collapse} and $CGI::values{$opt->{collapse}}) { $memo = {}; delete $::Scratch->{$opt->{memo}} if $opt->{memo}; } my $explode; if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) { $explode = 1; } my $enable; my $qsub; my $donemsg; my $dbh; $dbh = $db->dbh() unless $nodb; my $qs_query = "SELECT * FROM $table WHERE $parent = ?$where$sort"; if($nodb) { my $l = $opt->{level_field} || 'msort'; #::logDebug("setting up nodb qsub level=$l"); $qsub = sub { my $key = shift; #::logDebug("Looking for key=$key"); return if $key < 1; my $base = $passed[$key - 1]->{$l} + 1; #::logDebug("Base level=$base, firstone = $passed[$key]{$l}"); my @out; for(my $i = $key; $passed[$i]{$l} >= $base ; $i++ ) { push @out, $passed[$i] if $passed[$i]{$l} == $base; } return unless @out; return \@out; }; } elsif($dbh and $db->config('Class') eq 'DBI') { my $sth = $dbh->prepare($qs_query) or die errmsg( "tree failed to prepare query: %s\nError was: %s", $qs_query, $DBI::errstr, ); $qsub = sub { #::logDebug("executing query sub DBI style"); # while ! $donemsg++; my $parm = shift; my @ary; $sth->execute($parm) or die errmsg( "tree failed to prepare query for '%s': %s\nError was: %s", $parm, $qs_query, $DBI::errstr, ); while(my $ref = $sth->fetchrow_hashref()) { push @ary, { %$ref }; } return unless @ary; return \@ary; }; } else { $qsub = sub { my $parm = shift; #::logDebug("executing query sub regular style"); # while ! $donemsg++; $parm = $db->quote($parm, $parent); my $q = $qs_query; $q =~ s/\s\?\s/ $parm /; $db->query( { hashref => 1, sql => $q }); }; } $memo = {} if ! $memo; my $count = 0; my $stop_sub; #::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult"); my @ary_stack = ( $ary ); # Stacks the rows my @above_stack = { $start_item => 1 }; # Holds the previous levels my @inc_stack = ($outline[0]); # Holds the increment characters my @rows; my $row; ARY: for (;;) { #::logDebug("next ary"); my $ary = pop(@ary_stack) or last ARY; my $above = pop(@above_stack); my $level = scalar(@ary_stack); my $increment = pop(@inc_stack); ROW: for(;;) { #::logDebug("next row level=$level increment=$increment"); my $prev = $row; $row = shift @$ary or ($prev and $prev->{mv_last} = 1), last ROW; $row->{mv_level} = $level; $row->{mv_spacing} = $level * $mult; $row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing} if $opt->{spacer}; $row->{mv_increment} = $increment++; $row->{mv_ip} = $count++; push(@rows, $row); my $code = $row->{$keyfield}; $row->{mv_toggled} = 1 if $memo->{$code}; #::logDebug("next row sub=$sub=$row->{$sub}"); my $next = $row->{$sub} or next ROW; my $stop; $row->{mv_children} = 1 if ($opt->{stop} and ! $row->{ $opt->{stop} } ) or ($opt->{continue} and $row->{ $opt->{continue} }) or ($opt->{autodetect}); $stop = 1 if ! $explode and ! $memo->{$code}; #::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}"); if($above->{$next} and ($opt->{autodetect} or ! $stop) ) { my $fmt = <{$parent}, $next); if(! $opt->{pedantic}) { error_opt($opt, $msg); next ROW; } else { $opt->{log_error} = 1 unless $opt->{show_error}; return error_opt($opt, $msg); } } my $a; if ($opt->{autodetect} or ! $stop) { #::logDebug("next=$next row query=$q"); $a = $qsub->($next); $above->{$next} = 1 if $a and scalar @{$a}; } if($opt->{autodetect}) { $row->{mv_children} = $a ? scalar(@$a) : 0; } if (! $stop) { push(@ary_stack, $ary); push(@above_stack, $above); push(@inc_stack, $increment); $level++; $increment = defined $outline[$level] ? $outline[$level] : 1; $ary = $a; } } # END ROW #::logDebug("last row"); } # END ARY $opt->{object} = { mv_results => \@rows }; #::logDebug("last ary, results =" . ::uneval(\@rows)); return labeled_list($opt, $text, $opt->{object}); } EOR interchange-5.7.7.orig/code/SystemTag/try.coretag0000644000000000000000000000127311352565025016673 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: try.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag try Order label UserTag try addAttr UserTag try hasEndTag UserTag try PosNumber 1 UserTag try Version $Revision: 1.4 $ UserTag try MapRoutine Vend::Interpolate::try interchange-5.7.7.orig/code/SystemTag/uc_attr_list.coretag0000644000000000000000000000152011352565025020544 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: uc_attr_list.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $ UserTag uc-attr-list addAttr UserTag uc-attr-list hasEndTag UserTag uc-attr-list PosNumber 0 UserTag uc-attr-list noRearrange UserTag uc-attr-list Version $Revision: 1.2 $ UserTag uc-attr-list Routine <{hash} ) { $opt = $opt->{hash}; } return Vend::Interpolate::tag_attr_list($body, $opt, 1); } EOR interchange-5.7.7.orig/code/SystemTag/unpack.coretag0000644000000000000000000000244211352565025017335 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: unpack.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $ UserTag unpack PosNumber 0 UserTag unpack addAttr UserTag unpack hasEndTag UserTag unpack Interpolate UserTag unpack Version $Revision: 1.4 $ UserTag unpack Routine <($Vend::Output[$ptr]); #::logDebug("Now is ${$Vend::Output[$ptr]}"); } } } } else { for(@Vend::Output) { Vend::Interpolate::substitute_image($_); } } undef $Vend::MultiOutput; $::Pragma->{no_image_rewrite} = 1; Vend::Page::templatize($template); return; } EOR interchange-5.7.7.orig/code/SystemTag/update.coretag0000644000000000000000000000116311352565025017335 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: update.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag update Order function UserTag update addAttr UserTag update Version $Revision: 1.5 $ UserTag update MapRoutine Vend::Interpolate::update interchange-5.7.7.orig/code/SystemTag/userdb.coretag0000644000000000000000000000140211352565025017333 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: userdb.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag userdb Order function UserTag userdb addAttr UserTag userdb attrAlias table db UserTag userdb attrAlias name nickname UserTag userdb PosNumber 1 UserTag userdb Version $Revision: 1.5 $ UserTag userdb MapRoutine Vend::UserDB::userdb interchange-5.7.7.orig/code/SystemTag/value.coretag0000644000000000000000000000135711535625651017201 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: value.coretag,v 1.7 2008-07-04 15:52:35 mheins Exp $ UserTag value Order name UserTag value addAttr UserTag value PosNumber 1 UserTag value Version $Revision: 1.7 $ UserTag value MapRoutine Vend::Interpolate::tag_value UserTag evalue Alias value keep=1 filter="encode_entities" name= interchange-5.7.7.orig/code/SystemTag/value_extended.coretag0000644000000000000000000000125611352565025021052 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: value_extended.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $ UserTag value-extended Order name UserTag value-extended addAttr UserTag value-extended PosNumber 1 UserTag value-extended Version $Revision: 1.5 $ UserTag value-extended MapRoutine Vend::Interpolate::tag_value_extended interchange-5.7.7.orig/code/SystemTag/warnings.coretag0000644000000000000000000000311211352565025017677 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: warnings.coretag,v 1.9 2007-09-21 16:15:48 kwalsh Exp $ UserTag warning Alias warnings UserTag warnings Order message UserTag warnings addAttr UserTag warnings PosNumber 1 UserTag warnings Version $Revision: 1.9 $ UserTag warnings Routine <{param} ? $opt->{param} : [$opt->{param}]; push_warning($message, @$param); return unless $opt->{show}; } return unless $Vend::Session->{warnings}; my $out = $opt->{header} || ""; if($opt->{auto}) { $opt->{list_container} ||= 'ul'; $out .= "<$opt->{list_container}"; for(qw/ class style extra /) { next unless $opt->{"list_$_"}; if($opt->{"list_$_"} =~ m{^\s*$_\s*=}i) { $out .= ' ' . $opt->{"list_$_"}; } else { $out .= qq{ $_="$opt->{"list_$_"}"}; } } $out .= '>'; $opt->{joiner} = '
  • ' if ! length($opt->{joiner}); $out .= $opt->{joiner}; } elsif(! length($opt->{joiner})) { $opt->{joiner} = "\n"; } $out .= join $opt->{joiner}, grep /\S/, @{$Vend::Session->{warnings}}; $out .= "{list_container}>" if $opt->{auto}; $out .= $opt->{footer} if length($opt->{footer}); delete $Vend::Session->{warnings} unless $opt->{keep}; return $out; } EOR interchange-5.7.7.orig/code/UI_Tag/0000755000000000000000000000000011624451637013701 5ustar interchange-5.7.7.orig/code/UI_Tag/add_gpg_key.coretag0000644000000000000000000000337011352565025017502 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: add_gpg_key.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $ UserTag add-gpg-key Order name UserTag add-gpg-key addAttr UserTag add-gpg-key Version $Revision: 1.6 $ UserTag add-gpg-key Routine <{GPG_PATH} || 'gpg'; my $outfile = "$Vend::Cfg->{ScratchDir}/$Vend::Session->{id}.gpg_results"; my $flags = "--import --batch 2> $outfile"; #::logDebug("gpg_add flags=$flags"); my $keytext = $opt->{text} || $CGI::values{$name}; $keytext =~ s/^\s+//; $keytext =~ s/\s+$//; open(GPGIMP, "| $gpgexe $flags") or die "Can't fork: $!"; print GPGIMP $keytext; close GPGIMP; if($?) { $::Scratch->{ui_failure} = ::errmsg("Failed GPG key import."); return defined $opt->{failure} ? $opt->{failure} : undef; } else { my $keylist = `$gpgexe --list-keys`; $::Scratch->{ui_message} = ::errmsg( "GPG key imported successfully.
    \n%s\n
    ", $keylist, ); } if($opt->{return_id}) { open(GETGPGID, "< $outfile") or do { ::logGlobal("GPG key ID read -- can't read %s: %s", $outfile, $!); return undef; }; my $id; while() { next unless /\bkey\s+(\w+)\s*:\s+(public\s+key|)(.*)(imported|not\s+changed)/i; $id = $1; last; } close GETGPGID; return $id || 'Failed ID get?'; } elsif (defined $opt->{success}) { return $opt->{success}; } else { return 1; } } EOR interchange-5.7.7.orig/code/UI_Tag/assume_identity.tag0000644000000000000000000000174211352565025017603 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: assume_identity.tag,v 1.5 2007-03-30 23:40:54 pajamian Exp $ UserTag assume-identity Order file locale UserTag assume-identity addAttr UserTag assume-identity PosNumber 2 UserTag assume-identity Version $Revision: 1.5 $ UserTag assume-identity Routine <{name}) { $pn = $opt->{name}; } else { $pn = $file; $pn =~ s/\.\w+$//; $pn =~ s:^pages/::; } $Global::Variable->{MV_PAGE} = $pn; $locale = 1 unless defined $locale; return Vend::Interpolate::interpolate_html( Vend::Util::readfile($file, undef, $locale) ); } EOR interchange-5.7.7.orig/code/UI_Tag/auto_wizard.coretag0000644000000000000000000005434211352565025017602 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: auto_wizard.coretag,v 1.20 2007-03-30 23:40:54 pajamian Exp $ UserTag auto-wizard Order name UserTag auto-wizard AddAttr UserTag auto-wizard HasEndTag UserTag auto-wizard Version $Revision: 1.20 $ UserTag auto-wizard Routine <{already_title} ||= "You already did that survey!" ) : ($opt->{thanks_title} ||= $default || "Thanks for completing the survey!"); return errmsg($tt); } sub thanks_message { my ($opt, $already) = @_; my $tm; if($already) { $opt->{already_message} ||= "We only want to collect information once from each person. Thank you."; $tm = $opt->{already_message}; } else { $opt->{thanks_message} ||= "Your survey is complete. Thank you."; $tm = $opt->{thanks_message}; } return errmsg($tm); $opt->{intro_text} .= "

    $tm

    " if $already; } sub title_and_message { my ($opt, $already) = @_; my $tt = thanks_title($opt, $already); my $tm = thanks_message($opt, $already); return ( '', "final: $tt", 'template: <{surveys} ||= {}; if(defined $set) { $surv->{$wizname} = $set; } if ($Vend::Session->{logged_in} and ! $Vend::admin) { if (! defined $surv->{$wizname}) { my $o = { function => 'check_file_acl', location => "survey/$wizname", }; $surv->{$wizname} = $Tag->userdb($o); } else { my $o = { function => 'set_file_acl', location => "survey/$wizname", mode => $surv->{$wizname}, }; $Tag->userdb($o); } } return $surv->{$wizname}; } sub survey_log_generate_final { my ($wizname, $opt, $ary) = @_; ref($opt) eq 'HASH' or die "bad call to generate_final routine, output options not hash ref ($opt)"; ref($ary) eq 'ARRAY' or die "bad call to generate_final routine, output not array ref ($ary)"; my $done = already($wizname); push @$ary, title_and_message($opt, $done); if ( $done ) { $opt->{intro_text} .= '

    ' . thanks_title($opt, 1) . '

    '; } # else { # $opt->{survey_counter} ||= "logs/survey/$wizname.cnt"; # $opt->{survey_file} ||= "logs/survey/$wizname.txt"; # push @$ary, "\tsurvey_file: $opt->{survey_file}"; # push @$ary, "\tsurvey_counter: $opt->{survey_counter}"; # } return; } sub gen_email_header { my ($wizname, $ref, $opt, $fnames) = @_; my $subject = errmsg($opt->{email_subject} || "Response to %s", $wizname); my $from_addr = $opt->{email_from}; my $cc_addr = $opt->{email_cc}; for(qw/ EMAIL_SURVEY EMAIL_INFO EMAIL_SERVICE /) { next unless $from_addr = $::Variable->{$_}; last; } $from_addr ||= $Vend::Cfg->{MailOrderFrom} || $Vend::Cfg->{MailOrderTo}; my $tpl = <{output_fields}; if(! @fields) { @fields = @$fnames; } for(@fields) { $tpl .= "$_: {$_}\n"; } $tpl .= "--------------------------------------------\n"; return $tpl; } sub email_output { my ($wizname, $ref, $opt, $fnames) = @_; #::logDebug("Called email_output"); return unless $opt->{output_email}; #::logDebug("email_output has an address of $opt->{output_email}"); ## Check and see if already sent if(! $opt->{output_repeated} and already($wizname)) { #::logDebug("email_output already done, repeated=$opt->{output_repeated} already=" . ::uneval($Vend::Session->{surveys})); return; } #::logDebug("email_output is continuing"); my $tpl = $opt->{email_template}; if(! $tpl or $tpl !~ /\S/) { $tpl = gen_email_template($wizname, $ref, $opt, $fnames); } else { $opt->{email_template} =~ s/\s+$//; $opt->{email_template} =~ s/^\s+//; if($opt->{email_template} !~ /[\r\n]/) { $tpl = interpolate_html(Vend::Util::readfile($opt->{email_template})); } else { $tpl = $opt->{email_template}; } if($tpl !~ /^[-\w]+:/) { $tpl = join "\n", gen_email_header($wizname, $ref, $opt, $fnames), $tpl; } } #::logDebug("email_output tpl=$tpl"); my @fields = grep /\S/, split /\s+/, $opt->{output_fields}; if(! @fields) { @fields = @$fnames; } my $outref = { %$opt }; $outref->{ip_address} = $CGI::remote_addr; $outref->{host_name} = $CGI::remote_host; $outref->{username} = $Vend::username || 'anonymous'; $outref->{date} = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime()); for(@fields) { $outref->{$_} = $Values->{$_}; } my $out = tag_attr_list($tpl, $outref); my $status; $status = $Tag->email_raw({}, $out) or ::logError("Failed to send survey email output:\n$out"); #::logDebug("email_output status=$status"); return $status; } sub survey_log_to_file { my ($wizname, $ref, $opt, $fnames) = @_; if(! $opt->{output_repeated} and already($wizname)) { return template_attr($wizname, $ref, $opt, $fnames); } my $fn = $ref->{survey_file}; my $cfn = $ref->{survey_counter}; my $sqlc = $ref->{survey_counter_sql}; if(! $fn) { $fn = $::Variable->{SURVEY_LOG_DIR} || 'logs/survey'; $fn .= "/$wizname.txt"; } if(! $cfn and ! $sqlc) { $cfn = $fn; $cfn =~ s/\.txt$//; $cfn .= '.cnt'; $cfn =~ s:(.*/):$1.:; } my @fields = grep /\S/, split /\s+/, $opt->{output_fields}; if(! @fields) { @fields = @$fnames; } if(! -f $fn) { my $string = join "\t", 'code', 'ip_address', 'username', 'date', @fields; $string .= "\n"; $Tag->write_relative_file($fn, $string); } my @o = $Tag->counter({file => $cfn, sql => $sqlc}); push @o, $CGI::remote_addr; push @o, $Vend::username || 'anonymous'; push @o, POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime()); for(@fields) { my $result = $Values->{$_}; $result =~ s/\r?\n/\r/g; $result =~ s/\t/ /g; push @o, $result; } ::logData($fn, @o); email_output($wizname, $ref, $opt, $fnames); already($wizname => 1) unless $opt->{output_repeated}; return template_attr($wizname, $ref, $opt, $fnames); } my %survey_genfinal = ( survey_log => \&survey_log_generate_final, email_only => sub { my ($wizname, $opt, $ary) = @_; push @$ary, title_and_message($opt, already($wizname)); if($opt->{continue_template}) { push @$ary, "template: <{continue_template}; push @$ary, 'EOF'; } return; }, default => sub { my ($wizname, $opt, $ary) = @_; my $line = "final: "; $line .= thanks_title( $opt, $Vend::Session->{surveys}{$wizname}, errmsg("Finished with %s", $wizname), ); push @$ary, ''; push @$ary, $line; if($opt->{continue_template}) { push @$ary, "template: <{continue_template}; push @$ary, 'EOF'; } return; }, ); sub template_attr { my ($wizname, $ref, $opt, $fields) = @_; my %attr; if(ref($fields) eq 'hash') { %attr = { %$fields }; } $attr{TITLE} = $ref->{_page_title} || "Finished with $wizname..."; $attr{PROMPT} = $ref->{prompt}; $attr{ANCHOR} = $ref->{anchor} || 'Go'; $attr{EXTRA} = $ref->{extra} || ''; $attr{EXTRA} = " $attr{EXTRA}" if $attr{EXTRA}; $attr{URL} = wizard_url($ref, $opt, $fields); #::logDebug("generated ATTR is: " . uneval(\%attr)); my $template = $ref->{template} || <{TITLE} {PROMPT}

    {ANCHOR}
    EOF return tag_attr_list($template, \%attr); } sub wizard_url { my ($ref, $opt, $fields) = @_; my %attr; my %ignore = qw/ page href template remap /; my $form = { }; for(keys %$ref) { next if /^_/; next if $ignore{$_}; $form->{$_} = $ref->{$_}; } $form->{href} = $opt->{output_href} || $ref->{href} || $ref->{page}; if($opt->{output_parm}) { my $ref = Vend::Util::scalar_to_hash($opt->{output_parm}) || {}; for (keys %$ref) { $form->{$_} = $ref->{$_}; } } $form->{form} = 'auto'; for(@$fields) { $form->{$_} = $Values->{$_}; } my $save = { }; if($ref->{remap}) { my @pairs = split /[\s,\0]+/, $ref->{remap}; for(@pairs) { my ($k, $v) = split /=/, $_; next unless $k and $v; my $val = delete($form->{$k}) || $save->{$k}; $save->{$k} = $val; $form->{$v} = $val; } } return $Tag->area($form); } my %survey_auto = qw/ survey_log 1 email_only 1 auto_bounce 1 /; ## Called with: ## ## $$dest = $sub->($wizname, $ref, $opt, \@vals); ## ## $wizname name of wizard/survey ## $ref copy of final stanza of auto_wizard, hash ref with keys, can modify ## %opts Options auto_wizard was created with, can modify ## @vals Fields names collected in the wizard, can modify my %survey_action = ( survey_log => \&survey_log_to_file, auto_bounce => sub { my ($wizname, $ref, $opt, $fnames) = @_; my $url = wizard_url($ref, $opt, $fnames); email_output($wizname, $ref, $opt, $fnames); my $status = $Tag->deliver( { type => 'text/html', location => $url }); return $status; }, default => sub { my ($wizname, $ref, $opt, $fnames) = @_; $ref->{wizard_name} = $wizname; email_output($wizname, $ref, $opt, $fnames); return template_attr($wizname, $ref, $opt, $fnames); }, ); sub compile_wizard { my ($wizname, $opt, $script) = @_; #Debug("script in: $script"); $script =~ s/^\s+//; $script =~ s/\r\n/\n/g; $script =~ s/\r/\n/g; my @lines = split /\n/, $script; my $ref; my @pages; my $qip; # question in progress my $iip; # item in progress my $fip; # final in progress my $bip; # breaks in progress my $blip; # break labels in progress my $began; # We have begun my $sip; my $vip; my $mark; my $break; my %opts; if($opt->{db_id}) { #Debug("found db_id=$opt->{db_id}"); my ($t, $k) = split /:+/, $opt->{db_id}, 2; BUILDWIZ: { my $met = $Tag->meta_record($k, undef, $t) or last BUILDWIZ; my($structure) = delete $met->{ui_data_fields}; delete $met->{extended}; %opts = %$met; #Debug("display type=$opts{display_type} met=" . ::uneval($met) ); $met->{row_template} = $opt->{row_template} if $opt->{row_template}; my $ids = $t . '::' . $k . '::'; $structure =~ s/\r\n?/\n/g; my $string = "\n\n$structure"; my %break; while ($string =~ s/\n+(?:\n[ \t]*=(.*))?\n+[ \t]*(\w[:.\w]+)/\n$2/) { $break{$2} = $1; } $string =~ s/^[\s,\0]+//; $string =~ s/[\s,\0]+$//; $string =~ s/[,\0\s]+/ /g; my @fields = split /\s+/, $string; my @out = "$k: $met->{label}"; my $i = 1; my $fields_line = join "\t", @fields; for(@fields) { if($break{$_}) { push @out, "$i: $break{$_}"; $i++; } push @out, "\tdb_id: $ids$_"; push @out, ''; } $opts{output_fields} ||= join " ", @fields; my $otype = $opts{output_type} || 'default'; my $sub = $survey_genfinal{$otype} || $survey_genfinal{default}; $sub->($k, \%opts, \@out); @lines = @out; } } #Debug("Found some lines, number=" . scalar @lines); #Debug("display type=$opts{display_type}"); for(@lines) { if($mark) { $sip .= "$_\n", next unless $_ eq $mark; $_ = $sip; undef $mark; undef $sip; } if (s/<<(\w+)$//) { $mark = $1; $sip = $_; next; } s/\s+$//; if(! $_) { undef $iip; next; } if(! $ref) { if(/^(\w+):\s*(.*)/) { $began = 1; $wizname ||= $1; my $title = $2; $ref = { _page_name => 'begin', _name => [], title => $title, %opts, }; } next; } if(/^(\d+)[:.]\s*(.*)/) { my $pn = $1; my $title = $2; push @pages, $ref; my $lastpage = $ref->{_page_name}; $qip = []; undef $bip; undef $blip; $ref = { _page_name => $pn, _name => $qip, _breaks => $bip, _break_labels => $blip, _page_title => $title, }; next; } if(/^final[:.]\s*(.*)/) { undef $qip; undef $iip; $fip = 1; my $title = $1; push @pages, $ref; my $lastpage = $ref->{_page_name}; $ref = { _page_name => 'final', _page_title => $title}; next; } if($fip) { s/^\s+//; unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) { $Tag->warnings(qq{Unrecognized "$_" in middle of script.}); next; } my $thing = $1; my $modifier = $2; my $value = $3; if($modifier) { $ref->{_modifier} ||= {}; $ref->{_modifier}{$thing} = $modifier; } $ref->{$thing} = $value; next; } if($qip) { if(/^(itl|perl)(?:_condition)?:\s*(.*)$/s) { if(! $ref->{_condition}) { $ref->{_condition_type} = $1; $ref->{_condition} = $2; } else { $Tag->error( "%s_condition: cannot set twice in wizard %s screen %s", $1, $pages[0]->{_title}, $ref->{_page_name}, ); return; } next; } elsif(/^opt:\s*(.*)$/s) { my $option = $1; $option =~ s/\s+$//; my ($n, $v) = split /=/, $option, 2; my $o = $ref->{_options} ||= []; push @$o, $n, $v; next; } s/^\s+//; unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) { $Tag->warnings(qq{Unrecognized "$_" in middle of script.}); next; } my $thing = $1; my $modifier = $2; my $value = $3; if(! $iip) { ## This redoes the loop if($thing eq 'name') { $thing = $value; undef $value; } elsif($thing eq 'break') { $break = $value; $break =~ s/,/)/g; $ref->{_breaks} ||= ($bip = []); $ref->{_break_labels} ||= ($blip = []); next; } elsif($thing eq 'db_id') { my ($t, $survey, $name) = split /:+/, $value, 3; $thing = $name; my $key = $survey . '::' . $name; my $meta = $Tag->meta_record($key, undef, $t); if($meta) { for(keys %$meta) { $ref->{$_} ||= {}; $ref->{$_}{$thing} = $meta->{$_}; } } $ref->{name}{$thing} = $thing; #::logDebug("meta record is " . ::uneval($meta)); undef $value; } $iip = $thing; push @$qip, $iip; if($break) { push @$bip, $iip; push @$blip, "$iip=$break"; undef $break; } $ref->{label}{$iip} = $value if $value; next; } if($modifier) { $ref->{_modifier} ||= {}; $ref->{_modifier}{$thing} ||= {}; $ref->{_modifier}{$thing}{$iip} = $modifier; } $ref->{$thing} ||= {}; $ref->{$thing}{$iip} = $value; } else { unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) { $Tag->warnings(qq{Unrecognized "$_" in beginning section of script.}); next; } my $thing = $1; my $modifier = $2; my $value = $3; $ref->{$thing} = $value; } } push @pages, $ref; $wizname ||= 'default'; my $wiz_ary = $Session->{auto_wizard} ||= {}; $wiz_ary->{$wizname} = \@pages; #Debug("Wizard $wizname=" . ::uneval(\@pages)); return $wizname; } sub { my ($wizname, $opt, $body) = @_; my $dest; $wizname ||= $CGI->{wizard_name}; if($opt->{scratch}) { $Tag->tmp($opt->{scratch}); $::Scratch->{$opt->{scratch}} ||= ''; $dest = \$::Scratch->{$opt->{scratch}}; } else { $Tmp->{auto_wizard} ||= ''; $dest = \$Tmp->{auto_wizard}; } return $$dest if $opt->{show} and ! $opt->{run}; if($opt->{compile} eq 'auto') { $Session->{auto_wizard} ||= {}; undef $opt->{compile} if $wizname && $Session->{auto_wizard}{$wizname}; $opt->{show} = 1 unless defined $opt->{show}; $opt->{run} = 1; } if($opt->{compile}) { my $n; $n = compile_wizard(@_) or do { ::logError( $$dest = errmsg( "Wizard %s failed to compile.", $wizname, ) ); return; }; #Debug("compiler returned wizname=$n"); $wizname = $n; undef $body; } if(! defined $opt->{run}) { $opt->{run} = 1; $opt->{show} = 0 if ! defined $opt->{show}; } my $title_var = $opt->{title_scratch} || 'page_title'; my $banner_var = $opt->{banner_scratch} || 'page_banner'; my $wiz; $wizname ||= $CGI->{wizard_name} || 'default'; #Debug("wizname=$wizname"); return unless $wiz = $Vend::Session->{auto_wizard}{$wizname}; #Debug("we have a wiz! wizname=$wizname"); my $beg = $wiz->[0]; my $fin = $wiz->[-1]; for($beg, $fin) { return "Bad wizard!" unless ref($_) eq 'HASH'; } my $lastwiz = $#$wiz; my $lastpage = $CGI->{wizard_page} || 0; my $current_page; my %opts; copyref($beg, \%opts); # Get rid of internal stuff for(keys %opts) { next unless /^_/; delete $opts{$_}; } if($CGI->{ui_wizard_action} eq 'Back') { $current_page = $lastpage - 1; } elsif($CGI->{ui_wizard_action} eq 'Cancel') { $current_page = 0; } elsif($CGI->{ui_wizard_action} eq 'Next') { $current_page = $lastpage + 1; } else { $current_page = $lastpage; } my $finished; my $condition_done; my $optref; #::logDebug("Getting screens"); GETSCREEN: { $optref = $wiz->[$current_page]; if(! $condition_done and $optref->{_condition}) { $condition_done = 1; my $result; if($optref->{_condition_type} eq 'itl') { eval { $result = interpolate_html($optref->{_condition}); }; $result =~ s/\s+$//; $result =~ s/.*\s//s; $result += 0; $current_page += $result; } else { eval { $result = $ready_safe->reval($optref->{_condition}); }; if($@) { $Tag->error( "error during perl conditional: $@\ncode was:\n%s", $@, $optref->{_condition}, ); $current_page -= 1; } $result += 0; #::logDebug("did perl conditional, result=$result"); $current_page += $result; } redo GETSCREEN; } if($current_page <= 0) { $current_page = 1; } elsif ( ($current_page + 1) == $lastwiz ) { $opts{next_text} = errmsg('Finish') if $survey_auto{$opts{output_type}} or $fin->{auto}; } elsif ($current_page >= $lastwiz) { $finished = 1; } $optref = $wiz->[$current_page]; } unless($current_page <= 1) { delete $opts{intro_text}; delete $optref->{intro_text}; } my %modsub = ( i => sub { my $val = shift; # ::logDebug("running interpolate of $val"); return interpolate_html($val); }, default => sub { my $val = shift; my $filters = join " ", @_; return $Tag->filter($filters, $val); }, ); $Scratch->{$title_var} = $optref->{_page_title}; $Scratch->{$banner_var} = $optref->{_page_title}; if($finished) { my $ref = { %$fin }; my $mod; if( $mod = delete $ref->{_modifier}) { for(keys %$ref) { next if /^_/; if(my $m = $mod->{$_}) { my $v = $ref->{$_}; my $sub = $modsub{$m} || $modsub{default}; $ref->{$_} = $sub->($ref->{$_}, $m); } } } my @vals; for my $w (@$wiz) { next unless ref($w->{_name}) eq 'ARRAY'; push @vals, @{$w->{_name}}; } my $otype = $opts{output_type}; $otype ||= 'auto_bounce' if $ref->{auto}; my $sub = $survey_action{$otype} || $survey_action{default}; $$dest = $sub->($wizname, $ref, \%opts, \@vals); return $$dest if $opt->{show}; return; #Debug("finished, page ref=" . uneval($ref)); } #Debug("we have a wiz=$wizname! current_page = $current_page"); #Debug("optref=" . $Tag->uneval(undef, $optref)); #::logDebug("prepping to walk optref"); ### TODO: Find bad reference when no section title... my $name = $optref->{_name} || die; # $Scratch->{page_title} = $optref->{_page_title}; if($optref->{_breaks} and ref($optref->{_breaks}) eq 'ARRAY') { $opts{ui_break_before} = join " ", @{$optref->{_breaks}}; $opts{ui_break_before_label} = join ",", @{$optref->{_break_labels}}; } if(my $o = $optref->{_options}) { for (my $i = 0; $i < @$o; $i += 2) { $opts{$o->[$i]} = $o->[$i + 1]; } } $opts{form_name} ||= 'wizard'; $opts{all_errors} = '1'; $opts{hidden} = { wizard_name => $wizname, wizard_page => $current_page, }; $opts{wizard} = 1; $opts{notable} = 1; $opts{no_meta} = 1; $opts{defaults} = 1; $opts{mv_cancelpage} ||= 'index'; $opts{row_template} ||= $opt->{row_template} || <<'EOF' unless $opts{display_type}; {HELP?}  {HELP} {HELP_URL?}
    more help{/HELP_URL?} {/HELP?} {LABEL} $WIDGET$ EOF $opts{ui_wizard_fields} = join " ", @$name; $opts{mv_nextpage} = $Global::Variable->{MV_PAGE}; $opts{mv_prevpage} = $Global::Variable->{MV_PAGE} if $current_page != 1; $opts{bottom_buttons} = 1; #::logDebug("walking optref"); my $mod = $optref->{_modifier} || ''; for(keys %$optref) { next if /^_/; next if $overall_opt{$_}; next unless ref($optref->{$_}) eq 'HASH'; $opts{$_} = {} if ref($opts{$_}) ne 'HASH'; Vend::Util::copyref($optref->{$_}, $opts{$_}); my $m; if($mod and $m = $mod->{$_}) { my $r = $opts{$_}; for my $k (keys %$r) { next unless $m->{$k}; my @subs = split /\s*,\s*/, $m->{$k}; for(@subs) { my $sub = $modsub{$_} || $modsub{default}; $r->{$k} = $sub->($r->{$k}, $_); } } } } $opts{widget} ||= {}; if( my $r = delete $opts{type} ) { for(keys %$r) { $opts{widget}{$_} = $r->{$_}; } } delete $opts{type}; # Prevent ui_data_fields from parent corrupting wizard delete $opts{ui_data_fields}; delete $opts{extended}; #::logDebug("calling table_editor opts=" . ::uneval(\%opts)); $$dest = $Tag->table_editor( {all_opts => \%opts }); if($$dest !~ /error({ show => 1, set => $msg }); } return $$dest if $opt->{show}; return; } EOR interchange-5.7.7.orig/code/UI_Tag/available_ups_internal.coretag0000644000000000000000000000131611352565025021746 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: available_ups_internal.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag available_ups_internal Version $Revision: 1.4 $ UserTag available_ups_internal Routine < {type => 'UPS', description => 'Next Day Air Early AM'}, '1DML' => {type => 'UPS', description => 'Next Day Air Early AM Letter'}, '1DA' => {type => 'UPS', description => 'Next Day Air'}, '1DAL' => {type => 'UPS', description => 'Next Day Air Letter'}, '1DP' => {type => 'UPS', description => 'Next Day Air Saver'}, '1DPL' => {type => 'UPS', description => 'Next Day Air Saver Letter'}, '2DM' => {type => 'UPS', description => '2nd Day Air A.M.'}, '2DA' => {type => 'UPS', description => '2nd Day Air'}, '2DML' => {type => 'UPS', description => '2nd Day Air A.M. Letter'}, '2DAL' => {type => 'UPS', description => '2nd Day Air Letter'}, '3DS' => {type => 'UPS', description => '3 Day Select'}, 'GNDCOM' => {type => 'UPS', description => 'Ground Commercial'}, 'GNDRES' => {type => 'UPS', description => 'Ground Residential'}, 'XPR' => {type => 'UPS', description => 'Worldwide Express'}, 'XDM' => {type => 'UPS', description => 'Worldwide Express Plus'}, 'XPRL' => {type => 'UPS', description => 'Worldwide Express Letter'}, 'XDML' => {type => 'UPS', description => 'Worldwide Express Plus Letter'}, 'XPD' => {type => 'UPS', description => 'Worldwide Expedited'}, ; } if (wantarray) { return @ups_modes; } else { my $out = ''; my $i; for ($i = 0; $i < @ups_modes; $i += 2) { my $ref = $ups_modes[$i + 1]; $out .= qq{UPSE:$ups_modes[$i]\t$ref->{type}: $ref->{description}\n}; } return $out; } } EOR interchange-5.7.7.orig/code/UI_Tag/backup_database.coretag0000644000000000000000000001266111535625651020346 0ustar # Copyright 2002-2009 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. UserTag backup-database Order tables UserTag backup-database AddAttr UserTag backup-database Version 1.11 UserTag backup-database Routine <{dir} || $::Variable->{BACKUP_DIRECTORY} || "$Vend::Cfg->{VendRoot}/backup"; my $gnum = $opt->{gnumeric}; my $agg = "$backup_dir/DBDOWNLOAD.all"; my $Max_xls_string = 255; eval { require Compress::Zlib; } if $opt->{compress}; my $xls; if ($opt->{xls}) { eval { require Spreadsheet::WriteExcel; import Spreadsheet::WriteExcel; $xls = Spreadsheet::WriteExcel->new("$backup_dir/DBDOWNLOAD.xls"); }; if ($xls) { if ($opt->{max_xls_string}) { $Max_xls_string = int($opt->{max_xls_string}) || 255; $xls->{_xls_strmax} = $Max_xls_string; } } else { undef $opt->{xls}; } } my $gz; my @errors; if($gnum) { open (AGG, ">$agg") or die "Cannot write aggregate file $agg; $!\n"; } my $done = 0; for my $table (@tables) { my $unlink; my $db = Vend::Data::database_exists_ref($table); my $fn = $db->config('file'); $fn =~ s:.*/::; my $file = "$backup_dir/$fn"; my $status; eval { $status = export( $table, { force => 1, table => $table, file => $file, type => 'TAB', where => $opt->{where}, }, ); }; if(! $status) { push @errors, errmsg( "Error exporting %s to %s: %s", $table, $file, $@ || 'unspecified', ); next; } if($opt->{compress}) { my $new = "$file.gz"; my $gz; eval { $gz = Compress::Zlib::gzopen($new, "wb") or die errmsg("error compressing %s to %s: %s", $new, $agg, $!); open(ZIN, $file) or die errmsg("error opening %s: %s", $file, $!); while() { $gz->gzwrite($_) or die errmsg("gzwrite error on %s: %s", $new, $gz->gzerror()); } $gz->gzclose(); close ZIN; }; if($@) { push @errors, $@; next; } $unlink = 1; } if($gnum) { print AGG "\f" if $done; print AGG "$table\n"; open(RECENT, $file) or do { push @errors, errmsg("Can't read written file %s: %s", $file, $!); next; }; while() { /\t/ and s/^/'/ and ( s/\t(0\d+)/\t'$1/g, s/\t\+/\t'+/g, s/\t( *\d[^\t]*[-A-Za-z ])/\t'$1/g ); print AGG; } close RECENT; } if($xls) { my $sheet = $xls->addworksheet($table); $sheet->{_xls_strmax} = $Max_xls_string if defined $opt->{max_xls_string}; $sheet->activate($table) if $table eq $Vend::Cfg->{ProductFiles}[0]; open(RECENT, $file) or do { push @errors, errmsg("Can't read written file %s: %s", $file, $!); next; }; my $fstring = ; chomp $fstring; my @fields = split /\t/, $fstring; my $maxcol = scalar @fields - 1; my $j; for($j = 0; $j <= $maxcol; $j++) { $sheet->write_string(0, $j, $fields[$j]) if length $fields[$j]; } my $i = 1; while() { chomp; my @extra; my @overflow; @fields = split /\t/, $_; for($j = 0; $j <= $maxcol; $j++) { my $l = 0; my $ptr; if ( length($fields[$j]) > $Max_xls_string) { $overflow[$j] = $fields[$j]; $extra[$j] = []; while ( length($overflow[$j]) > $Max_xls_string) { for( ' ', "\n", " " ) { $ptr = rindex $overflow[$j], $_, $Max_xls_string; #::logDebug("char='$_' ptr=$ptr length=" . length($overflow[$j]) ) if $l < 10; last if $ptr != -1; } #::logDebug("char='$_' ptr=$ptr\nstring=$overflow[$j]") if $l++ < 10; $ptr = 254 if $ptr < 0; $ptr++; my $string = substr $overflow[$j], 0, $ptr; $overflow[$j] = substr $overflow[$j], $ptr; push @{$extra[$j]}, $string; } push @{$extra[$j]}, $overflow[$j]; $fields[$j] = shift @{$extra[$j]}; } $sheet->write_string($i, $j, $fields[$j]); } if(@extra) { my $max = 0; for(@extra) { next unless $_; my $current = scalar @$_; $max = $current if $max < $current; } for (my $k = 0; $k < $max; $k++) { $i++; for( $j = 0; $j < scalar @extra; $j++) { next unless $_; $sheet->write_string($i, $j, $extra[$j][$k]); } } } $i++; } close RECENT; } unlink($file) if $unlink; undef $unlink; $done++; } close AGG if $opt->{compress}; if($opt->{compress} and $gnum and $gnum =~ /^compress/i) { my $file = $agg; my $new = "$file.gz"; eval { my $gz = Compress::Zlib::gzopen($new, "wb") or die errmsg("error compressing %s to %s: %s", $new, $agg, $!); open(ZIN, $file) or die errmsg("error opening %s: %s", $file, $!); while() { $gz->gzwrite($_) or die errmsg("gzwrite error on %s: %s", $new, $gz->gzerror()); } $gz->gzclose(); close ZIN; }; if($@) { push @errors, $@; } else { unlink($file); } } if(@errors) { $::Scratch->{ui_error} = '
    • '; $::Scratch->{ui_error} .= join "
      • \n
    • ", @errors; $::Scratch->{ui_error} .= '
    '; } return $opt->{hide} ? "" : $done; } EOR interchange-5.7.7.orig/code/UI_Tag/backup_file.coretag0000644000000000000000000000264111352565025017511 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: backup_file.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $ UserTag backup-file Order file UserTag backup-file AddAttr UserTag backup-file Version $Revision: 1.5 $ UserTag backup-file Routine < $bu_dir } ) or die ::errmsg("Cannot make backup of %s: %s", $bu_file, $!); } #::logDebug("ready to copy $file to $bu_file"); File::Copy::copy($file, $bu_file) or die ::errmsg("Copy %s to %s: %s", $file, $bu_file, $!); }; if ($@) { $::Scratch->{ui_error} = $@; ::logError($::Scratch->{ui_error}); return undef; } return 1; } EOR interchange-5.7.7.orig/code/UI_Tag/base_url.coretag0000644000000000000000000000101211352565025017030 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: base_url.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag base-url Version $Revision: 1.4 $ UserTag base-url Routine sub { return $Vend::Cfg->{VendURL} } interchange-5.7.7.orig/code/UI_Tag/check_upload.coretag0000644000000000000000000000155411352565025017670 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: check_upload.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag check-upload Order file same UserTag check-upload PosNumber 2 UserTag check-upload Version $Revision: 1.4 $ UserTag check-upload Routine <{ProductDir}; $same = $same ? '' : '+'; if (-s "upload/$file") { File::Copy::copy "upload/$file", "$dir/$file$same" or return "Couldn't copy uploaded file!"; unlink "upload/$file"; } return ''; } EOR interchange-5.7.7.orig/code/UI_Tag/content_editor.coretag0000644000000000000000000000126411352565025020265 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: content_editor.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $ UserTag content-editor Order name UserTag content-editor addAttr UserTag content-editor hasEndTag UserTag content-editor Version $Revision: 1.6 $ UserTag content-editor Routine <{umask}"); my $save_mask; if($opt->{umask}) { $opt->{umask} = oct($opt->{umask}); $save_mask = umask($opt->{umask}); } my $status = File::Copy::copy($from, $to); if ($opt->{preserve_times}) { my ($atime, $mtime); ($atime, $mtime) = (stat $from)[8,9]; if ($atime) { $status = utime($atime, $mtime, $from); } else { $status = 0; } } umask($save_mask) if defined $save_mask; return '' if $opt->{hide}; return $status; } EOR interchange-5.7.7.orig/code/UI_Tag/crypt.coretag0000644000000000000000000000130111352565025016376 0ustar # Copyright 2003-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: crypt.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $ UserTag crypt Order value salt UserTag crypt attrAlias password value UserTag crypt attrAlias crypted salt UserTag crypt Version $Revision: 1.6 $ UserTag crypt Routine <{mv_data_table} unless $table; my $db = Vend::Data::database_exists_ref($table) or return undef; my $acl = UI::Primitive::get_ui_table_acl($table); $db = $db->ref() unless $Vend::Interpolate::Db{$table}; my $key = $db->config('KEY'); $joiner = "\n" unless defined $joiner; my @cols; if(! $columns || $columns =~ /^[\s,\0]*$/) { @cols = $db->columns(); } else { @cols = grep /\S/, split /[\s,\0]+/, $columns; my (@allcols) = $db->columns(); my %col; if($passed_order) { @col{@allcols} = @allcols; @allcols = @cols; my $found; for(@cols) { next unless $_ eq $key; $found = 1; last; } unshift (@allcols, $key) if ! $found; } else { @col{@cols} = @cols; } $col{$key} = $key if ! defined $col{$key}; @cols = grep defined $col{$_}, @cols; } if($acl) { @cols = UI::Primitive::ui_acl_grep( $acl, 'fields', @cols); } return @cols if wantarray; return join $joiner, @cols; } EOR interchange-5.7.7.orig/code/UI_Tag/db_hash.coretag0000644000000000000000000000300011352565025016623 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: db_hash.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $ UserTag db-hash Order table column key UserTag db-hash PosNumber 3 UserTag db-hash addAttr UserTag db-hash Version $Revision: 1.5 $ UserTag db-hash Routine <reval($val); if (! ref $ref) { $ref = {}; } } if (! $rest) { return $val unless defined $opt->{value}; } my @extra; @extra = split /:+/, $rest; my $final = pop @extra; my $curr = $ref; $out .= "Original key request: $rest\n"; $out .= "\nFinal key: $final\n"; for(@extra) { $out .= "key --> $_\n"; $curr = $curr->{$_}; if (! ref $curr) { return "BAD HASH: $out" if $opt->{show_error}; return; } } if($opt->{keys}) { return join get_joiner($opt->{joiner}), sort keys %$curr; } elsif(! defined $opt->{value}) { return $curr->{$final}; } else { $curr->{$final} = $opt->{value}; tag_data($table, $col, $key, { value => uneval_it($ref) }); return $curr->{$final}; } } EOR interchange-5.7.7.orig/code/UI_Tag/diff.coretag0000644000000000000000000000363211352565025016156 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: diff.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag diff Order current previous UserTag diff attrAlias curr current prev previous UserTag diff addAttr UserTag diff Version $Revision: 1.4 $ UserTag diff Routine <{flags} .= ' -c' if $opt->{context}; $opt->{flags} .= ' -u' if $opt->{unified}; my $data_opt = {}; $data_opt->{safe_data} = 1 if $opt->{safe_data}; unless($opt->{flags} =~ /^[-\s\w.]*$/) { Log("diff tag: Security violation with flags: $opt->{flags}"); return "Security violation with flags: $opt->{flags}. Logged."; } my ($currfn, $prevfn); if($curr =~ /^(\w+)::(.*?)::(.*)/) { my ($table, $col, $key) = ($1, $2, $3); $currfn = "tmp/$Vend::SessionName.current"; my $data = tag_data($table, $col, $key, $data_opt); if ($opt->{ascii}) { $data =~ s/\r\n?/\n/g; $data .= "\n" unless substr($data, -1, 1) eq "\n"; } Vend::Util::writefile(">$currfn", $data); } else { $currfn = $curr; } if($prev =~ /^(\w+)::(.*?)::(.*)/) { my ($table, $col, $key) = ($1, $2, $3); $prevfn = "tmp/$Vend::SessionName.previous"; my $data = tag_data($table, $col, $key, $data_opt); if ($opt->{ascii}) { $data =~ s/\r\n?/\n/g; $data .= "\n" unless substr($data, -1, 1) eq "\n"; } Vend::Util::writefile(">$prevfn", $data); } else { $prevfn = $prev; } #Debug("diff command: 'diff $opt->{flags} $prevfn $currfn'"); return `diff $opt->{flags} $prevfn $currfn`; } EOR interchange-5.7.7.orig/code/UI_Tag/diffmerge.coretag0000644000000000000000000000737211352565025017203 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: diffmerge.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ # This tag uses GNU diff3 to merge two texts blocks that were # modified from the same ancestral text together, and marks # conflicts that may appear. This is similar to CVS's merging # and conflict marking. The names the diff3 manpage uses are: # # older # / \ # / \ # / \ # mine yours # # You supply pointers to three text blocks, either as file names or # database fields in the form Table::Column::Key. 'mine' can instead # be provided in the body, between the opening and closing tags. # # The tag returns the merged text. You can find out whether a # conflict was detected by providing the name of a scratch variable # in the 'result' option where the return code from diff3 will be placed. # # Set the 'ascii' option to allow for different newline types and # ignore whether the last line of the file has a newline. # # Set the 'safe_data' option to allow raw data to be pulled from the # database without escaping left brackets (turning [ into [). # # Examples: # # [diffmerge /tmp/abcd2 /tmp/abcd1 /tmp/abcd3] # # [diffmerge # yours="content::pagebody::00001" # older="backup::pagebody::00001" # ascii=1 # result=diff_result # safe_data=1 # ][scratch new_pagebody][/diffmerge] UserTag diffmerge Interpolate 1 UserTag diffmerge hasEndTag UserTag diffmerge addAttr UserTag diffmerge Version $Revision: 1.4 $ # These designations come from the diff3 manpage. # It seemed easier to use their names than to make up new ones. UserTag diffmerge Order yours older mine # But here I try to make up new ones anyway. :) UserTag diffmerge attrAlias <{flags} =~ /^[-\s\w.]*$/) { Log("diffmerge tag: Security violation with flags: $opt->{flags}"); return "Security violation with flags: $opt->{flags}. Logged."; } my ($minefn, $yoursfn, $olderfn, $cmd, $merge); my $tmpbasename = "tmp/$Vend::SessionName"; my $data_opt = {}; $data_opt->{safe_data} = 1 if $opt->{safe_data}; my $asciifix = sub { local $_ = shift; if ($opt->{ascii}) { s/\r\n?/\n/g; $_ .= "\n" unless substr($_, -1, 1) eq "\n"; } return $_; }; my $putfile = sub { my ($name, $passed, $fn) = @_; if ($$passed =~ /^(\w+)::(.*?)::(.*)/) { my ($table, $col, $key) = ($1, $2, $3); my $data = $asciifix->( tag_data($table, $col, $key, $data_opt) ); $$fn = "$tmpbasename.$name"; Vend::Util::writefile(">$$fn", $data); } else { $$fn = $$passed; } }; if ($body) { $body = $asciifix->($body); $minefn = "tmp/$Vend::SessionName.mine"; Vend::Util::writefile(">$minefn", $body); } elsif ($mine) { $putfile->('mine', \$mine, \$minefn); } $putfile->('yours', \$yours, \$yoursfn); $putfile->('older', \$older, \$olderfn); $cmd = "diff3 -m $opt->{flags} $minefn $olderfn $yoursfn"; #Debug("diffmerge command: '$cmd'"); $merge = `$cmd`; if (defined $opt->{result}) { unless ($opt->{result} =~ /\W/) { $Scratch->{$opt->{result}} = $? >> 8; #Debug("diffmerge put $Scratch->{$opt->{result}} into scratch $opt->{result}"); } else { Log("diffmerge tag: Invalid 'result' option given; must be a valid name for a scratch variable"); } } return $merge; } EOR interchange-5.7.7.orig/code/UI_Tag/directive_value.coretag0000644000000000000000000000155211352565025020417 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: directive_value.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag directive_value order name unparse UserTag directive_value PosNumber 2 UserTag directive_value Version $Revision: 1.4 $ UserTag directive_value Routine <{$1}/g; $parsed =~ s/__([A-Z]\w+?)__/$Vend::Cfg->{Variable}{$1}/g; } return ($parsed || $value); } EOR interchange-5.7.7.orig/code/UI_Tag/display.coretag0000644000000000000000000000156311352565025016714 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: display.coretag,v 1.14 2007-03-30 23:40:54 pajamian Exp $ UserTag display Order table column key UserTag display attrAlias base table UserTag display attrAlias database db UserTag display attrAlias col column UserTag display attrAlias row key UserTag display attrAlias code key UserTag display addAttr 1 UserTag display Interpolate 1 UserTag display posNumber 3 Require Module Vend::Table::Editor UserTag display Version $Revision: 1.14 $ UserTag display MapRoutine Vend::Table::Editor::display interchange-5.7.7.orig/code/UI_Tag/dump_session.coretag0000644000000000000000000000702211352565025017753 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: dump_session.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $ UserTag dump_session Order name UserTag dump_session AddAttr UserTag dump_session Version $Revision: 1.8 $ UserTag dump_session Routine <{$k}; $newref->{$k} = $ref->{$k}; } return $newref; } else { return { $key, $ref->{$key} }; } } sub { my ($name, $opt) = @_; my $joiner = $opt->{joiner} || ' '; return "Cannot dump or find sessions with session type $Vend::Cfg->{SessionType}." if ($Vend::Cfg->{SessionType} ne 'File' && $Vend::Cfg->{SessionType} ne 'DBI'); if ($Vend::Cfg->{SessionType} eq 'File') { if($opt->{find}) { require File::Find; my $expire = $Vend::Cfg->{SessionExpire}; if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) { $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60; } my $now = time(); $expire = $now - $expire; my @files; my $wanted = sub { return unless -f $_; return if (stat(_))[9] < $expire; return if /\.lock$/; push @files, $_; }; File::Find::find($wanted, $Vend::Cfg->{SessionDatabase}); return join $joiner, @files; } elsif (! $name) { return "dump-session: Nothing to do."; } else { my $fn = Vend::Util::get_filename($name, 2, 1, $Vend::Cfg->{SessionDatabase}); return '' unless -f $fn; my $ref = Vend::Util::eval_file($fn); $ref = show_part($ref, $opt->{key}) if $opt->{key}; my $out = ''; eval { $out = Vend::Util::uneval($ref); }; return uneval($ref) if $@; return $out; } } if ($Vend::Cfg->{SessionType} eq 'DBI') { if($opt->{find}) { my $expire = $Vend::Cfg->{SessionExpire}; if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) { $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60; } my $now = time(); $expire = $now - $expire; my @sesscodes; my $db = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB}) or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB}); my $dbh = $db->dbh(); my $tname = $db->name(); my $sql = "select code from $tname where UNIX_TIMESTAMP(last_accessed) >= ?"; my $sth = $dbh->prepare($sql); $sth->execute($expire) || return $DBI::errstr; my $code; $sth->bind_columns( undef, \$code); while($sth->fetch) { push @sesscodes, $code; } $sth->finish; return join $joiner, @sesscodes; } elsif (! $name) { return "dump-session: Nothing to do."; } else { my $db = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB}) or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB}); my $dbh = $db->dbh(); my $tname = $db->name(); my $sql = "select session from $tname where code=?"; my $sth = $dbh->prepare($sql); $sth->execute($name); my $session; $sth->bind_columns( undef, \$session); $sth->fetch; $sth->finish; my $out = ''; my $ref = Vend::Util::evalr($session); ## Allow show of only part $ref = show_part($ref, $opt->{key}) if $opt->{key}; eval { $out = Vend::Util::uneval($ref); }; return uneval($ref) if $@; return $out; } } } EOR interchange-5.7.7.orig/code/UI_Tag/export_database.coretag0000644000000000000000000000266511352565025020420 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: export_database.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag export-database Order table file type UserTag export-database addAttr UserTag export-database Version $Revision: 1.4 $ UserTag export-database Routine <{ui_export_database} or return undef; if($opt->{delete} and ! $opt->{verify}) { ::logError("attempt to delete field without verify, abort"); return undef; } if(!$file and $type) { #::logError("exporting as default type, no file specified"); undef $type; } $Vend::WriteDatabase{$table} = 1; if(! $opt->{field}) { #::logError("exporting:\ntable=$table\nfile=$file\ntype=$type\nsort=$opt->{sort}"); } elsif($opt->{field} and $opt->{delete}) { ::logError("delete field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n"); } elsif($opt->{field}) { ::logError("add field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n"); } return Vend::Data::export_database( $table, $file, $type, $opt, ); } EOR interchange-5.7.7.orig/code/UI_Tag/file_info.coretag0000644000000000000000000000306111352565025017174 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: file_info.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag file-info Order name UserTag file-info attrAlias file name UserTag file-info addAttr UserTag file-info Version $Revision: 1.4 $ UserTag file-info Routine <{server}) { $fn = "$Global::VendRoot/$fn" } elsif($opt->{conf}) { $fn = "$Global::ConfDir/$fn" } elsif($opt->{run}) { $fn = "$Global::RunDir/$fn" } my @stat = stat($fn); my %info; my @ary; my $size = $stat[7] < 1024 ? $stat[7] : ( $stat[7] < 1024 * 1024 ? sprintf ("%.2fK", $stat[7] / 1024) : sprintf ("%.2fM", $stat[7] / 1024 / 1024) ); if($opt->{flags}) { $opt->{flags} =~ s/\W//g; my @flags = split //, $opt->{flags}; for(@flags) { s/(.)/"-$1 _"/ee; } return join "\t", @flags; } if($opt->{size}) { return $stat[7]; } if($opt->{time}) { return $stat[9]; } if($opt->{date}) { return $Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},'%c'); } $opt->{fmt} = '%f bytes, last modified %Y-%m-%d %H:%M:%S' if ! $opt->{fmt}; $opt->{fmt} =~ s/%f/$size/g; $Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},$opt->{fmt}); } EOR interchange-5.7.7.orig/code/UI_Tag/file_navigator.coretag0000644000000000000000000002311411352565025020234 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: file_navigator.coretag,v 1.17 2007-12-21 03:32:43 mheins Exp $ UserTag file-navigator Order mask UserTag file-navigator addAttr UserTag file-navigator Version $Revision: 1.17 $ UserTag file-navigator Routine <{UI_BASE} || 'admin'); my $base_url = $Vend::Cfg->{VendURL} . '/' . ($opt->{base_url} || $base_admin); my $view_href = $opt->{view_href} || "$base_admin/do_view"; my $view_form = $opt->{view_form} || 'mv_arg=~FN~'; my $full_path; my $action = $CGI::values{action} || ''; my $already_found; my $edit_page = $opt->{edit_page} || "content_editor"; my $edit_form = $opt->{edit_form} || "ui_name=~FN~&ui_type=page"; my @errors; my @messages; my $idir_re; if ($opt->{initial_dir}) { $Vend::Session->{ui_cwd} = $opt->{initial_dir}; $idir_re = qr{^$opt->{initial_dir}/}; } if($action eq 'chdir') { my $newdir = $CGI::values{dir} || '.'; unless( Vend::File::allowed_file($newdir) ) { $Scratch->{ui_error} = ::errmsg('Security violation'); return interpolate_html("[bounce page='$base_admin/error']"); } if(! -d $newdir) { $Scratch->{ui_error} = ::errmsg("%s not a directory", $newdir); return interpolate_html("[bounce page='$base_admin/error']"); } $Vend::Session->{ui_cwd} = $newdir || '.'; } my $curdir = $Vend::Session->{ui_cwd} || '.'; $curdir =~ s:/+$::; my @files; FINDNAV: { if($action eq 'find') { my $regex; my $string = $CGI::values{find}; if($string !~ /\S/) { push @errors, ::errmsg("Refuse to find a blank or whitespace."); last FINDNAV; } elsif( $string =~ /\(\s*\?\s*\{/) { $Scratch->{ui_error} = ::errmsg('Security violation'); return interpolate_html("[bounce page='$base_admin/error']"); } else { eval { if($string =~ /\*/ and $string !~ /\.\*/) { $regex =~ s/\*/.*/g; } $regex = qr{$string}; }; } if($@ or ! $regex) { push @errors, ::errmsg("%s is not a good search.", $regex); last FINDNAV; } $full_path = 1; require File::Find; my $wanted; local($SIG{__WARN__}) = sub { push @errors, $_ }; my %exclude; if($CGI::values{find_action} =~ /\bfilename\b/) { $wanted = sub { push @files, $File::Find::name if $_ =~ $regex; }; } else { if($curdir eq '.' and ! $CGI::values{find_session}) { %exclude = (qw! ./session 1 session 1 tmp 1 ./tmp 1!); } $wanted = sub { local ($/) = undef; if( -d $_ and $exclude{$File::Find::dir}) { $File::Find::prune = 1; return; } return unless -f _; -s _ > 1_000_000 and do { push(@errors, errmsg("%s: refuse to find in megabyte-sized files", $File::Find::name) ); return; }; open(TMPFINDNAV, "< $_") or do { push(@errors, errmsg("%s: permission denied", $File::Find::name) ); return; }; my $str = ; $str =~ $regex and push (@files, $File::Find::name); return; }; } File::Find::find($wanted, $curdir); s:^./:: for @files; if(@files) { push @messages, errmsg("Found %s files.", scalar @files); $already_found = 1; } else { undef $full_path; push @errors, errmsg("No files found."); } } } if($already_found) { # do nothing } elsif($curdir eq '.') { if($dir_mask eq '*') { @files = grep $_ ne 'CVS', glob('*'); } else { @files = split /\s+/, $dir_mask; } } else { @files = grep $_ !~ m{/CVS$}, glob("$curdir/*"); } my $this_page = $Global::Variable->{MV_PAGE}; my $this = Vend::Interpolate::tag_area($this_page); $this =~ s/\?(.*)//; my $up_img = qq{}; my $dn_img = qq{}; my $vw_img = qq{}; my $ed_img = qq{}; my $dir_img = qq{}; my $del_img = qq{}; my $sp_img = qq{}; my $do_perms; $opt->{details} = $CGI->{details} unless defined $opt->{details}; if(defined $opt->{details}) { $do_perms = $opt->{details}; } elsif (defined $CGI->{details}) { $do_perms = $Session->{ui_file_details} = $CGI->{details}; } else { $do_perms = $Session->{ui_file_details}; } my $del_string = ''; $Tag->if_mm('advanced', 'delete_files') and do { $del_string = qq{$del_img}; }; my $ftmpl = <$dn_img$del_string$up_img$vw_img %s %s
    EOF my $utmpl = <$up_img %s %s
    EOF my $ftmpl_ed; if(! $do_perms and $opt->{edit_only}) { $ftmpl_ed = <$ed_img %s %s
    EOF } else { $ftmpl_ed = <$dn_img$del_string$up_img$ed_img %s %s
    EOF } my $dtmpl = <$dir_img %s %s
    EOF $dtmpl = "$sp_img$sp_img$sp_img$dtmpl" if $do_perms; my @out; my $out; my @dir; my @plain; sub perm_line { my $fn = shift; my @perm = qw/ --- --x -w- -wx r-- r-x rw- rwx /; my @det; if (-l $fn) { @det = lstat($fn); } else { @det = stat(_); } my $time = POSIX::strftime("%d-%b-%Y %H:%M:%S", localtime($det[9])); my $permstring = sprintf('%04o', $det[2]); #push @messages, "$_ perms=$permstring\n"; $permstring = substr($permstring, -3, 3); my $top; my (@ugo) = split //, $permstring; @ugo = map { $_ = $perm[$_] } @ugo; if (-l _) { $top = 'l' } elsif (-d _) { $top = 'd' } elsif (-f _) { $top = '-' } else { $top = '?' } $ugo[0] =~ s/.$/s/ if $det[2] & S_ISUID(); $ugo[1] =~ s/.$/s/ if $det[2] & S_ISGID(); $ugo[2] =~ s/.$/t/ if $det[2] & S_ISVTX(); my $user = getpwuid($det[4]); my $grp = getgrgid($det[5]); $grp = substr($grp, 0, 8) if length($grp) > 8; $user = substr($grp, 0, 8) if length($user) > 8; my $perm = join "", $top, @ugo; my $ret = sprintf(" %s %-8s %-8s %s", $perm, $user, $grp, $time); $ret =~ s/ / /g; return $ret; } my $perms = ''; for(@files) { my $fn = $_; $fn =~ s:.*/:: unless $full_path; my $fe = $_; $fe =~ s!([^-\w./:,])!sprintf('%%%02x', ord($1) )!eg; my $perms; $perms = perm_line($_) if($do_perms); if(-d $_) { push @dir, [$fe, $fn, $dtmpl, $perms]; } elsif ($opt->{edit_all} || ($opt->{edit_only} && /\.html?$/) ) { my $rn = $curdir . "/$fn"; $rn =~ s{$idir_re}{} if $idir_re; push @plain, [$fe, $fn, $ftmpl_ed, $perms, $rn]; } else { push @plain, [$fe, $fn, $ftmpl, $perms]; } } $opt->{top_of_tree} ||= '.'; my $nd = $curdir; if($nd ne $opt->{top_of_tree} and ! $opt->{no_up}) { $nd =~ s:/[^/]*$:: or $nd = $opt->{top_of_tree}; my $msg = '.. [' . errmsg ($opt->{parent_directory_message} || 'parent directory') . ']'; unshift @dir, [ $nd, $msg, $dtmpl ]; } my $pc = \$Vend::Session->{pageCount}; unshift @dir, [ "$curdir/", errmsg('(new file)'), $utmpl ] unless $opt->{no_new_file}; @dir = () if $opt->{no_dirs}; for(@errors) { $out .= "$_
    "; } for(@messages) { $out .= "$_
    "; } my $template = $opt->{template} || ''; for (@dir, @plain) { $$pc++; $_->[2] = sprintf($_->[2], $_->[3], $_->[1]); $_->[2] =~ s/~FN~/$_->[0]/g; $_->[2] =~ s/~RN~/$_->[4]/g; $_->[2] =~ s/~ID~/mv_session_id=$Session->{id}&mv_pc=$$pc/g; if($template) { my $t = $template; $t =~ s/%s/$_->[2]/; $out .= $t; } else { $out .= $_->[2]; } } return $out; } EOR interchange-5.7.7.orig/code/UI_Tag/flex_select.coretag0000644000000000000000000011023511535625651017546 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: flex_select.coretag,v 1.18 2009-05-01 16:02:50 mheins Exp $ UserTag flex-select Order table UserTag flex-select addAttr UserTag flex-select attrAlias ml height UserTag flex-select hasEndTag UserTag flex-select Version $Revision: 1.18 $ UserTag flex-select Routine <{mv_more_ip}) { for(@fs_more) { $CGI->{$_} = $::Values->{$_}; } } if($CGI->{mv_return_table}) { my $rt = delete $CGI->{mv_return_table}; $rt =~ s/^\0+//; $rt =~ s/\0.*//; $CGI->{mv_data_table} = $rt if $rt; } my $bounce_url; $::Scratch->{ui_class} = $CGI->{ui_class} if $CGI->{ui_class} && $CGI->{ui_class} =~ /^\w+$/; if($opt->{sql_query}) { my $spec; eval { ($table) = Vend::Scan::sql_statement($opt->{sql_query}, { table_only => 1}); }; if($@) { $Tag->error( { set => errmsg( "flex-select -- bad query %s: %s", $opt->{sql_query}, $@, ), name => 'flex_select', }); return undef; } } if($table =~ s/\.(txt|asc)$/_$1/) { $table =~ s:.*/::; } my $db = database_exists_ref($table); $Tmp->{flex_select} ||= {}; my $ts = $Tmp->{flex_select}{$table} = {}; if(! $db) { $Tag->error({ name => 'flex_select', set => errmsg('no %s database', $table), }); my $url = $Tag->area( { href => $::Variable->{UI_ERROR_PAGE} || 'admin/error', secure => $::Variable->{UI_SECURE}, }); #::logDebug("delivering error url=$url"); $Tag->deliver( { location => $url }); return; } if( $::Variable->{UI_LARGE_TABLE} =~ /\b$table\b/ or $db->config('LARGE') ) { $ts->{large} = 1; } if( $db->config('COMPOSITE_KEY') ) { $ts->{multikey} = 1; $ts->{key_columns} = $db->config('_Key_columns'); } DELETE: { last DELETE unless $CGI->{item_id}; last DELETE unless delete $CGI->{deleterecords}; unless ($Tag->if_mm('tables', '=d')) { $Tag->error({ name => 'flex_select', set => errmsg("no permission to delete records"), }); last DELETE; }; $Vend::Cfg->{NoSearch} = ''; my @ids = split /\0/, $CGI->{item_id}; for(grep $_, @ids) { if($db->delete_record($_)) { push @warnings, errmsg("Deleted record %s", $_); } else { push @errors, $db->errstr(); } } } SEQUENCE: { my $dest = $CGI->{ui_sequence_destination} || '__UI_BASE__/flex_editor'; #::logDebug("Entering flex_select sequence edit stuff"); last SEQUENCE unless $CGI->{ui_sequence_edit}; #::logDebug("doing flex_select sequence edit stuff"); my $doit; if($CGI->{item_id_left} =~ s/^(.*?)[\0]//) { $CGI->{ui_sequence_edit} = 1; $CGI->{item_id} = $1; $doit = 1; } elsif ($CGI->{item_id_left}) { $CGI->{item_id} = delete $CGI->{item_id_left}; delete $CGI->{ui_sequence_edit}; $doit = 1; } else { delete $CGI->{item_id}; delete $CGI->{ui_sequence_edit}; } last SEQUENCE unless $doit; my $url = $Tag->area( { href => $dest, form => qq{ mv_data_table=$CGI->{mv_data_table} item_id=$CGI->{item_id} item_id_left=$CGI->{item_id_left} ui_sequence_edit=$CGI->{ui_sequence_edit} }, }); #::logDebug("flex_select sequence developed URL=$url"); $Tag->deliver( { location => $url } ); return; } $ts->{table_meta} = $Tag->meta_record($table, $CGI->{ui_meta_view}) || {}; my $tm = $ts->{table_meta}; my $extra; if($tm->{name}) { $extra .= "$tm->{name}
    "; } if($ts->{help_url}) { $extra .= qq{   }; $extra .= errmsg('help'); $extra .= ""; } if($ts->{help}) { $extra .= "
    $ts->{help}
    "; } $::Scratch->{page_banner} ||= $::Scratch->{page_title}; $::Scratch->{page_banner} .= $extra; for(@errors) { $Tag->error({ name => 'flex_select', set => $_ }); } for(@warnings) { $Tag->warnings($_); } return; } sub { my ($table, $opt, $body) = @_; #::logDebug("Entering flex_select"); my $CGI = \%CGI::values; $table ||= $CGI->{mv_data_table}; ## Do the initialization if($opt->{init}) { return flex_select_init($table, $opt); } my $filter; if(ref($opt->{filter}) eq 'HASH') { $filter = $opt->{filter}; } $filter ||= {}; my $spec; my $stmt; my $q; if($opt->{sql_query}) { $q = $opt->{sql_query}; if($CGI->{ui_sort_field} =~ s/^(\w+)(:[rfn]+)?$/$1/) { my $field = $1; my $opt = $2 || $CGI->{ui_sort_option}; $field .= ' DESC', $CGI->{ui_sort_option} = 'r' if $opt =~ /r/i; $q =~ s/ \s+ORDER\s+BY \s+(\w+(\s+desc\w*)?) (\s*,\s*\w+(\s+desc\w*)?)* (\s*$|\s+LIMIT\s+\d+(?:\s*,\s*\d+)?) / ORDER BY $field$5/ix or $q =~ s/(\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)/ ORDER BY $field$1/ix or $q .= " ORDER BY $field"; } eval { ($spec) = Vend::Scan::sql_statement($q); }; if($@ || ! $spec->{rt}) { $Tag->error( { set => errmsg("flex-select -- bad query %s: %s", $q, $@), name => 'flex_select', }); return undef; } $table = $spec->{rt}->[0]; } my $ref = dbref($table) or do { my $msg = errmsg("%s: table '%s' does not exist", 'flex_select', $table); logError($msg); $Tag->error({ name => 'flex_select', set => $msg }); return undef; }; my $ts = $Tmp->{flex_select}{$table} ||= {}; my $meta = $ts->{table_meta} ||= $Tag->meta_record($table, $CGI->{ui_meta_view}); #::logDebug("flex_select table=$table"); if($meta->{sql_query}) { $q = $meta->{sql_query}; if($CGI->{ui_sort_field} =~ s/^(\w+)(:[rfn]+)?$/$1/) { my $field = $1; my $opt = $2 || $CGI->{ui_sort_option}; $field .= ' DESC', $CGI->{ui_sort_option} = 'r' if $opt =~ /r/i; $q =~ s/ \s+ORDER\s+BY \s+(\w+(\s+desc\w*)?) (\s*,\s*\w+(\s+desc\w*)?)* (\s*$|\s+LIMIT\s+\d+(?:\s*,\s*\d+)?) / ORDER BY $field$5/ix or $q =~ s/(\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)/ ORDER BY $field$1/ix or $q .= " ORDER BY $field"; } eval { ($spec) = Vend::Scan::sql_statement($q); }; if($@ or ! $spec->{rt}) { $Tag->error( { set => errmsg("flex-select -- bad query %s: %s", $q, $@), name => 'flex_select', }); return undef; } $table = $spec->{rt}->[0]; } if( $table ne $ref->config('name')) { ## Probably transient database $CGI->{mv_data_table_real} = $table = $ref->config('name'); } my @labels; ## Locally set labels in ui_show_fields my @views; ## Locally set view data in ui_show_fields my @filter_show; ## Locally set filters in ui_show_fields my @calcs; ## Data calculation code (if any) from fs_data_calc my @redirect; ## A column with a different metadata from standard my @extras; ## A column with a different metadata from standard my @style; ## Style for data cell, only have to read once my @link_page; ## Locally set filters in ui_show_fields my @link_parm; ## Locally set filters in ui_show_fields my @link_parm_extra; ## Locally set filters in ui_show_fields my @link_anchor; ## Locally set filters in ui_show_fields my $filters_done; ## Tells us we are done with filters if(my $show = $CGI->{ui_show_fields} ||= $meta->{ui_show_fields} || $meta->{field}) { my $i = 0; if($show =~ s/[\r\n]+/\n/g) { $show =~ s/^\s+//; $show =~ s/\s+$//; my @f = split /\n/, $show; my @c; for(@f) { s/^\s+//; s/\s+$//; if(s/\s*\((.+)\)\s*$//) { $filter_show[$i] = $1; } if(/^(\w+)-(\w+)$/) { push @c, $1; $redirect[$i] = $2; } elsif(/^(\w+)(?:-([^=]+))?(?:=(.*))?/) { push @c, $1; $views[$i] = $2 if $2; $labels[$i] = $3; } else { push @c, $_; } $i++; } $show = join ",", @c; } else { $show =~ s/(\w+)(?:\((.*?)\))?/ ($filter_show[$i++] = $2), $1/eg; $show =~ s/[\0,\s]+/,/g; } $CGI->{ui_description_fields} = $show; $filters_done = 1; } if($spec) { #::logDebug("flex_select spec=$spec"); if($spec->{rf} and $spec->{rf}[0] ne '*') { my @c; my $header; for(my $i = 0; $i < @{$spec->{rf}}; $i++) { if($spec->{hf}[$i]) { $header++; push @c, $spec->{rf}[$i] . '=' . $spec->{hf}[$i]; } else { push @c, $spec->{rf}[$i]; } } if($header) { $CGI->{ui_show_fields} = join "\n", @c; } else { $CGI->{ui_show_fields} = join " ", @c; } } if($spec->{tf} and $spec->{tf}[0]) { $CGI->{ui_sort_field} = join ",", @{$spec->{tf}}; $CGI->{ui_sort_option} = join ",", @{$spec->{to}}; } $CGI->{ui_list_size} = $spec->{ml} if $spec->{ml}; } $meta ||= {}; if($CGI->{ui_flex_key}) { $ts->{keypos} = $CGI->{ui_flex_key}; } else { $ts->{keypos} = $ref->config('KEY_INDEX'); } $ts->{keyname} = $ref->config('KEY'); $ts->{owner_field} = $ref->config('OWNER_FIELD') || $::Scratch->{ui_owner}; if($CGI->{ui_exact_record}) { #::logDebug("found exact record input"); undef $CGI->{mv_like_field}; my $id = $CGI->{mv_like_spec}; $id =~ s/\0.*//s; my $url = $Tag->area({ href => 'admin/flex_editor', form => qq{ mv_data_table=$CGI->{mv_data_table} item_id=$id ui_meta_view=$CGI->{ui_meta_view} }, }); $Tag->deliver({ location => $url }); #::logDebug("deliver=$url"); return; } my $sf; if($sf = $CGI->{ui_sort_field} and $sf =~ s/^(\w+)([,\s\0]+.*)?$/$1/) { my $fmeta; $fmeta = $Tag->meta_record("${table}::$sf", $CGI->{ui_meta_view}) and do { $CGI->{ui_more_alpha} = $fmeta->{ui_more_alpha} if length($fmeta->{ui_more_alpha}); if (! $CGI->{ui_sort_option} and length($fmeta->{ui_sort_option}) ) { my $o = $fmeta->{ui_sort_option}; if($CGI->{ui_sort_option} =~ /r/) { $o =~ s/^([^r]+)$/$1r/ or $o =~ s/r//; } $CGI->{ui_sort_option} = $o; } }; } for(qw/ui_more_alpha ui_more_decade ui_meta_specific/) { $CGI->{$_} = $meta->{$_} unless defined $CGI->{$_}; } $Vend::Cfg->{NoSearch} = ''; my $out_message = ''; my $ui_text_qualification = $CGI->{ui_text_qualification}; if ($ui_text_qualification and $CGI->{ui_text_qualification} =~ /[\^]/ ) { if($ts->{owner_field}) { $CGI->{ui_text_qualification} = <{owner_field} se=$Vend::username op=eq nu=0 os=0 su=0 bs=0 EOF } else { $CGI->{ui_text_qualification} = "co=1\n"; } my @entries = split /\s+(and|or)\s+/i, $ui_text_qualification; my $or; for(@entries) { if(/^or$/i) { $or = 1; $CGI->{ui_text_qualification} .= "os=1\n"; next; } elsif(/^and$/i) { $or = 0; $CGI->{ui_text_qualification} .= "os=0\n"; next; } my ($f, $op, $s) = split /\s*([<=!>\^]+)\s*/, $_, 2; $op = "eq" if $op eq "=="; $op = "rm" if $op eq "="; if($op eq '^') { $op = 'rm'; $CGI->{ui_text_qualification} .= "bs=1\nsu=1\n"; } else { $CGI->{ui_text_qualification} .= "bs=0\nsu=0\n"; } if(length($s) > 1) { $CGI->{ui_text_qualification} .= "se=$s\nsf=$f\nop=$op\n"; } else { $CGI->{ui_text_qualification} .= "se=.\nsf=$f\nop=rn\n"; } if($op =~ /[<>]/ and $s =~ /^[\d.]+$/) { $CGI->{ui_text_qualification} .= "nu=1\n"; } else { $CGI->{ui_text_qualification} .= "nu=0\n"; } } if(defined $or) { $CGI->{ui_text_qualification} .= $or ? "os=1\n" : "os=0\n"; } $out_message = errmsg('Entries matching "%s"', $ui_text_qualification); } elsif ($ui_text_qualification) { $CGI->{ui_text_qualification} = "se=$CGI->{ui_text_qualification}"; $out_message = errmsg('Entries matching "%s"', $ui_text_qualification); if($ts->{owner_field}) { $CGI->{ui_text_qualification} = <{owner_field} se=$Vend::username op=eq sf=:* se=$CGI->{ui_text_qualification} EOF } } elsif ( $CGI->{mv_like_field} ) { my @f = split /\0/, $CGI->{mv_like_field}; my @s = split /\0/, $CGI->{mv_like_spec}; my @q = 'ra=yes'; my $found; for(my $i = 0; $i < @f; $i++) { next unless length $s[$i]; $found++; push @q, "lf=$f[$i]"; push @q, "ls=$s[$i]"; } if($found) { $CGI->{ui_text_qualification} = join "\n", @q; my @out; for(@q) { my $thing = $_; $thing =~ s/^ls=/mv_like_spec=/; $thing =~ s/^lf=/mv_like_field=/; push @out, $thing; } $ts->{like_recall} = join "\n", @out; } else { $CGI->{ui_text_qualification} = "" } } elsif($ts->{owner_field}) { $CGI->{ui_text_qualification} = <{owner_field} se=$Vend::username op=eq EOF } elsif ($ts->{large}) { my $keylabel = $Tag->display({ table => $table, name => 'item_id', column => $ts->{keyname}, template => 1, }); $ts->{like_spec} = $CGI->{mv_more_ip} ? 0 : 1; $CGI->{ui_text_qualification} = ""; } else { $CGI->{ui_text_qualification} = "ra=yes"; } if($meta->{ui_sort_combined} =~ /\S/) { $meta->{ui_sort_field} = $meta->{ui_sort_combined}; $meta->{ui_sort_option} = ''; } $CGI->{ui_sort_field} ||= $meta->{ui_sort_field} || $meta->{lookup} || $ts->{keyname}; $CGI->{ui_sort_option} ||= $meta->{ui_sort_option}; $CGI->{ui_sort_option} =~ s/[\0,\s]+//g; $CGI->{ui_list_size} = $opt->{height} || $meta->{height} if ! $CGI->{ui_list_size}; if(! $CGI->{ui_show_fields} ) { $CGI->{ui_show_fields} = $CGI->{ui_description_fields} = join ",", $ref->columns(); } else { my $i = 0; my $show = $CGI->{ui_show_fields}; if($filters_done) { # do nothing } else { if($show =~ s/[\r\n]+/\n/g) { $show =~ s/^\s+//; $show =~ s/\s+$//; my @f = split /\n/, $show; my @c; for(@f) { s/^\s+//; s/\s+$//; if(s/\s*\((.+)\)\s*$//) { $filter_show[$i] = $1; } if(/^(\w+)-(\w+)$/) { push @c, $1; $redirect[$i] = $2; } elsif(/^(\w+)(?:-([^=]+))?(?:=(.*))?/) { push @c, $1; $views[$i] = $2 if $2; $labels[$i] = $3; } else { push @c, $_; } $i++; } $show = join ",", @c; } else { $show =~ s/(\w+)(?:\((.*?)\))?/ ($filter_show[$i++] = $2), $1/eg; $show =~ s/[\0,\s]+/,/g; } $CGI->{ui_description_fields} = $show; } } my @cols = split /,/, $CGI->{ui_description_fields}; @cols = grep $ref->column_exists($_), @cols unless $spec; my %limit_field; $CGI->{ui_limit_fields} =~ s/[\0,\s]+/ /g; $CGI->{ui_limit_fields} =~ s/^\s+//; $CGI->{ui_limit_fields} =~ s/\s+$//; my (@limit_field) = split " ", $CGI->{ui_limit_fields}; if(@limit_field) { @limit_field{@limit_field} = (); @cols = grep ! exists($limit_field{$_}), @cols; } unshift(@cols, $ts->{keyname}) if $cols[0] ne $ts->{keyname}; $CGI->{ui_description_fields} = join ",", @cols; unless ($CGI->{ui_sort_option}) { $CGI->{ui_sort_option} = 'n' if $ref->numeric($CGI->{ui_sort_field}); } my $fi = $CGI->{mv_data_table_real} || $CGI->{mv_data_table}; $ts->{sparams} = ($ts->{like_spec} || $spec) ? '' : <{ui_text_qualification} su=1 ma=$CGI->{ui_more_alpha} md=$CGI->{ui_more_decade} ml=$CGI->{ui_list_size} tf=$CGI->{ui_sort_field} to=$CGI->{ui_sort_option} rf=$CGI->{ui_description_fields} nh=1 EOF $::Scratch->{page_banner} .= $out_message; $::Scratch->{page_title} .= $out_message; my %output; ### Header determination my @refkeys = grep ref($opt->{$_}) eq 'HASH', keys %$opt; my %default = ( data_cell_class => '', data_cell_style => '', data_row_class_even => 'rownorm', data_row_class_odd => 'rowalt', data_row_style_even => '', data_row_style_odd => '', form_method => 'GET', explicit_edit => '', explicit_edit_page => '', explicit_edit_form => '', explicit_edit_anchor => '', no_code_link => '', group_image => 'smindex.gif', group_class => 'rhead', group_spacing => 2, group_padding => 0, group_width => '100%', header_link_class => 'rhead', header_cell_class => 'rhead', header_cell_style => '', header_row_class => 'rhead', header_row_style => '', mv_action => 'back', meta_image => errmsg('meta.png'), label => "flex_select_$table", no_checkbox => 0, radio_box => 0, user_merge => 0, check_uncheck_all => 0, number_list => 0, table_border => 0, table_class => 'rseparator', table_padding => 0, table_spacing => 1, table_style => '', table_width => '100%', ); for(keys %default) { next if defined $opt->{$_}; if(length $meta->{$_}) { $opt->{$_} = $meta->{$_}; } else { $opt->{$_} = $default{$_}; } } $opt->{ui_style} = 1 unless defined $opt->{ui_style}; $opt->{no_checkbox} = 1 if $ts->{multikey}; my $show_meta; my $meta_anchor; if($Tag->if_mm('super') and ! $opt->{no_meta}) { $show_meta = defined $::Values->{ui_meta_force} ? $::Values->{ui_meta_force} : $::Variable->{UI_META_SELECT}; if($opt->{meta_image}) { $meta_anchor = qq{}; } else { $meta_anchor = 'M'; } } $opt->{form_name} ||= "fs_$table"; $output{TOP_OF_TABLE} = < EOF my $cwp = $Global::Variable->{MV_PAGE}; $opt->{form_href} ||= $CGI->{ui_searchpage} || $cwp; $opt->{form_extra} ||= ''; $opt->{form_extra} .= qq{ name="$opt->{form_name}"} if $opt->{form_name}; $opt->{form_extra} =~ s/^\s*/ /; my $action = $Tag->process({href => $opt->{form_href}}); $output{TOP_OF_FORM} = <{form_extra}> EOF ### What the heck is going on here? if($CGI->{ui_meta_view}) { $output{TOP_OF_FORM} .= < EOF $output{TOP_OF_FORM} .= $Tag->return_to(); } else { $output{TOP_OF_FORM} .= < EOF } my $cc = $ts->{column_meta} ||= {}; my $mview = $CGI->{ui_meta_view}; my $cmeta = sub { my $col = shift; return $cc->{$col} if $cc->{$col}; my $m = $Tag->meta_record("${table}::$col", $mview); for(@refkeys) { $m->{$_} = $opt->{$_}{$col} if exists $opt->{$_}{$col}; } $cc->{$col} = $m; return $m; }; my $header_cell_style = sub { my $col = shift; my $m = $cmeta->($col); #::logDebug("meta for header=" . ::uneval($m)); my $stuff = ''; for(qw/ class style align valign /) { my $tag = "header_cell_$_"; my $thing; if(ref $opt->{$tag}) { $thing = $opt->{$tag}{$col} || $m->{$tag} || $opt->{"all_$tag"} or next; } else { $thing = $m->{$tag} || $opt->{$tag} or next; } encode_entities($thing); $stuff .= qq{ $_="$thing"}; } return $stuff; }; my $data_cell_style = sub { my $col = shift; my $m = $cmeta->($col); my $stuff = ''; for(qw/ class style align valign /) { my $tag = "data_cell_$_"; my $thing; if(ref $opt->{$tag}) { $thing = $opt->{$tag}{$col} || $m->{$tag} || $opt->{"all_$tag"} or next; } else { $thing = $m->{$tag} || $opt->{$tag} or next; } encode_entities($thing); $stuff .= qq{ $_="$thing"}; } return $stuff; }; my @head; my $rc = $opt->{header_row_class}; push @head, "{header_row_class}) if $opt->{header_row_class}; push @head, qq( style=$opt->{header_row_style}) if $opt->{header_row_style}; push @head, ">\n"; if(! $opt->{no_checkbox}) { push @head, "  " } if($opt->{radio_box}) { push @head, "  " } if($opt->{number_list}) { push @head, " # " ; } if($opt->{explicit_edit}) { push @head, "  " } my $return = <{ui_meta_view} ui_return_to=mv_return_table=$table mv_return_table=$table ui_return_stack=$CGI->{ui_return_stack} start_at=extended.ui_more_alpha EOF my %mkey; if($ts->{multikey}) { for(@{$ts->{key_columns}}) { $mkey{$_} = 1; } } my @mcol; my $idx = 0; foreach my $col (@cols) { my $mcol = $col; if($redirect[$idx]) { $mcol .= "-$redirect[$idx]"; } my $td_extra = $header_cell_style->($mcol); ## $cc is set in header_cell_class my $m = $cc->{$mcol}; if($mkey{$col}) { push @mcol, $idx - 1; } push @head, < {group_spacing} cellpadding=$opt->{group_padding} width="$opt->{group_width}"> EOF unless($opt->{no_group} || $m->{fs_no_group}) { my $u = $Tag->area({ href => 'admin/flex_group', form => qq( mv_data_table=$table ui_meta_view=$mview from_page=$Global::Variable->{MV_PAGE} mv_arg=$col ), }); my $msg = errmsg('Select group by %s', $col); push @head, < EOF } my $o = ''; my $msg; my $rmsg; if($o = $m->{ui_sort_option}) { my @m; $msg = "sort by %s (%s)"; if($CGI->{ui_sort_field} eq $col) { if($CGI->{ui_sort_option} =~ /r/) { $o =~ s/r//; } else { $o .= "r"; } } push @m, errmsg('reverse') if $o =~ /r/; push @m, errmsg('case insensitive') if $o =~ /f/; push @m, errmsg('numeric') if $o =~ /n/; $rmsg = join ", ", @m; } else { if ($CGI->{ui_sort_field} eq $col and $CGI->{ui_sort_option} !~ /r/) { $o .= 'r'; $msg = "sort by %s (%s)"; $rmsg = errmsg('reverse'); } else { $msg = "sort by %s"; } $o .= 'n' if $ref->numeric($col); } my $sort_msg = errmsg($msg, $col, $rmsg); my $url = $Tag->area( { href => $cwp, form => qq( $ts->{like_recall} ui_text_qualification=$ui_text_qualification mv_data_table=$table ui_meta_view=$mview ui_sort_field=$col ui_sort_option=$o ui_more_alpha=$m->{ui_more_alpha} ), }); my $lab = $labels[$idx] || $m->{label} || $col; # Set up some stuff for the data cells; $style[$idx] = $data_cell_style->($mcol); $filter_show[$idx] = $filter->{$mcol} if $filter->{$mcol}; $filter_show[$idx] ||= $m->{fs_display_filter} || 'encode_entities'; $filter_show[$idx] .= ' encode_entities' unless $filter_show[$idx] =~ /\b(?:encode_)?entities\b/; $style[$idx] .= " $1" while $filter_show[$idx] =~ s/(v?align=\w+)//i; if($views[$idx]) { my ($page, $parm, $l) = split /:/, $views[$idx]; $m->{fs_link_page} = $page; $parm ||= 'item_id'; my @p = split /[\s,\0]+/, $parm; my $arg = shift @p; $m->{fs_link_parm} = $arg; $m->{fs_link_parm_extra} = join ",", @p; $m->{fs_link_anchor} = $l; } if($m->{fs_link_page}) { $link_page[$idx] = $m->{fs_link_page}; $link_parm[$idx] = $m->{fs_link_parm}; if($m->{fs_link_parm_extra}) { my @p = grep /\S/, split /[\s,\0]+/, $m->{fs_link_parm_extra}; $link_parm_extra[$idx] = \@p; } $link_anchor[$idx] = $m->{fs_link_anchor}; } if(my $prog = $m->{fs_data_calc}) { #::logDebug("looking at calcs=$prog"); $prog =~ s/^\s+//; $prog =~ s/\s+$//; if($prog =~ /^\w+$/) { $calcs[$idx] = $Vend::Cfg->{Sub}{$prog} || $Global::GlobalSub->{$prog}; } else { $prog =~ s/^\[(calc|perl)(.*?)\]//; $prog =~ s{\[/(calc|perl)\]$}{}; $calcs[$idx] = $prog; } if($m->{fs_data_tables}) { tag_perl($m->{fs_data_tables}, {}); } } push @head, < {header_link_class} title="$sort_msg">$lab EOF if($show_meta) { my $u = $Tag->area({ href=>'admin/meta_editor', form => qq( item_id=${table}::$mcol ui_meta_view=$mview $return), }); my $tit = errmsg( "Edit header meta information for %s::%s", $table, $col, ); push @head, < $meta_anchor EOF } push @head, <
    EOF $idx++; } push @head, ""; shift @mcol; my $ncols = $idx; $ncols++ if $opt->{explicit_edit}; $ncols++ if $opt->{number_list}; $ncols++ if $opt->{radio_box}; $ncols++ unless $opt->{no_checkbox}; $output{HEADER_AREA} = join "", @head; ### Row output my $cb_width = $opt->{checkbox_width} || '30'; my $cb_name = $opt->{checkbox_name} || 'item_id'; my $rb_name = $opt->{radiobox_name} || 'item_radio'; my $edit_page = $opt->{edit_page} || 'admin/flex_editor'; my $edit_parm = $opt->{edit_parm} || 'item_id'; my $edit_extra = <{ui_page_title} ui_meta_view=$mview ui_page_banner=$CGI->{ui_page_banner} ui_meta_specific=$CGI->{ui_meta_specific} EOF my @rows; if($ts->{like_spec}) { ## Do nothing } elsif($body =~ /\S/) { my $o = { label => $opt->{label}, list_prefix => 'flex', prefix => 'flex', more => 1, search => $ts->{sparams}, }; push @rows, tag_loop_list($o); } else { my $ary; my $search; my $params; my $c; #::logDebug("MM=$CGI->{MM}($CGI::values{MM}) mv_more_matches=$CGI->{mv_more_matches}($CGI::values{mv_more_matches})"); if($CGI->{mv_more_ip}) { $search = $::Instance->{SearchObject}{$opt->{label}}; $search ||= $::Instance->{SearchObject}{''}; $search ||= perform_search(); $ary = [ splice( @{$search->{mv_results}}, $search->{mv_first_match}, $search->{mv_matchlimit}, )] ; #::logDebug("search first_match=$search->{mv_first_match} length=$search->{mv_matchlimit}"); #::logDebug("Found search=" . ::uneval($search)); } elsif($q) { my $db = dbref($table); my $o = { ma => $CGI->{ui_more_alpha}, md => $CGI->{ui_more_decade}, ml => $CGI->{ui_list_size}, more => 1, table => $fi, query => $q, }; $ary = $db->query($o); } else { #::logDebug("In new search"); $params = escape_scan($ts->{sparams}); $c = { mv_search_immediate => 1, mv_search_label => $opt->{label} }; Vend::Scan::find_search_params($c, $params); $search = Vend::Scan::perform_search($c); $ary = $search->{mv_results}; } finish_search($search) if $search; $search ||= {}; if($CGI->{ui_return_to} and ! $CGI->{ui_return_stack}) { $edit_extra .= $Tag->return_to('formlink'); } else { $edit_extra .= "ui_return_to=$cwp"; } my $edit_anchor; my $ee_extra; if($opt->{explicit_edit}) { $edit_anchor = $opt->{explicit_edit_anchor} || errmsg('edit record'); $edit_anchor =~ s/ / /g; $ee_extra = ''; for(qw/ class style width align valign /) { my $v = $opt->{"explicit_edit_$_"} or next; $ee_extra .= qq{ $_="$v"}; } $ee_extra ||= ' width=30'; } #::logDebug("explicit_edit=$opt->{explicit_edit} no_code_link=$opt->{no_code_link}"); my $j = $search->{mv_first_match} || 0; foreach my $line (@$ary) { my $code = shift (@$line); my $ecode = encode_entities($code); my $rc = $j++ % 2 ? $opt->{data_row_class_even} : $opt->{data_row_class_odd}; my $out = qq{\n}; my $code_pre; my $code_post; my $ep_string = ''; if($opt->{no_code_link} and ! $opt->{explicit_edit}) { $code_pre = $code_post = ''; } else { my @what; push @what, "$edit_parm=$code"; if($ts->{multikey}) { unshift @what, 'ui_multi_key=1'; for(@mcol) { push @what, "$edit_parm=$line->[$_]"; } } $ep_string = join "\n", @what, $edit_extra; my $edit_url = $Tag->area({ href => $edit_page, form => $ep_string, }); my $msg = errmsg('edit %s', $ecode); $code_pre = qq{}; $code_post = qq{}; } unless($opt->{no_checkbox}) { $out .= < EOF } if($opt->{radio_box}) { $out .= < EOF } if($opt->{number_list}) { $out .= qq{ $j }; } if($opt->{explicit_edit}) { my $form = $opt->{explicit_edit_form} || ''; if($form) { $form .= $ecode; } my $url = $Tag->area({ href => $opt->{explicit_edit_page} || $edit_page, form => $form || $ep_string, }); my $msg = errmsg('process %s', $ecode); my $pre = qq{}; $out .= qq{ $pre$edit_anchor$code_post }; } #::logDebug("keyname=$ts->{keyname}"); $out .= "($ts->{keyname}) . ">"; $ecode = ''; if ($calcs[0]) { my %item; @item{@cols} = ($code, @$line); if(ref($calcs[0]) eq 'CODE') { $ecode = $calcs[0]->(\%item); } else { $Vend::Interpolate::item = \%item; $ecode = tag_calc($calcs[0]); } } if ($filter_show[0]) { $ecode = $code unless $ecode; $ecode = $Tag->filter($filter_show[0], $ecode, $cols[0]); $ecode =~ s/\[/[/g; } $ecode = encode_entities($code) unless $ecode; $out .= "$code_pre$ecode$code_post"; my $i = 1; for my $v (@$line) { my $extra = $style[$i]; my $pre = ''; my $post = ''; my $lab; if($link_page[$i]) { my $opt = { $link_parm[$i] => $v, form => 'auto' }; if(my $p = $link_parm_extra[$i]) { for(@$p) { $opt->{$_} = $CGI->{$_}; } } $opt->{href} = $link_page[$i]; $lab = $link_anchor[$i]; $lab =~ s/^\s+//; my $url = $Tag->area($opt); my $ev = encode_entities($v); $pre = qq{}; $post = ''; } if($calcs[$i]) { #::logDebug("found a calc"); my %item; @item{@cols} = ($code, @$line); if(ref($calcs[$i]) eq 'CODE') { $lab = $calcs[$i]->(\%item); } else { $Vend::Interpolate::item = \%item; $lab = tag_calc($calcs[$i]); } } $lab ||= $v; $lab = $Tag->filter($filter_show[$i], $lab, $cols[$i]); $lab =~ s/\[/[/g; $out .= "$pre$lab$post"; $i++; } $out .= "\n"; push @rows, $out; } unless(@rows) { my $nomsg = errmsg('No records'); push @rows, qq{
    $nomsg.
    }; } else { my $mmsg = errmsg($opt->{more_message} ||= 'More rows'); $opt->{more_list} ||= < $mmsg: [decade-next][/decade-next] [more] [decade-prev][/decade-prev] EOF $opt->{more_list} =~ s/\{NCOLS\}/$ncols/g; my $override = { mv_data_table => $table, ui_meta_view => $mview }; my @forms; my @formparms = qw/ mv_data_table ui_meta_view ui_meta_specific /; for(@formparms) { my $thing = $override->{$_} || $CGI->{$_}; next unless length $thing; push @forms, "$_=$thing"; } my $o = { object => $search, label => $opt->{label}, form => join("\n", @forms), }; $output{MORE_LIST} = tag_more_list( $opt->{next_anchor}, $opt->{prev_anchor}, $opt->{page_anchor}, $opt->{more_border}, $opt->{more_border_selected}, $o, $opt->{more_list}, ); } } $output{BOTTOM_OF_TABLE} = ''; $output{BOTTOM_OF_FORM} = ''; my $calc_sequence = <<'EOF'; ui_sequence_edit=[calc] $CGI->{item_id_left} = $CGI->{item_id}; $CGI->{item_id_left} =~ s/\0+/,/g; if($CGI->{item_id_left} =~ s/^(.*?),//) { $CGI->{item_id} = $1; return 1; } else { delete $CGI->{item_id_left}; return ''; } [/calc] EOF $calc_sequence .= "mv_nextpage=$edit_page\nmv_todo=return"; my $ebutton = $Tag->button( { text => errmsg('Edit checked records in sequence'), extra => $opt->{edit_button_extra} || ' class=s2', }, $calc_sequence, ); my $mbutton = ''; my $dbutton = ''; if($Tag->if_mm({ function => 'tables', table => "$table=d"}) ) { $opt->{confirm} ||= "Are you sure you want to delete the checked records?"; my $dtext = qq{ [flag type=write table=$table] deleterecords=1 mv_click=db_maintenance}; $dbutton = ' '; $dbutton .= $Tag->button( { text => errmsg('Delete checked records'), extra => $opt->{edit_button_extra} || ' class=s2', confirm => errmsg($opt->{confirm}), }, $dtext, ); if($opt->{user_merge}) { $opt->{confirm_merge} ||= "Are you sure you want to merge the checked users?"; $mbutton = ' '; $mbutton .= $Tag->button( { text => errmsg('Merge checked users'), extra => $opt->{merge_button_extra} || ' class=s2', confirm => errmsg($opt->{confirm_merge}), }, '[user-merge]', ); } } my $cboxes = ''; if($meta->{check_uncheck_all}) { my $uc_msg = errmsg('Uncheck all'); my $ch_msg = errmsg('Check all'); $ch_msg =~ s/\s/ /g; $uc_msg =~ s/\s/ /g; $cboxes = < $ch_msg    $uc_msg    EOF $cboxes =~ s/\n//g; } if(! $opt->{no_checkbox} and ! $ts->{like_spec}) { unless($opt->{no_top} || $opt->{bottom_buttons}) { $output{TOP_BUTTONS} = $cboxes; $output{TOP_BUTTONS} .= $ebutton; if($mbutton) { $output{TOP_BUTTONS} .= ' ' x 4; $output{TOP_BUTTONS} .= $mbutton; } if($dbutton) { $output{TOP_BUTTONS} .= ' ' x 4; $output{TOP_BUTTONS} .= $dbutton; } } unless($opt->{no_bottom} || $opt->{top_buttons}) { $output{BOTTOM_BUTTONS} = $cboxes; $output{BOTTOM_BUTTONS} .= $ebutton; if($mbutton) { $output{BOTTOM_BUTTONS} .= ' ' x 4; $output{BOTTOM_BUTTONS} .= $mbutton; } if($dbutton) { $output{BOTTOM_BUTTONS} .= ' ' x 4; $output{BOTTOM_BUTTONS} .= $dbutton; } } } my %map = qw/ TOP_OF_FORM top_of_form BOTTOM_OF_FORM bottom_of_form HIDDEN_FIELDS hidden_fields TOP_BUTTONS top_buttons BOTTOM_BUTTONS bottom_buttons EXTRA_BUTTONS extra_buttons /; my @areas = qw/ TOP_OF_TABLE TOP_OF_FORM HIDDEN_FIELDS TOP_BUTTONS HEADER_AREA MAIN_BODY MORE_LIST BOTTOM_BUTTONS EXTRA_BUTTONS BOTTOM_OF_FORM BOTTOM_OF_TABLE /; if($ts->{like_spec}) { push @rows, <   [L]Check the box for exact record and enter the record id/key.[/L] [L]Or enter a query by example to select a set of records.[/L] [L]Each input will match on the beginning text in the field.[/L]

    Edit exact record in key column
        [loop list="[cgi ui_description_fields]"] [/loop]    
     
    EOF } $output{MAIN_BODY} = join "", @rows; my @out; for(@areas) { next unless $output{$_}; if($opt->{ui_style} and $map{$_}) { my $op = $map{$_}; $Tag->output_to($op, { name => $op }, $output{$_} ); } else { push @out, $output{$_}; } } return join "", @out; } EOR interchange-5.7.7.orig/code/UI_Tag/get_gpg_keys.coretag0000644000000000000000000000246511352565025017720 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: get_gpg_keys.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $ UserTag get-gpg-keys Order dir UserTag get-gpg-keys addAttr UserTag get-gpg-keys Version $Revision: 1.5 $ UserTag get-gpg-keys Routine <{GPG_PATH} || 'gpg'; my $flags = "--list-keys"; if($dir) { $dir = filter_value('filesafe', $dir); $flags .= "--homedir $dir"; } #::logDebug("gpg_get_keys flags=$flags"); open(GPGIMP, "$gpgexe $flags |") or die "Can't fork: $!"; my $fmt = $opt->{long} ? "%s=%s (date %s, id %s)" : "%s=%s"; my @out; while() { next unless s/^pub\s+//; my ($id, $date, $text) = split /\s+/, $_, 3; $id =~ s:.*?/::; $text = ::errmsg( $fmt, $id, $text, $date, $id ); $text =~ s//>/g; $text =~ s/,/,/g; push @out, $text; } close GPGIMP; my $joiner = $opt->{joiner} || ",\n"; unshift @out, "=none" if $opt->{none}; return join($joiner, @out); } EOR interchange-5.7.7.orig/code/UI_Tag/global_value.coretag0000644000000000000000000000121211352565025017672 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: global_value.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $ UserTag global-value Order name UserTag global-value Version $Revision: 1.5 $ UserTag global-value Routine <{table} || $::Values->{mv_data_table}; my $acl = UI::Primitive::get_ui_table_acl($table); return $text unless $acl; my @items = grep /\S/, Text::ParseWords::shellwords($text); return join "\n", UI::Primitive::ui_acl_grep($acl, $func, @items); } EOR interchange-5.7.7.orig/code/UI_Tag/if_mm.coretag0000644000000000000000000001161511352565025016335 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: if_mm.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $ UserTag if-mm Order function name UserTag if-mm addAttr UserTag if-mm attrAlias key name UserTag if-mm hasEndTag UserTag if-mm Version $Revision: 1.6 $ UserTag if-mm Routine <{super}; $func = lc $func; ($status = 1, last CHECKIT) if $func eq 'logged_in'; my %acl_func = qw/ fields fields field fields columns fields column fields col fields row keys rows keys key keys keys keys owner_field owner_field owner owner_field /; my %file_func = qw/ page pages file files pages pages files files /; my %bool_func = qw/ config 1 reconfig 1 /; my %paranoid = qw/ mml 1 sql 1 report 1 add_delete 1 add_field 1 journal_update 1 /; my %yesno_func = qw/ functions functions advanced functions tables tables table tables /; my %prefix_func = qw/ filematch files pagematch pages /; my $table = $CGI::values{mv_data_table} || $::Values->{mv_data_table}; if($yesno_func{$func} eq 'tables') { $opt->{table} = $field if ! $opt->{table}; $opt->{table} =~ s/^=/$table/; } elsif($yesno_func{$func} eq 'functions') { $opt->{table} = $field; } $table = $opt->{table} || $table; my $acl; my $check; $status = 0, last CHECKIT if $func eq 'super'; if($check = $file_func{$func}) { $status = 1, last CHECKIT unless $record->{$check}; my $file = $field || $Global::Variable->{MV_PAGE}; # strip trailing slashes for checks on directories $file =~ s%/+$%%; #::logDebug("check=$check file=$file record=$record->{$check} prefix=$opt->{prefix}"); my @files = UI::Primitive::list_glob($record->{$check}, $opt->{prefix}); #::logDebug("check yielded files=" . join(",", @files)); if(! @files) { $status = ''; last CHECKIT; } $status = ui_check_acl("$file$extended", join(" ", @files)); #::logDebug("check status=$status"); last CHECKIT; } if($check = $prefix_func{$func}) { $status = '', last CHECKIT unless $record->{$check}; my $file = $field; # strip trailing slashes for checks on directories #::logDebug("check=$check file=$file record=$record->{$check}"); my @allow = split /\s+/, $record->{$check}; $status = ''; for(@allow) { #::logDebug("check file=$file against allow=$_"); if(s/^\!//) { if ($file =~ /^$_/) { #::logDebug("denied based on $_"); $status = ''; last CHECKIT; } } else { next unless $file =~ /^$_\b/; $status = 1; } } #::logDebug("check Yielded status=$status"); last CHECKIT; } if($bool_func{$func} ) { $status = $record->{$func}; last CHECKIT; } if($check = $yesno_func{$func} ) { my $v; if($v = $record->{"yes_$check"}) { $status = ui_check_acl("$table$extended", $v); } else { $status = 1; } if($v = $record->{"no_$check"}) { $status &&= ! ui_check_acl("$table$extended", $v); } last CHECKIT; } if(! ($check = $acl_func{$func}) ) { my $default = $func =~ /^no_/ ? 0 : 1; $status = $default, last CHECKIT unless $record->{$func}; $status = ui_check_acl("$table$extended", $record->{$func}); last CHECKIT; } # Now it is definitely a job for table_control; $acl = UI::Primitive::get_ui_table_acl($table); $status = 1, last CHECKIT unless $acl; my $val; if($acl->{owner_field} and $check eq 'keys') { $status = ::tag_data($table, $acl->{owner_field}, $field) eq $Vend::username; last CHECKIT; } elsif ($check eq 'owner_field') { $status = length $acl->{owner_field}; last CHECKIT; } $status = UI::Primitive::ui_acl_atom($acl, $check, $field); } if(! $status and $record and (@groups or $record->{groups}) ) { goto CHECKIT if $group = shift @groups; (@groups) = grep /\S/, split /[\0,\s]+/, $record->{groups}; ($group, @groups) = map { s/^/:/; $_ } @groups; goto CHECKIT; } return $status ? ( Vend::Interpolate::pull_if($text, $reverse) ) : Vend::Interpolate::pull_else($text, $reverse); } EOR interchange-5.7.7.orig/code/UI_Tag/import_fields.coretag0000644000000000000000000002600011352565025020100 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: import_fields.coretag,v 1.15 2007-08-03 18:17:24 racke Exp $ UserTag import_fields Order table UserTag import_fields addAttr UserTag import_fields Version $Revision: 1.15 $ UserTag import_fields Routine <Fatal Administration Error

    FATAL error

    $msg
    Progress to date:

    $out EOF exit 0; }; my $file = $opt->{'file'} || $Vend::Cfg->{ProductDir} . "/$table.update"; my $currdb; my $tmsg = ''; my $db; my %filter = ( '' => { mv_credit_card_number => 'encrypt' }, ); if($opt->{filter_field}) { my @filt = grep /\S/, split /[\r\n]+/, $opt->{filter_field}; for(@filt) { s/^\s+//; s/\s+$//; my ($t, $f) = split /\s*:\s*/, $_; if(! $f) { if ($opt->{multiple}) { die "Must specify both table and filter for multiple table filters.\n"; } else { $f = $t; $t = ''; } $t ||= ''; } #::logDebug("found filter: t=$t f=$f"); my ($field, $filters) = split /\s*=\s*/, $f, 2; #::logDebug("found filter: t=$t field=$field filters=$filters"); $filter{$t}{$field} = $filters; } } CONVERT: { last CONVERT if ! $opt->{convert}; if ($opt->{convert} eq 'auto') { if($file =~ /\.(txt|all)$/i) { last CONVERT; } elsif($file =~ /\.xls$/i) { $opt->{convert} = 'xls'; redo CONVERT; } else { $file =~ s:.*\.:: or $file = 'none'; return "Failed: unknown file extension ''"; } } elsif ($opt->{convert} eq 'xls') { #::logDebug("doing XLS for file=$file"); eval { require Spreadsheet::ParseExcel; import Spreadsheet::ParseExcel; my $oBook = Spreadsheet::ParseExcel::Workbook->Parse($file); #::logDebug("oBook is $oBook"); if(! $oBook) { die errmsg("Failed to parse XLS file %s: %s\n", $file, $!); } my($iR, $iC, $oWkS, $oWkC); my $sheetcount = $oBook->{SheetCount}; #::logDebug("Sheetcount is $sheetcount"); my $sheets = {}; for my $oWkS (@{$oBook->{Worksheet}}) { next unless defined $oWkS; for(qw/MaxCol MaxRow MinCol MinRow/) { die "No $_!" if ! defined $oWkS->{$_}; } my $sname = $oWkS->{Name} or die "no sheet name."; #::logDebug("doing sheet $sname"); $sheets->{$sname} = "$sname\n"; my $maxcol; my $mincol; my $iC; my $iR = $oWkS->{MinRow}; for($iC = $oWkS->{MinCol} ; $iC <= $oWkS->{MaxCol} ; $iC++) { $oWkC = $oWkS->{Cells}[$iR][$iC]; if(! $oWkC or ! $oWkC->Value) { $maxcol = $iC; $maxcol--; last; } $maxcol = $iC; } $mincol = $oWkS->{MinCol}; my @out; for( ; $iR <= $oWkS->{MaxRow}; $iR++) { my $row = $oWkS->{Cells}[$iR]; @out = (); for($iC = $mincol; $iC <= $maxcol; $iC++) { if(! defined $row->[$iC]) { push @out, ""; next; } push @out, $row->[$iC]->Value; } $sheets->{$sname} .= join "\t", @out; $sheets->{$sname} .= "\n"; } } my @print; for(sort keys %$sheets) { push @print, $sheets->{$_}; } $file =~ s/(\.xls)?$/.txt/i; open OUT, ">$file" or die "Cannot write $file: $!\n"; print OUT join "\cL", @print; close OUT; }; die "Excel conversion failed: $@\n" if $@; } else { # other types, or assume gnumeric simple text } } # end CONVERT my $change_sub; if($opt->{multiple}) { undef $table; $change_sub = sub { my $table = shift; $Vend::WriteDatabase{$table} = 1; $Vend::TransactionDatabase{$table} = 1 if $opt->{transactions}; #::logDebug("changing table to $table"); $db = Vend::Data::database_exists_ref($table); #::logDebug("db now=$db"); die "Non-existent table '$table'\n" unless $db; $db = $db->ref(); #::logDebug("db now=$db"); if($opt->{autonumber} and ! $db->config('_Auto_number') ) { $db->config('AUTO_NUMBER', '1000'); } #::logDebug("db now=$db"); $tmsg = "table $table: "; return; }; } else { $Vend::WriteDatabase{$table} = 1; $Vend::TransactionDatabase{$table} = 1 if $opt->{transactions}; $db = Vend::Data::database_exists_ref($table); die "Non-existent table '$table'\n" unless $db; $db = $db->ref() unless $Vend::Interpolate::Db{$table}; if($opt->{autonumber} and ! $db->config('_Auto_number') ) { $db->config('AUTO_NUMBER', '1000'); } } $out = '

    ';
	my $delimiter = quotemeta $opt->{delimiter} || "\t";
	open(UPDATE, $file)
		or die "read $file: $!\n";

	my $fields;

	if($opt->{multiple}) {
		# will get fields later
		undef $opt->{fields};
	}
	elsif($opt->{fields}) {
		$fields = $opt->{fields};
		$out .= "Using fields from parameter: '$fields'\n";
	}

	my $verbose;
	my $quiet;

	$verbose = 1 if ! $opt->{quiet};
	$quiet = 1   if $opt->{quiet} > 1;

  TABLE: {
	if(! $table) {
		$table = ;
		$table =~ s/(\015\012|\015|\012)$//;
		$change_sub->($table);
	}
#::logDebug("db now=$db");
	if(! $opt->{fields}) {
		$fields = ;
		$fields =~ s/(\015\012|\015|\012)$//;
		$fields =~ s/$delimiter/ /g;
		$out .= "${tmsg}Using fields from file: '$fields'\n";
	}
	$filter{$table} ||= {};
	die "No field names." if ! $fields;
	my @names;
	my $k;
	my @f;
	@names = split /\s+/, $fields;
	my $key = shift @names;
	my $i = 0;
	my $idx = 0;
	my $ignore_sub;
	
	# check key name
	if ($key !~ /^[\w_-]+$/) {
		die "Invalid key '$key' for table $table (wrong file format ?)\n";
	}

	my $multikey = $db->config('COMPOSITE_KEY') ? 1 : 0;

	
	if ($opt->{ignore_fields}) {
		my %fmap;
		for (my $ct = 0; $ct < @names; $ct++) {
			$fmap{$names[$ct]} = $ct;
		}
		for (split(/[\0\s,]+/, $opt->{ignore_fields})) {
			delete $fmap{$_};
		}
		my $code = 'sub {$a = shift; @$a = @$a[' . join(',', values(%fmap)) . '];}';
		$ignore_sub = eval $code;
		die "Routine to ignore fields bad: $@" if $@;
		@names = grep {exists $fmap{$_}} @names;
	}

	# We skip the whole table if bad field is found
	my $skipping;

	my @keycols;

	if($multikey) {
		my %fmap;
		@fmap{$key,@names} = ($key,@names);
		my $not_all_there;
		for(@{$db->config('_Key_columns')}) {
			push(@keycols, $_);
			next if $fmap{$_};	
			$not_all_there = 1;
		}
		if($not_all_there) {
			$out .= errmsg(
						"Table %s: not all key columns present. Skipping table.",
						$table,
					);

			$skipping = 1;
		}
	}

	######### Filters
	##
	## Done with so many data items for speed when empty....
	##

	## Holds filter subroutines if any
	my %change;
	## Holds names of filter subroutines if any
	my @filters;
	## Non-zero if found any filter
	my $found_filter = 0;
	##
	######### Filters

	for(@names) {
		my $test = $db->column_index($_);
#::logDebug("checking name=$_");
		if(! defined $test) {
			$out .= errmsg(
						"Table %s: undefined column '%s'. Skipping table.",
						$table,
						$_,
						);
			$skipping = 1;
		}
		elsif ($filter{''}{$_} || $filter{$table}{$_}) {
#::logDebug("found filter for name=$_");
			my @things = grep length($_), $filter{''}{$_}, $filter{$table}{$_};
			my $thing = join " ", @things;
			eval {
				$change{$_} = sub {
					my $ref = shift;
					$$ref = Vend::Interpolate::filter_value($thing, $$ref);
				};
			};
			if($@) {
				$out .= errmsg(
							"Table %s: unrequited filter '%s'. Skipping table.",
							$table,
							$thing,
						);
				$skipping = 1;
			}
			push @filters, $_;
			$found_filter++;
		}
		$idx++;
	}
	my %keys;
	if ($opt->{cleanse}) {
		# record existing columns
		my $recs;
		if ($multikey) {
			$recs = $db->query("select " . join(',', @keycols) . " from $table");
			$keys{join("\0", @$_)} = 1 for @$recs;
		} else {
			$recs = $db->query("select $key from $table");
			$keys{$_->[0]} = 1 for @$recs;
		}
	}
	my $count = 0;
	my $totcount = 0;
	my $delcount = 0;
	my $addcount = 0;
	while() {
		s/(\015\012|\015|\012)$//;
		$totcount++;
		($k, @f) = split /$delimiter/o, $_;
		if(/^\f(\w+)$/) {
			$out .= "${tmsg}$count records processed of $totcount input lines.\n";
			$out .= "${tmsg}$delcount records deleted.\n" if $delcount;
			$out .= "${tmsg}$addcount records added.\n" if $addcount;
			$delcount = $totcount = $addcount = 0;
			$db->commit() if $opt->{transactions};
			$change_sub->($1);
			redo TABLE;
		}
		next if $skipping;
		if(! $k and ! length($k)) {
			if ($f[0] eq 'DELETE') {
				next if ! $opt->{delete};
				next if $multikey;
				$out .= "${tmsg}Deleting record '$f[1]'.\n" if $verbose;
				$db->delete_record($f[1]);
				$count++;
				$delcount++;
				next;
			}
		}
		$ignore_sub->(\@f) if $ignore_sub;
		$out .= "${tmsg}Record '$k' had too many fields, ignored.\n"
			if @f > $idx;

		my %hash;
		@hash{@names} = @f;
		if($found_filter) {
			for(@filters) {
				$change{$_}->(\$hash{$_});
			}
		}

		if($multikey) {
			$hash{$key} = $k;
			if(! $db->record_exists(\%hash)) {
				if($opt->{add}) {
					$out .= "${tmsg}Adding multiple-key record.\n" if $verbose;
				}
				else {
					$out .= "${tmsg}Non-existent record '$k', skipping.\n";
					next;
				}
			}
			$k = undef;
		}
		elsif ( ! length($k) or ! $db->record_exists($k)) {
			if ($opt->{add}) {
				if( ! length($k) and ! $opt->{autonumber}) {
					$out .= "${tmsg}Blank key, no autonumber option, skipping.\n";
					next;
				}
				$k = $db->set_row($k);
				$out .= "${tmsg}Adding record '$k'.\n" if $verbose;
				$addcount++;
			}
			else {
				$out .= "${tmsg}Non-existent record '$k', skipping.\n";
				next;
			}
		}

		if ($opt->{cleanse}) {
			if ($multikey) {
				delete $keys{join("\0", map{$hash{$_}} @keycols)};
			} else {
				delete $keys{$k};
			}
		}

		$db->set_slice($k, \%hash) if @names;

		if($@) {
   			my $msg = ::errmsg("error on update: %s", $@);
			::logError($msg);
   			$out .= $msg;
   		}
		$count++;
	}

	$db->commit() if $opt->{transactions};

	if ($opt->{cleanse}) {
		# remove any record which hasn't updated
		for (keys(%keys)) {
			$db->delete_record($_);
			$delcount++;
		}
	}
	$out .= "${tmsg}$count records processed of $totcount input lines.\n";
	$out .= "${tmsg}$delcount records deleted.\n" if $delcount;
	$out .= "${tmsg}$addcount records added.\n" if $addcount;
  }
	$out .= "
    "; close UPDATE; if($opt->{'move'}) { my $ext = POSIX::strftime("%Y%m%d%H%M%S", localtime()); rename $file, "$file.$ext" or die "rename $file --> $file.$ext: $!\n"; if( $opt->{dir} and (-d $opt->{dir} or File::Path::mkpath($opt->{dir})) and -w $opt->{dir} ) { File::Copy::move("$file.$ext", $opt->{dir}) or die "move $file.$ext --> $opt->{dir}: $!\n"; } } return $out unless $quiet; return; } EOR interchange-5.7.7.orig/code/UI_Tag/jsq.coretag0000644000000000000000000000177611352565025016052 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: jsq.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $ UserTag jsquote Alias jsq UserTag jsq hasEndTag UserTag jsq NoReparse UserTag jsq PosNumber 0 UserTag jsq Version $Revision: 1.8 $ UserTag jsq Routine <{Database}; @dbs = sort keys %$d; GENDBLIST: { last GENDBLIST if $nohide; my @outdb; my $record = ui_acl_enabled(); last GENDBLIST if $record and $record->{super}; undef $record unless ref($record) and $record->{yes_tables} || $record->{no_tables}; for(@dbs) { if($record) { next if $record->{no_tables} and ui_check_acl($_, $record->{no_tables}); my $check = "$_$extended"; next if $record->{yes_tables} and ! ui_check_acl($check, $record->{yes_tables}); } push @outdb, $_; } @dbs = $nohide ? (@dbs) : (@outdb); } return @dbs if wantarray; my $string = join " ", grep /\S/, @dbs; return $string; } EOR interchange-5.7.7.orig/code/UI_Tag/list_glob.coretag0000644000000000000000000000124611352565025017223 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: list_glob.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag list_glob Order spec prefix UserTag list_glob PosNumber 2 UserTag list_glob Version $Revision: 1.4 $ UserTag list_glob Routine <{mv_data_table} unless $table; #::logDebug("list-keys $table"); my @keys; my $record; if(! ($record = $Vend::UI_entry) ) { $record = ui_acl_enabled(); } my $acl; my $keys; if($record) { #::logDebug("list_keys: record=$record"); $acl = get_ui_table_acl($table); #::logDebug("list_keys table=$table: acl=$acl"); if($acl and $acl->{yes_keys}) { #::logDebug("list_keys table=$table: yes.keys enabled"); @keys = grep /\S/, split /\s+/, $acl->{yes_keys}; } } unless (@keys) { my $db = Vend::Data::database_exists_ref($table); return '' unless $db; $db = $db->ref() unless $Vend::Interpolate::Db{$table}; my $keyname = $db->config('KEY'); if($db->config('LARGE')) { return ::errmsg('--not listed, too large--'); } my $query = "select $keyname from $table order by $keyname"; #::logDebug("list_keys: query=$query"); $keys = $db->query( { query => $query, ml => $::Variable->{UI_ACCESS_KEY_LIMIT} || 500, st => 'db', } ); if(defined $keys) { @keys = map {$_->[0]} @$keys; } else { my $k; while (($k) = $db->each_record()) { push(@keys, $k); } if( $db->numeric($db->config('KEY')) ) { @keys = sort { $a <=> $b } @keys; } else { @keys = sort @keys; } } #::logDebug("list_keys: query=returned " . ::uneval(\@keys)); } if($acl) { #::logDebug("list_keys acl: ". ::uneval($acl)); @keys = UI::Primitive::ui_acl_grep( $acl, 'keys', @keys); } return @keys if wantarray; return join("\n", @keys); } EOR interchange-5.7.7.orig/code/UI_Tag/list_pages.coretag0000644000000000000000000000153211352565025017375 0ustar # Copyright 2002-2007 Interchange Development Group and others # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. See the LICENSE file for details. # # $Id: list_pages.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $ UserTag list_pages Order options UserTag list_pages addAttr UserTag list_pages Version $Revision: 1.4 $ UserTag list_pages Routine <{keep},$opt->{ext},$opt->{base}); if($return_options) { $out = "