t/cfg/cfg/99end.cfg
t/cfg/isafile.cfg
t/cfg/t/varinc.cfg
+t/data/t101.jpg
t/t000load.t
t/t00smoke.t makes a request to most of the scripts
t/t010template.t Tests Squirrel::Template
t/t12cat.t
t/t13parent.t
t/t13steps.t
+t/t15api.t
t/t20gen.t
t/t21gencat.t Tests catalog generation
t/t30rules.t Check for use strict and warnings
package BSE::API;
use strict;
-use vars qw(@ISA @EXPORT_OK);
use BSE::Util::SQL qw(sql_datetime now_sqldatetime);
use BSE::DB;
use BSE::Cfg;
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT_OK = qw(bse_init bse_cfg bse_make_product bse_make_catalog bse_encoding bse_add_image bse_add_step_child bse_add_owned_file bse_delete_owned_file bse_replace_owned_file bse_make_article bse_add_step_parent);
+use Exporter qw(import);
+our @EXPORT_OK = qw(bse_init bse_cfg bse_make_product bse_make_catalog bse_encoding bse_add_image bse_save_image bse_add_step_child bse_add_owned_file bse_delete_owned_file bse_replace_owned_file bse_make_article bse_add_step_parent);
+our %EXPORT_TAGS = ( all => \@EXPORT_OK );
use Carp qw(confess croak);
use Fcntl qw(:seek);
use Cwd;
-our $VERSION = "1.001";
+our $VERSION = "1.002";
my %acticle_defaults =
(
titleAlias => '',
linkAlias => '',
category => '',
+ parentid => -1,
);
my %product_defaults =
defined $opts{title} && length $opts{title}
or confess "Missing title option\n";
- defined $opts{body} && length $opts{body}
- or confess "Missing body option\n";
$opts{summary} ||= $opts{title};
unless ($opts{displayOrder}) {
my $editor;
($editor, $article) = _load_editor_class($article, $cfg);
- my %image;
- my $file = delete $opts{file};
- $file
- or croak "Missing image filename";
- open IN, "< $file"
- or croak "Failed opening image file $file: $!";
- binmode IN;
+ my $fh;
+
+ my $filename = delete $opts{file};
+ if ($filename) {
+ open $fh, "< $filename"
+ or croak "Failed opening image file $filename: $!";
+ binmode $fh;
+ }
+ elsif ($opts{fh}) {
+ $filename = $opts{display_name}
+ or confess "No image display name supplied with fh";
+ $fh = $opts{fh};
+ }
+ else {
+ confess "Missing fh or file parameter";
+ }
my %errors;
$editor->do_add_image
(
$cfg,
$article,
- *IN,
+ $fh,
+ %opts,
+ errors => $opts{errors} || \%errors,
+ filename => $filename,
+ );
+}
+
+sub bse_language {
+ return $cfg->entry("site", "language", "en_AU");
+}
+
+{
+ my $msgs;
+
+ sub bse_msg_text {
+ my ($lang, $id, $parms, $def) = @_;
+
+ unless ($msgs) {
+ require BSE::Message;
+ $msgs = BSE::Message->new;
+ }
+
+ return $msgs->text($lang, $id, $parms, $def);
+ }
+}
+
+sub bse_save_image {
+ my ($image, %opts) = @_;
+
+ my @warn;
+ my $result = $image->update
+ (
+ _language => bse_language(),
+ _actor => "S",
+ _warnings => \@warn,
%opts,
- errors => \%errors,
- filename => $file,
);
+ if (@warn) {
+ warn "$_\n" for @warn;
+ }
+
+ return $result;
}
sub _load_editor_class {
package BSE::Cache;
use strict;
-our $VERSION = "1.000";
+our $VERSION = "1.001";
sub load {
my ($class, $cfg) = @_;
defined $cache_class
or return;
( my $cache_mod_file = $cache_class . ".pm" ) =~ s(::)(/)g;
- require $cache_mod_file;
- return $cache_class->new($cfg);
+ my $result = eval {
+ require $cache_mod_file;
+ return $cache_class->new($cfg);
+ };
+ unless ($result) {
+ require BSE::TB::AuditLog;
+ BSE::TB::AuditLog->log
+ (
+ component => "cache::load",
+ level => "error",
+ actor => "S",
+ msg => "Failed to load or create cache object: $@",
+ dump => <<EOS
+Class: $cache_class
+Module: $cache_mod_file
+Error: $@
+EOS
+ );
+ }
+
+ return $result;
}
1;
package BSE::Cache::Cache;
use strict;
-our $VERSION = "1.000";
+our $VERSION = "1.001";
# BSE cache interface for Cache interface compatible caches.
sub get {
my ($self, $key) = @_;
- my $entry = $self->{cache}->entry($key);
- $entry->exists
- or return;
+ my $result;
+ eval {
+ my $entry = $self->{cache}->entry($key);
+ $entry->exists
+ or return;
+
+ $result = $entry->thaw;
+ } or do {
+ return;
+ };
- return $entry->thaw;
+ return $result;
}
sub delete {
use List::Util qw(first);
use constant MAX_FILE_DISPLAYNAME_LENGTH => 255;
-our $VERSION = "1.010";
+our $VERSION = "1.011";
=head1 NAME
};
}
+# FIXME: eliminate this method and call get_ftype directly
sub _image_ftype {
my ($self, $type) = @_;
- if ($type eq 'CWS' || $type eq 'SWF') {
- return "flash";
- }
-
- return "img";
+ require BSE::TB::Images;
+ return BSE::TB::Images->get_ftype($type);
}
sub do_add_image {
$errors->{image} = $msg;
return;
}
-print STDERR "Gen filename '$filename'\n";
+
# for OSs with special text line endings
binmode $fh;
sub _image_manager {
my ($self) = @_;
- require BSE::StorageMgr::Images;
-
- return BSE::StorageMgr::Images->new(cfg => $self->cfg);
+ require BSE::TB::Images;
+ return BSE::TB::Images->storage_manager;
}
# remove an image
package BSE::Edit::Base;
use strict;
-our $VERSION = "1.000";
+our $VERSION = "1.001";
# one day I might put something useful here
sub new {
my ($class, %parms) = @_;
- $parms{cfg}
- or die "Missing cfg parameter";
+ $parms{cfg} ||= BSE::Cfg->single;
return bless \%parms, $class;
}
@ISA = qw/Squirrel::Row/;
use Carp 'confess';
-our $VERSION = "1.003";
+our $VERSION = "1.004";
sub columns {
return qw/id articleId displayName filename sizeInBytes description
return 1;
}
+sub update {
+ my ($self, %opts) = @_;
+
+ my $actor = $opts{_actor}
+ or confess "Missing _actor parameter";
+
+ my $warnings = $opts{_warnings}
+ or confess "Missing _warnings parameter";
+
+ my $cfg = BSE::Cfg->single;
+ my $file_dir = BSE::TB::ArticleFiles->download_path($cfg);
+ my $old_storage = $self->storage;
+ my $delete_file;
+ if ($opts{filename} || $opts{file}) {
+ my $src_filename = delete $opts{filename};
+ my $filename;
+ if ($src_filename) {
+ if ($src_filename =~ /^\Q$file_dir\E/) {
+ # created in the right place, use it
+ $filename = $src_filename;
+ }
+ else {
+ open my $in_fh, "<", $src_filename
+ or die "Cannot open $src_filename: $!\n";
+ binmode $in_fh;
+
+ require DevHelp::FileUpload;
+ my $msg;
+ ($filename) = DevHelp::FileUpload->
+ make_img_copy($file_dir, $opts{displayName}, \$msg)
+ or die "$msg\n";
+ }
+ }
+ elsif ($opts{file}) {
+ my $file = delete $opts{file};
+ require DevHelp::FileUpload;
+ my $msg;
+ ($filename) = DevHelp::FileUpload->
+ make_fh_copy($file, $file_dir, $opts{displayName}, \$msg)
+ or die "$msg\n";
+ }
+
+ my $fullpath = $file_dir . '/' . $filename;
+ $self->set_filename($filename);
+ $self->set_sizeInBytes(-s $fullpath);
+ $self->setDisplayName($opts{displayName});
+
+ unless ($opts{contentType}) {
+ require BSE::Util::ContentType;
+ $self->set_contentType(BSE::Util::ContentType::content_type($cfg, $opts{displayName}));
+ }
+
+ $self->set_handler($cfg);
+ }
+
+ my $type = delete $opts{contentType};
+ if (defined $type) {
+ $self->set_contentType($type);
+ }
+
+ my $name = $opts{name};
+ $self->id != -1 || defined $name && $name =~ /\S/
+ or die "name is required for global files\n";
+ if (defined $name && $name =~ /\S/) {
+ $name =~ /^\w+$/
+ or die "name must be a single word\n";
+ my ($other) = BSE::TB::ArticleFiles->getBy(articleId => $self->id,
+ name => $name);
+ $other && $other->id != $self->id
+ and die "Duplicate file name (identifier)\n";
+
+ $self->set_name($name);
+ }
+
+ $self->save;
+
+ my $mgr = BSE::TB::ArticleFiles->file_manager($cfg);
+ if ($delete_file) {
+ if ($old_storage ne "local") {
+ $mgr->unstore($delete_file);
+ }
+ unlink "$file_dir/$delete_file";
+
+ $old_storage = "local";
+ }
+
+ my $storage = delete $opts{storage} || '';
+
+ my $new_storage;
+ eval {
+ $new_storage =
+ $mgr->select_store($self->filename, $storage, $self);
+ if ($old_storage ne $new_storage) {
+ # handles both new images (which sets storage to local) and changing
+ # the storage for old images
+ my $src = $mgr->store($self->filename, $new_storage, $self);
+ $self->set_src($src);
+ $self->set_storage($new_storage);
+ $self->save;
+ }
+ 1;
+ } or do {
+ my $msg = $@;
+ chomp $msg;
+ require BSE::TB::AuditLog;
+ BSE::TB::AuditLog->log
+ (
+ component => "admin:edit:saveimage",
+ level => "warn",
+ object => $self,
+ actor => $actor,
+ msg => "Error saving file to storage $new_storage: $msg",
+ );
+ push @$warnings, "msg:bse/admin/edit/file/save/savetostore:$msg";
+ };
+
+ if ($self->storage ne $old_storage && $old_storage ne "local") {
+ eval {
+ $mgr->unstore($self->filename, $old_storage);
+ 1;
+ } or do {
+ my $msg = $@;
+ chomp $msg;
+ require BSE::TB::AuditLog;
+ BSE::TB::AuditLog->log
+ (
+ component => "admin:edit:savefile",
+ level => "warn",
+ object => $self,
+ actor => $actor,
+ msg => "Error saving file to storage $new_storage: $msg",
+ );
+ push @$warnings, "msg:bse/admin/edit/file/save/delfromstore:$msg";
+ };
+ }
+
+}
+
1;
@ISA = qw/Squirrel::Row BSE::ThumbCommon/;
use Carp qw(confess);
-our $VERSION = "1.002";
+our $VERSION = "1.003";
sub columns {
return qw/id articleId image alt width height url displayOrder name
sub image_url {
my ($im) = @_;
- $im->src || "/images/$im->{image}";
+ return $im->src || BSE::TB::Images->base_uri . $im->image;
}
sub json_data {
return $self->image;
}
+sub article {
+ my ($self) = @_;
+
+ if ($self->articleId == -1) {
+ require BSE::TB::Site;
+ return BSE::TB::Site->new;
+ }
+ else {
+ require Articles;
+ return Articles->getByPkey($self->articleId);
+ }
+}
+
+sub update {
+ my ($image, %opts) = @_;
+
+ my $errors = delete $opts{errors}
+ or confess "Missing errors parameter";
+
+ my $actor = $opts{_actor}
+ or confess "Missing _actor parameter";
+
+ my $warnings = $opts{_warnings}
+ or confess "Missing _warnings parameter";
+
+ require BSE::CfgInfo;
+ my $cfg = BSE::Cfg->single;
+ my $image_dir = BSE::CfgInfo::cfg_image_dir($cfg);
+ my $fh = $opts{fh};
+ my $fh_field = "fh";
+ my $delete_file;
+ my $old_storage = $image->storage;
+ my $filename;
+ if ($fh) {
+ $filename = $opts{display_name}
+ or confess "Missing display_name";
+ }
+ elsif ($opts{file}) {
+ unless (open $fh, "<", $opts{file}) {
+ $errors->{filename} = "Cannot open $opts{file}: $!";
+ return;
+ }
+ $fh_field = "file";
+ $filename = $opts{file};
+ }
+ if ($fh) {
+ local $SIG{__DIE__};
+ eval {
+ my $msg;
+ require DevHelp::FileUpload;
+ my ($image_name) = DevHelp::FileUpload->
+ make_fh_copy($fh, $image_dir, $filename, \$msg)
+ or die "$msg\n";
+
+ my $full_filename = "$image_dir/$image_name";
+ require Image::Size;
+ my ($width, $height, $type) = Image::Size::imgsize($full_filename);
+ if ($width) {
+ $delete_file = $image->image;
+ $image->set_image($image_name);
+ $image->set_width($width);
+ $image->set_height($height);
+ $image->set_storage("local");
+ $image->set_src(BSE::TB::Images->base_uri . $image_name);
+ $image->set_ftype(BSE::TB::Images->get_ftype($type));
+ }
+ else {
+ die "$type\n";
+ }
+
+ 1;
+ } or do {
+ chomp($errors->{$fh_field} = $@);
+ };
+ }
+
+ my $name = $opts{name};
+ if (defined $name) {
+ unless ($name =~ /^[a-z_]\w*$/i) {
+ $errors->{name} = "msg:bse/admin/edit/image/save/nameformat:$name";
+ }
+ if (!$errors->{name} && length $name && $name ne $image->name) {
+ # check for a duplicate
+ my @other_images = grep $_->id != $image->id, $image->article->images;
+ if (grep $name eq $_->name, @other_images) {
+ $errors->{name} = "msg:bse/admin/edit/image/save/namedup:$name";
+ }
+ }
+ }
+
+ if (defined $opts{alt}) {
+ $image->set_alt($opts{alt});
+ }
+
+ if (defined $opts{url}) {
+ $image->set_url($opts{url});
+ }
+
+ keys %$errors
+ and return;
+
+ my $new_storage = $opts{storage};
+ defined $new_storage or $new_storage = $image->storage;
+ $image->save;
+
+ my $mgr = BSE::TB::Images->storage_manager;
+
+ if ($delete_file) {
+ if ($old_storage ne "local") {
+ $mgr->unstore($delete_file);
+ }
+ unlink "$image_dir/$delete_file";
+
+ $old_storage = "local";
+ }
+
+ # try to set the storage, this failing doesn't fail the save
+ eval {
+ $new_storage =
+ $mgr->select_store($image->image, $new_storage, $image);
+ if ($image->storage ne $new_storage) {
+ # handles both new images (which sets storage to local) and changing
+ # the storage for old images
+ $old_storage = $image->storage;
+ my $src = $mgr->store($image->image, $new_storage, $image);
+ $image->set_src($src);
+ $image->set_storage($new_storage);
+ $image->save;
+ }
+ 1;
+ } or do {
+ my $msg = $@;
+ chomp $msg;
+ require BSE::TB::AuditLog;
+ BSE::TB::AuditLog->log
+ (
+ component => "admin:edit:saveimage",
+ level => "warn",
+ object => $image,
+ actor => $actor,
+ msg => "Error saving image to storage $new_storage: $msg",
+ );
+ push @$warnings, "msg:bse/admin/edit/image/save/savetostore:$msg";
+ };
+
+ if ($image->storage ne $old_storage && $old_storage ne "local") {
+ eval {
+ $mgr->unstore($image->image, $old_storage);
+ 1;
+ } or do {
+ my $msg = $@;
+ chomp $msg;
+ require BSE::TB::AuditLog;
+ BSE::TB::AuditLog->log
+ (
+ component => "admin:edit:saveimage",
+ level => "warn",
+ object => $image,
+ actor => $actor,
+ msg => "Error saving image to storage $new_storage: $msg",
+ );
+ push @$warnings, "msg:bse/admin/edit/image/save/delfromstore:$msg";
+ };
+ }
+
+ return 1;
+}
+
1;
@ISA = qw(Squirrel::Table);
use BSE::TB::Image;
-our $VERSION = "1.001";
+our $VERSION = "1.002";
sub rowClass {
return 'BSE::TB::Image';
return BSE::CfgInfo::cfg_image_dir(BSE::Cfg->single);
}
+=item base_uri
+
+Return the base URI for images stored in the image_dir().
+
+Traditionally C</images/>, but it's meant to be configurable.
+
+=cut
+
+sub base_uri {
+ return BSE::Cfg->single->entryIfVar("site", "images", "/images/");
+}
+
+=item get_ftype($is_type)
+
+Translate an Image::Size file type into a value for the ftype
+attribute.
+
+=cut
+
+sub get_ftype {
+ my ($self, $type) = @_;
+
+ if ($type eq 'CWS' || $type eq 'SWF') {
+ return "flash";
+ }
+
+ return "img";
+}
+
+=item storage_manager
+
+Return the images storage manager.
+
+=cut
+
+sub storage_manager {
+ require BSE::StorageMgr::Images;
+
+ return BSE::StorageMgr::Images->new(cfg => BSE::Cfg->single);
+}
+
1;
use constant CACHE_AGE => 30;
use constant VAR_DEPTH => 10;
-our $VERSION = "1.001";
+our $VERSION = "1.002";
my %cache;
$value;
}
-=item entryIfVar($section, $key)
+=item entryIfVar($section, $key, $def)
-Same as entryVar(), except that it returns undef if there is no value
+Same as entryVar(), except that it returns $def if there is no value
for the given section/key.
=cut
sub entryIfVar {
- my ($self, $section, $key) = @_;
+ my ($self, $section, $key, $def) = @_;
my $value = $self->entry($section, $key);
if (defined $value) {
- $value = $self->entryVar($section, $key);
+ return $self->entryVar($section, $key);
}
- $value;
+ return $def;
}
=item entryBool($section, $key, [ $def ])
use IO::File;
use File::Copy;
-our $VERSION = "1.000";
+our $VERSION = "1.001";
=head1 NAME
return $newname;
}
+=item DevHelp::FileUpload->make_fh_copy($fh, $imgdir, $name, \$msg)
+
+=cut
+
+sub make_fh_copy {
+ my ($class, $fh, $imgdir, $name, $rmsg) = @_;
+
+ my ($newname, $out_fh) = $class->make_img_filename($imgdir, $name, $rmsg)
+ or return;
+
+ # $fh might be a CGI.pm special that confuses File::Copy
+ local $/ = \8192;
+ binmode $fh;
+ binmode $out_fh;
+ while (my $block = <$fh>) {
+ print $out_fh $block;
+ }
+ unless (close $out_fh) {
+ $$rmsg = "Cannot write work file: $!";
+ unlink "$imgdir/$newname";
+ return;
+ }
+
+ return $newname;
+}
+
=item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
=cut
id: bse/admin/edit/
description: Article editor messages
+id: bse/admin/edit/image/
+description: Article editor image messages
+
+id: bse/admin/edit/image/save/
+description: Messages from saving images
+
+id: bse/admin/edit/image/save/namedup
+description: Message for a duplicate image name ($1 - the offending name)
+
+id: bse/admin/edit/image/save/nameformat
+description: Message for an invalid name ($1 - the offending name)
+
+id: bse/admin/edit/image/save/delfromstore
+description: If the image couldn't be deleted from an external store ($1 - the back end error message)
+
+id: bse/admin/edit/image/save/savetostore
+description: If the image couldn't saved to an external store ($1 - the back end error message)
+
+id: bse/admin/edit/file/
+description: Article file manipulation
+
+id: bse/admin/edit/file/save/
+description: Saving an article file
+
+id: bse/admin/edit/file/save/savetostore
+description: If the file couldn't saved to an external store ($1 - the back end error message)
+
+id: bse/admin/edit/file/save/delfromstore
+description: If the image couldn't be deleted from an external store ($1 - the back end error message)
+
id: bse/admin/edit/uplabelsect
description: label in parent list to make article a section
---
-# VERSION=1.002
+# VERSION=1.003
# defaults for the following
language_code: en
priority: 0
id: bse/user/downloaderror/unfilled
message: The order containing this file hasn't been filled. Please contact us.
+id: bse/admin/edit/image/save/nameformat
+message: Image identifiers must be a letter or underscore followed by zero or more letters, underscores or digits
+
+id: bse/admin/edit/image/save/namedup
+message: Duplicate image identifier '$1'
+
+id: bse/admin/edit/image/save/savetostore
+message: Could not save image to external store: $1
+
+id: bse/admin/edit/image/save/delfromstore
+message: Could not delete image from external store: $1
+
+id: bse/admin/edit/file/save/savetostore
+message: Could not save file to external store: $1
+
+id: bse/admin/edit/file/save/delfromstore
+message: Could not delete file from external store: $1
+
id: bse/admin/edit/uplabelsect
message: -- move up a level -- become a section
--- /dev/null
+#!perl -w
+use strict;
+use BSE::Test ();
+use Test::More tests => 16;
+use File::Spec;
+use Carp qw(confess);
+
+$SIG{__DIE__} = sub { confess @_ };
+
+BEGIN {
+ unshift @INC, File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin", "modules");
+}
+
+BEGIN { use_ok("BSE::API", ":all") }
+
+my $base_cgi = File::Spec->catdir(BSE::Test::base_dir(), "cgi-bin");
+ok(bse_init($base_cgi), "initialize api")
+ or print "# failed to bse_init in $base_cgi\n";
+my $cfg = bse_cfg();
+ok($cfg, "we have a cfg object");
+
+my $art = bse_make_article(cfg => $cfg,
+ title => "API test");
+ok($art, "make a basic article");
+
+my $im1 = bse_add_image($cfg, $art, file => "t/data/t101.jpg");
+ok($im1, "add an image, just a filename");
+
+my $im2;
+{
+ open my $fh, "<", "t/data/t101.jpg"
+ or die "Cannot open test image: $!\n";
+ $im2 = bse_add_image($cfg, $art, fh => $fh, display_name => "t101.jpg");
+ ok($im2, "add an image by fh");
+}
+
+# just set alt text
+{
+ my %errors;
+ ok(bse_save_image($im1, alt => "Test", errors => \%errors),
+ "update alt text");
+ my $im = BSE::TB::Images->getByPkey($im1->id);
+ ok($im, "found im1 independently");
+ is($im->alt, "Test", "alt is set");
+}
+
+{ # change the image content (by name)
+ my %errors;
+ ok(bse_save_image($im1, file => "t/data/govhouse.jpg", errors => \%errors),
+ "save new image content");
+ is_deeply(\%errors, {}, "no errors");
+ like($im1->src, qr(^/), "src should start with /, assuming no storage");
+}
+
+{ # change the image content (by fh)
+ my %errors;
+ open my $fh, "<", "t/data/govhouse.jpg"
+ or die "Cannot open t/data/govhouse.jpg: $!";
+ ok(bse_save_image($im2, fh => $fh, , display_name => "govhouse.jpg",
+ errors => \%errors),
+ "save new image content (by fh)");
+ is_deeply(\%errors, {}, "no errors");
+ like($im2->src, qr(^/), "src should start with /, assuming no storage");
+}
+
+ok($art->remove($cfg), "remove article");
projects / bse.git / commitdiff
