[if cgi junksubmit]
[or cgi cancelsubmit]
Hit action for no-content
[tag op=header]Status: 204 No content[/tag]
[goto]
[/if]
[set page_title]Menu construction[/set]
[tmpn dhtml_required]1[/tmpn]
[set ui_class]Design[/set]
[set page_banner]Menu constructor: Make a quick menu[/set]
[set page_perm]layout=e[/set]
[set help_name]layout.edit[/set]
[set icon_name]icon_pages.gif[/set]
[seti ui_body_extra][/seti]
@_UI_STD_HEAD_@
[loop list="tree __MV_TREE_TABLE__"]
[flag type=write table="[loop-code]"]
[/loop]
[seti medit_tables]
__MV_TREE_TABLE__
__ProductFiles_0__
tree
cat
area
[cgi qmenu_products]
__UI_META_TABLE__
[/seti]
[perl tables="[scratch medit_tables]"]
my $menupath = $Variable->{MV_MENU_DIRECTORY} || 'include/menus';
@menufields = qw/
code mgroup msort next_line indicator exclude_on depends_on page
form name super inactive description help_name img_dn img_up
img_sel img_icon url member
/;
$Tag->tmp('qmenu_fdata');
$Tag->tmp('qmenu_data');
%menuinit = (
code => 0,
inactive => 0,
msort => "'x'",
);
if($CGI->{qmenu_text}) {
my $menufile;
my $menuname;
if($CGI->{qmenu_new} =~ /\S/) {
$menuname = $CGI->{qmenu_new};
$menuname =~ s/\s+$//;
$menuname =~ s/^\s+//;
}
else {
$menuname = $CGI->{qmenu_name};
}
$CGI->{qmenu_name} = $menuname;
if($menuname) {
$menufile = $Tag->filter('filesafe', "$menupath/$menuname.txt");
my $text = $CGI->{qmenu_text};
$text =~ s{\\([\\r])}{
if ($1 eq 'r') { "\r" }
elsif($1 eq "\\") { "\\" }
else { "\\$1" }
}eg;
$text =~ s/\r\n/\n/g;
$Tag->backup_file($menufile) if -f $menufile;
if($Tag->write_relative_file($menufile, $text) ) {
$Tag->warnings( errmsg(
"Menu '%s' saved to file %s. Active on next access.",
$menuname,
$menufile,
));
}
else {
$Tag->error({ name => 'Save menu',
set => errmsg(
"Failed to save menu '%s' to file %s.",
$Tag->filter('unescape', $menuname),
$menufile,
),
});
}
my $tab = $Variable->{MV_TREE_TABLE} || 'tree';
if($CGI->{qmenu_tree} && $CGI->{qmenu_write_tree} and $Db{$tab}) {
TREEWRITE: {
my $db = $Db{$tab}
or do {
$Tag->error({
set => errmsg(
"%s database %s for tree write: %s",
'open',
$tab,
'non-existent',
),
});
last TREEWRITE;
};
my @lines = split /\n/, $text;
my @fields = split /\t/, shift(@lines);
my $pfield = $Variable->{MV_TREE_PARENT_FIELD} || 'parent_fld';
my $gfield = $Variable->{MV_TREE_GROUP_FIELD} || 'mgroup';
my $sfield = $Variable->{MV_TREE_SORT_FIELD} || 'msort';
my @valid;
for(my $i = 0; $i < @fields; $i++) {
push @valid, $i if defined $db->test_column($fields[$i]);
}
#Debug("valid entries=" . join(',', @valid));
@fields = @fields[@valid];
my $gptr;
my $sptr;
for(my $i = 1; $i < @fields; $i++) {
if($fields[$i] eq $gfield) {
$gptr = $i;
}
elsif($fields[$i] eq $sfield) {
$sptr = $i;
}
}
my $num = @fields;
my $last = $num - 1;
my $pptr = @fields;
push @fields, $pfield;
shift(@fields);
my @parent = ($menuname);
my $plev = 0;
my $query = qq{delete from $tab where $gfield = '$menuname'};
$db->query($query);
for(@lines) {
my @row = split /\t/, $_, $num;
my @f = @fields;
$#row = $last;
@row = @row[@valid];
my $lev = $row[$sptr];
#Debug("menu level=$lev");
$row[$gptr] = $menuname;
$row[$pptr] = $parent[$lev];
splice(@parent, $lev + 1);
shift(@row);
#Debug("fields to set: " . uneval(\@f));
#Debug("values to set: " . uneval(\@row));
my $key = $db->set_slice(undef, \@f, \@row);
#Debug("fields to set: " . uneval(\@f));
#Debug("values to set: " . uneval(\@row));
$parent[$lev + 1] = $key;
}
$Tag->warnings( errmsg(
"Successfully wrote %s lines to tree %s.",
scalar(@lines),
$menuname,
) );
}
}
}
else {
$Tag->error({ name => 'qmenu_name/qmenu_new',
set => "No menu name to write.",
});
}
}
elsif ($CGI->{qmenu_products}) {
PRODBUILD: {
my $tab = $CGI->{qmenu_products};
my $db = $Db{$tab}
or do {
$Tag->error({ set => errmsg(
"Failed to open %s table %s.",
'products',
$tab,
),
});
last PRODBUILD;
};
#Debug("LARGE=" . $db->config('LARGE'));
if(! $CGI->{qmenu_even_large} and $db->config('LARGE')) {
$Tag->error({ set => errmsg(
"%s database %s for tree write: %s",
'check',
$tab,
'too large, must override',
),
});
last PRODBUILD;
}
my @somefields = qw/mgroup page name description/;
my $q = qq{
SELECT sku,prod_group,category,description
FROM $tab
ORDER BY prod_group,category,description
};
my $ary = $db->query($q)
or do {
$Tag->error({
set => errmsg(
"No results from %s table %s.",
'products',
$tab,
),
});
last PRODBUILD;
};
my $prev_area = '';
my $prev_cat = '';
my @out = join "\t", @menufields;
my @rows;
my $base_search = "scan/co=yes/fi=$tab";
for(@$ary) {
my($sku, $area, $cat, $desc) = @$_;
for( \$sku, \$area, \$cat, \$desc) {
$$_ =~ s/\s+$//;
}
if($area ne $prev_area) {
$prev_area = $area;
$prev_cat = '';
my $url = join '/',
$base_search,
"sf=prod_group",
"se=$area",
"op=eq",
"tf=category,description",
;
push @rows, {
%menuinit,
msort => 0,
page => $url,
inactive => 0,
name => $area,
};
}
if($cat ne $prev_cat) {
$prev_cat = $cat;
my $url = join '/',
$base_search,
"sf=prod_group",
"se=$area",
"op=eq",
"sf=category",
"se=$cat",
"op=eq",
"tf=description",
;
push @rows, {
%menuinit,
msort => 1,
page => $url,
inactive => 0,
name => $cat,
};
}
push @rows, {
%menuinit,
msort => 2,
name => $desc,
inactive => 0,
page => $sku,
};
}
for(@rows) {
#Debug("pushing out --> " . $_->{name});
push @out, join "\t", @{$_}{@menufields};
}
$Scratch->{qmenu_data} = join "\n", @out, '';
$CGI->{qmenu_name} = '';
$CGI->{qmenu_new} ||= 'Untitled';
#Debug("qmenu_data=$Scratch->{qmenu_data}");
}
}
elsif ($CGI->{qmenu_cat}) {
AREABUILD: {
my $tab = $CGI->{qmenu_area} || 'area';
my $ctab = $CGI->{qmenu_cat} || 'cat';
my $db = $Db{$tab}
or do {
$Tag->error({ set => errmsg(
"Failed to open %s table %s.",
'area',
$tab,
),
});
last AREABUILD;
};
#Debug("LARGE=" . $db->config('LARGE'));
my $q = qq{ SELECT * FROM $tab ORDER BY sort };
my $ary = $db->query({ sql => $q, hashref => 1 } )
or do {
$Tag->error({
set => errmsg(
"No results from %s table %s.",
'area',
$tab,
),
});
last AREABUILD;
};
sub old_link {
my ($row, $nrow) = @_;
#Debug("row link_type='$row->{link_type}'");
if($row->{link_type} eq 'external') {
$first = $row->{url};
$first =~ s/\s+$//;
$first =~ s/^\s+//;
$nrow->{page} = $first;
}
elsif ($row->{link_type} eq 'internal') {
my ($page, $form) = split /\s+/, $row->{url}, 2;
$nrow->{page} = $page;
$nrow->{form} = $form;
}
elsif ($row->{link_type} eq 'simple') {
my (@items) = split /\s*[\n,]\s*/, $row->{selector};
my @out;
my $fi = $row->{tab};
my $sp = $row->{page};
my $arg = '';
$nrow->{page} = 'search';
push @out, "fi=$fi" if $fi;
push @out, "sp=$sp" if $sp;
push @out, "st=db";
if(! @items) {
push @out, "ra=yes";
$nrow->{form} = join "\n", @out;
}
else {
push @out, "co=yes";
for(@items) {
my ($col, $string) = split /\s*=\s*/;
push @out, "sf=$col";
push @out, "se=$string";
}
push @out, $row->{search}
if $row->{search} =~ /^\s*\w\w=/;
push @out, qq{va=banner_image=$row->{banner_image}};
push @out, qq{va=banner_text=$row->{banner_text}};
$arg = join "\n", @out;
$nrow->{form} = $arg;
}
}
elsif ($row->{link_type} eq 'complex') {
$row->{search} =~ s/[\r\n+]/\n/g;
$row->{search} .= qq{\nva=banner_text=$row->{banner_text}};
$row->{search} .= qq{\nva=banner_image=$row->{banner_image}};
$nrow->{form} = $row->{search};
}
else {
$url = "";
}
return $nrow;
}
my @rows;
my $nc = '0000';
my $cdb = $Db{$ctab};
foreach my $row (@$ary) {
my $code = $row->{code};
my $nrow = {
code => $nc++,
name => $row->{name},
img_icon => $row->{image},
msort => 0,
mgroup => $row->{set_selector},
};
old_link($row, $nrow);
my $sq = qq{
SELECT * FROM $ctab
WHERE sel = '$code'
OR sel like '$code %'
OR sel like '% $code'
OR sel like '% $code %'
ORDER BY sort
};
#Debug("subquery=$sq");
push @rows, $nrow;
my $sary = $cdb->query({ sql => $sq, hashref => 1 });
#Debug("subquery returned: " . uneval($sary));
for my $crow (@$sary) {
my $nsub = {
code => $nc++,
name => $crow->{name},
img_icon => $crow->{image},
msort => 1,
mgroup => $crow->{sel},
};
old_link($crow, $nsub);
push @rows, $nsub;
}
}
for(@rows) {
#Debug("pushing out --> " . $_->{name});
push @out, join "\t", @{$_}{@menufields};
#Debug("pushing out --> row=" . uneval($_));
}
push @out, join
$Scratch->{qmenu_data} = join "\n", @out, '';
$CGI->{qmenu_name} = '';
$CGI->{qmenu_new} ||= 'Untitled';
#Debug("qmenu_data=$Scratch->{qmenu_data}");
}
}
if($CGI->{qmenu_html_create} and $CGI->{qmenu_create}) {
my $text = $CGI->{qmenu_html_create};
my $start = '0001';
my @out = join "\t", @menufields;
while($text =~ s{}{}is) {
my $blob = $1;
my $desc = '';
$blob =~ m{^[^>]*\s+title=(['"]?)(.*?)\1}
and $desc = $2;
$blob =~ s{^.*?\shref\s*=\s*(["'])?(.*?)\1}{}is
or next;
my $link = $2;
$blob =~ s/.*?>//;
1 while $blob =~ s{<.*?>}{};
$anchor = $blob;
my $sort = $start;
$sort =~ s/./x/;
my($href, $parms) = split /\?/, $link, 2;
my %record = (
code => $start++,
msort => $sort,
page => $href,
form => $parms,
name => $anchor,
description => $desc,
);
push @out, join "\t", @record{@menufields};
}
$Scratch->{qmenu_data} = join "\n", @out, '';
$CGI->{qmenu_name} = '';
$CGI->{qmenu_new} ||= 'Untitled';
}
my $files = $Tag->list_pages({
base => $menupath,
ext => '.txt',
arrayref => 1,
});
#Debug("files=" . join(",", @$files));
my @names;
for(@$files) {
my $tmp = $_;
$tmp =~ s/%([A-Fa-f0-9]{2})/chr(hex $1)/eg;
$_ = "$menupath/$_.txt";
push @names, $tmp;
}
@qmenu{@names} = @$files;
my @fdata = "code\tfile";
for(my $i = 0; $i < @names; $i++) {
push @fdata, "$names[$i]\t$files->[$i]";
}
$Scratch->{qmenu_fdata} = join "\n", @fdata;
if(my $mn = $CGI->{qmenu_name}) {
my $filedata = $Tag->file($qmenu{$mn});
if(! $filedata) {
$filedata = $Tag->file("$menupath/$mn.txt");
## Aha, in admin include
$CGI->{qmenu_new} ||= $mn;
}
if($filedata) {
$filedata =~ /^(.*)/;
my $f = $1;
$f =~ s/\s+$//;
@menufields = split /\t/, $f;
}
else {
$filedata = join("\t", @menufields);
}
$Scratch->{qmenu_data} = $filedata;
$Scratch->{qmenu_name} = $mn;
my $mbase;
for $mbase ( $CGI->{ui_meta_view}, "menu_editor::$mn") {
$menumeta = $Tag->meta_record($mbase)
and $metabase = $mbase
and last;
}
}
my %illegal;
my @illegal = qw/check msg code/;
my %suggested = qw/
extended 1
inactive 1
/;
my @required = qw/
description
form
mgroup
msort
name
page
/;
@required{@required} = @required;
@illegal{@illegal} = @illegal;
my $illegal = 0;
for(my $i = 1; $i < @menufields; $i++) {
my $f = lc $menufields[$i];
$menu_fh{$f} = $i;
delete $required{$f};
delete $suggested{$f};
if($illegal{$f}) {
$Tag->error({
name => 'Illegal field name',
set => errmsg( "Name reserved: %s.", $f),
});
$illegal++;
}
}
@suggested = keys %suggested;
for(keys %required) {
$Tag->error({
set => errmsg( "Required field '%s' missing.", $_),
});
$illegal++;
}
delete $Scratch->{qmenu_data} if $illegal;
@required{@required} = @required;
return;
[/perl]
[tmp qmenu_options]
[loop head-skip=1 lr=1 list="[scratch qmenu_fdata]" cgi=1 option=qmenu_name]
[/loop]
[/tmp]
[if scratch qmenu_options =~ /\S/] [/if] |
|
[error all=1 text="