554 lines
13 KiB
Perl
554 lines
13 KiB
Perl
|
#!/usr/bin/perl
|
||
|
|
#
|
||
|
|
# DW::Shop::Item
|
||
|
|
#
|
||
|
|
# Base class containing basic behavior for items to be sold in the shop
|
||
|
|
#
|
||
|
|
# Authors:
|
||
|
|
# Mark Smith <mark@dreamwidth.org>
|
||
|
|
# Janine Smith <janine@netrophic.com>
|
||
|
|
# Afuna <coder.dw@afunamatata.com>
|
||
|
|
#
|
||
|
|
# Copyright (c) 2009 by Dreamwidth Studios, LLC.
|
||
|
|
#
|
||
|
|
# This program is free software; you may redistribute it and/or modify it under
|
||
|
|
# the same terms as Perl itself. For a copy of the license, please reference
|
||
|
|
# 'perldoc perlartistic' or 'perldoc perlgpl'.
|
||
|
|
#
|
||
|
|
|
||
|
|
package DW::Shop::Item;
|
||
|
|
|
||
|
|
use strict;
|
||
|
|
use Carp;
|
||
|
|
use DW::InviteCodes;
|
||
|
|
use DW::Pay;
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
DW::Shop::Item - base class containing basic behavior for items to be sold in the shop
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
=head1 API
|
||
|
|
|
||
|
|
=head2 C<< $class->new( [ $opts ] ) >>
|
||
|
|
|
||
|
|
Instantiates an item to be purchased in the shop. The item must be defined in the
|
||
|
|
%LJ::SHOP hash in your config file.
|
||
|
|
|
||
|
|
Arguments:
|
||
|
|
=item type => item type, passed in by a subclass. Must be configured in %LJ::SHOP
|
||
|
|
=item target_userid => userid,
|
||
|
|
=item target_email => email,
|
||
|
|
=item from_userid => userid,
|
||
|
|
=item deliverydate => "yyyy-mm-dd",
|
||
|
|
=item anonymous => 1,
|
||
|
|
=item anonymous_target => 1,
|
||
|
|
=item cannot_conflict => 1,
|
||
|
|
=item noremove => 1,
|
||
|
|
=item from_name => sender name,
|
||
|
|
=item reason => personal note from sender to target
|
||
|
|
|
||
|
|
The type is required. Also, one target_* argument is required; it may be either
|
||
|
|
a target_userid or a target_email. All other arguments are optional.
|
||
|
|
|
||
|
|
Subclasses must override this function to set the type. Subclasses may also do any
|
||
|
|
other modifications necessary when instantiating itself. See DW::Shop::Item::Account
|
||
|
|
for an example.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my ( $class, %args ) = @_;
|
||
|
|
return undef unless exists $LJ::SHOP{ $args{type} };
|
||
|
|
|
||
|
|
# from_userid will be 0 or undef if the sender isn't logged in
|
||
|
|
# but if we have a userid, and it doesn't load properly, bail out here.
|
||
|
|
return undef if $args{from_userid} && !LJ::load_userid( $args{from_userid} );
|
||
|
|
|
||
|
|
# now do validation. since new is only called when the item is being added
|
||
|
|
# to the shopping cart, then we are comfortable doing all of these checks
|
||
|
|
# on things at the time this item is put together
|
||
|
|
if ( my $uid = $args{target_userid} ) {
|
||
|
|
|
||
|
|
# userid needs to exist
|
||
|
|
return undef unless LJ::load_userid($uid);
|
||
|
|
}
|
||
|
|
elsif ( my $email = $args{target_email} ) {
|
||
|
|
|
||
|
|
# email address must be valid
|
||
|
|
my @email_errors;
|
||
|
|
LJ::check_email( $email, \@email_errors,
|
||
|
|
{ force_spelling => delete $args{force_spelling} } );
|
||
|
|
return undef if @email_errors;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $args{deliverydate} ) {
|
||
|
|
return undef unless $args{deliverydate} =~ /^\d\d\d\d-\d\d-\d\d$/;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $args{anonymous} ) {
|
||
|
|
return undef unless $args{anonymous} == 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $args{cannot_conflict} ) {
|
||
|
|
return undef unless $args{cannot_conflict} == 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ( $args{noremove} ) {
|
||
|
|
return undef unless $args{noremove} == 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
# looks good
|
||
|
|
my $confargs = $LJ::SHOP{ $args{type} }; # arrayref
|
||
|
|
|
||
|
|
# points and vgifts have empty args, which will cause undef warnings
|
||
|
|
$confargs = [ 0, 0, 0, 0 ] unless scalar @$confargs;
|
||
|
|
|
||
|
|
return bless {
|
||
|
|
|
||
|
|
# user supplied arguments (close enough)
|
||
|
|
cost_cash => $confargs->[0] + 0.00,
|
||
|
|
cost_points => $confargs->[3] + 0,
|
||
|
|
%args,
|
||
|
|
|
||
|
|
# internal things we use to track the state of this item,
|
||
|
|
applied => 0,
|
||
|
|
cartid => 0,
|
||
|
|
}, $class;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->apply_automatically >>
|
||
|
|
|
||
|
|
True if you want the item to be applied via the paidstatus worker, and false
|
||
|
|
if you wish to apply the item yourself (usually triggered by a user action).
|
||
|
|
|
||
|
|
Subclasses may override.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub apply_automatically { 1 }
|
||
|
|
|
||
|
|
=head2 C<< $self->apply >>
|
||
|
|
|
||
|
|
Called when we are told we need to apply this item, i.e., turn it on. Note that we
|
||
|
|
update ourselves, but it's up to the cart to make sure that it saves.
|
||
|
|
|
||
|
|
Subclasses may override this method, but a better approach would be to override the
|
||
|
|
internal $self->_apply method.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub apply {
|
||
|
|
my $self = shift;
|
||
|
|
return 1 if $self->applied;
|
||
|
|
|
||
|
|
# 1) deliverydate must be present/past
|
||
|
|
if ( my $ddate = $self->deliverydate ) {
|
||
|
|
my $cur = LJ::mysql_time();
|
||
|
|
$cur =~ s/^(\d\d\d\d-\d\d-\d\d).+$/$1/;
|
||
|
|
|
||
|
|
return 0
|
||
|
|
unless $ddate le $cur;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $self->_apply(@_);
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->_apply >>
|
||
|
|
|
||
|
|
Internal application sub.
|
||
|
|
|
||
|
|
Subclasses must override this for item-specific behavior.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub _apply {
|
||
|
|
croak "Cannot apply shop item; this method must be override by a subclass.";
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->unapply >>
|
||
|
|
|
||
|
|
Called when we need to turn this item off.
|
||
|
|
|
||
|
|
Subclasses may override this to add additional behavior or warnings.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub unapply {
|
||
|
|
my $self = $_[0];
|
||
|
|
return unless $self->applied;
|
||
|
|
|
||
|
|
# do the application process now, and if it succeeds...
|
||
|
|
$self->{applied} = 0;
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->cart_state_changed( $cart, $newstate ) >>
|
||
|
|
|
||
|
|
Hook in the cart for custom behavior once the cart has been changed.
|
||
|
|
|
||
|
|
Subclasses may override this for custom behavior: for example, creating a token or certificate once the cart has been paid for.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cart_state_changed {
|
||
|
|
my ( $cart, $newstate ) = @_;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->can_be_added( [ %opts ] ) >>
|
||
|
|
|
||
|
|
Returns 1 if this item is allowed to be added to the shopping cart.
|
||
|
|
|
||
|
|
Subclasses must override this.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub can_be_added {
|
||
|
|
my ( $self, %opts ) = @_;
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->can_have_reason( [ %opts ] ) >>
|
||
|
|
|
||
|
|
Returns 1 if this item is allowed to have a personal note from the
|
||
|
|
sender explaining the reason for the gift.
|
||
|
|
|
||
|
|
Subclasses must override this in order to disallow.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub can_have_reason {
|
||
|
|
my ( $self, %opts ) = @_;
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->conflicts( $item ) >>
|
||
|
|
|
||
|
|
Given another item, see if that item conflicts with this item (i.e.,
|
||
|
|
if you can't have both in your shopping cart at the same time).
|
||
|
|
|
||
|
|
Returns undef on "no conflict" else an error message.
|
||
|
|
|
||
|
|
Subclasses may override.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub conflicts {
|
||
|
|
my ( $self, $item ) = @_;
|
||
|
|
|
||
|
|
# if either item are set as "does not conflict" then never say yes
|
||
|
|
return
|
||
|
|
if $self->cannot_conflict || $item->cannot_conflict;
|
||
|
|
|
||
|
|
# subclasses can add additional logic here
|
||
|
|
|
||
|
|
# guess we allow it
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->t_html( [ %opts ] ) >>
|
||
|
|
|
||
|
|
Render our target as a string.
|
||
|
|
|
||
|
|
Subclasses may override.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub t_html {
|
||
|
|
my ( $self, $opts ) = @_;
|
||
|
|
|
||
|
|
if ( my $uid = $self->t_userid ) {
|
||
|
|
my $u = LJ::load_userid($uid);
|
||
|
|
return $u->ljuser_display
|
||
|
|
if $u;
|
||
|
|
return "<strong>invalid userid $uid</strong>";
|
||
|
|
|
||
|
|
}
|
||
|
|
elsif ( my $email = $self->t_email ) {
|
||
|
|
return "<strong>$email</strong>";
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
return "<strong>invalid/unknown target</strong>";
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->name_text >>
|
||
|
|
|
||
|
|
Render the item name as a string, for display, to be used in contexts which don't allow HTML.
|
||
|
|
|
||
|
|
Subclasses must override to provide a more specific and user-friendly display name.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub name_text {
|
||
|
|
return ref $_[0];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->name_html >>
|
||
|
|
|
||
|
|
Render the item name as a string for display, to be used in contexts which accept HTML.
|
||
|
|
|
||
|
|
Subclasses may override to provide a version of the name containing HTML. Uses $self->name_text by default.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub name_html {
|
||
|
|
return $_[0]->name_text;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->note >>
|
||
|
|
|
||
|
|
Render a note to the user about this item.
|
||
|
|
|
||
|
|
Subclasses may override to provide a brief note about this item.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub note {
|
||
|
|
return "";
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->short_desc >>
|
||
|
|
|
||
|
|
Returns a short string talking about what this is.
|
||
|
|
|
||
|
|
Subclasses may override to provide further description.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub short_desc {
|
||
|
|
my ( $self, %opts ) = @_;
|
||
|
|
|
||
|
|
# does not contain HTML, I hope
|
||
|
|
my $desc = $opts{nohtml} ? $self->name_text : $self->name_html;
|
||
|
|
|
||
|
|
my $for = $self->t_email;
|
||
|
|
unless ($for) {
|
||
|
|
my $u = LJ::load_userid( $self->t_userid );
|
||
|
|
$for = $u->user
|
||
|
|
if $u;
|
||
|
|
}
|
||
|
|
|
||
|
|
# FIXME: english strip
|
||
|
|
return "$desc for $for";
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->id( $id ) >>
|
||
|
|
|
||
|
|
This is a getter/setter so it is pulled out.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub id {
|
||
|
|
return $_[0]->{id} unless defined $_[1];
|
||
|
|
return $_[0]->{id} = $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->cartid( $cartid ) >>
|
||
|
|
|
||
|
|
Gets/sets.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cartid {
|
||
|
|
return $_[0]->{cartid} unless defined $_[1];
|
||
|
|
return $_[0]->{cartid} = $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->t_userid( $target_userid ) >>
|
||
|
|
|
||
|
|
Gets/sets.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub t_userid {
|
||
|
|
return $_[0]->{target_userid} unless defined $_[1];
|
||
|
|
return $_[0]->{target_userid} = $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->from_html >>
|
||
|
|
|
||
|
|
Display who this is from, using ljuser_display.
|
||
|
|
|
||
|
|
=head2 C<< $self->from_text >>
|
||
|
|
|
||
|
|
Display who this is from, using display_name.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub from_html {
|
||
|
|
my $self = $_[0];
|
||
|
|
|
||
|
|
my $from = $self->_from_other;
|
||
|
|
return LJ::isu($from) ? $from->ljuser_display : LJ::ehtml($from);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub from_text {
|
||
|
|
my $self = $_[0];
|
||
|
|
|
||
|
|
my $from = $self->_from_other;
|
||
|
|
return LJ::isu($from) ? $from->display_name : $from;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _from_other {
|
||
|
|
my $self = $_[0];
|
||
|
|
|
||
|
|
return LJ::Lang::ml('widget.shopcart.anonymous') if $self->anonymous;
|
||
|
|
return $self->from_name if $self->from_name;
|
||
|
|
|
||
|
|
my $from_u = LJ::load_userid( $self->from_userid );
|
||
|
|
return LJ::Lang::ml('error.nojournal') unless LJ::isu($from_u);
|
||
|
|
|
||
|
|
return $from_u;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->paid_cash >>
|
||
|
|
|
||
|
|
Returns the amount paid for this item in USD. This varies from cart to cart
|
||
|
|
and item to item and is a reflection of the actual amount of cash paid for
|
||
|
|
this item. paid_points may also be non-zero.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
# this method has to be aware of old items
|
||
|
|
sub paid_cash {
|
||
|
|
my $self = $_[0];
|
||
|
|
|
||
|
|
# we try to promote the item to a new style. we don't know if this is
|
||
|
|
# going to get saved in the cart or not ...
|
||
|
|
if ( exists $self->{cost} ) {
|
||
|
|
$self->{paid_cash} = delete( $self->{cost} ) + 0.00;
|
||
|
|
$self->{paid_points} = 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $_[0]->{paid_cash} unless defined $_[1];
|
||
|
|
return $_[0]->{paid_cash} = $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->paid_points >>
|
||
|
|
|
||
|
|
Returns the amount paid in points for this item. This varies just like the
|
||
|
|
paid_cash item, which may also be non-zero for items that a user paid both
|
||
|
|
cash and points for.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub paid_points {
|
||
|
|
return $_[0]->{paid_points} unless defined $_[1];
|
||
|
|
return $_[0]->{paid_points} = $_[1];
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->display_paid >>
|
||
|
|
|
||
|
|
Displays how much cash and/or points this item costs right now.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub display_paid {
|
||
|
|
my $self = $_[0];
|
||
|
|
if ( $self->paid_cash && $self->paid_points ) {
|
||
|
|
return sprintf( '$%0.2f USD and %d points', $self->paid_cash, $self->paid_points );
|
||
|
|
}
|
||
|
|
elsif ( $self->paid_cash ) {
|
||
|
|
return sprintf( '$%0.2f USD', $self->paid_cash );
|
||
|
|
}
|
||
|
|
elsif ( $self->paid_points ) {
|
||
|
|
return sprintf( '%d points', $self->paid_points );
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return 'free';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->display_paid_cash >>
|
||
|
|
|
||
|
|
Display how much cash this item costs right now.
|
||
|
|
|
||
|
|
=head2 C<< $self->display_paid_points >>
|
||
|
|
|
||
|
|
Display how many points this item costs right now.
|
||
|
|
|
||
|
|
=head2 C<< $self->applied >>
|
||
|
|
|
||
|
|
Returns whether the item which was bought has been already applied
|
||
|
|
|
||
|
|
=head2 C<< $self->cost_cash >>
|
||
|
|
|
||
|
|
Returns the cost in USD of the item, as configured for this site.
|
||
|
|
|
||
|
|
=head2 C<< $self->cost_points >>
|
||
|
|
|
||
|
|
Returns the cost in points of the item, as configured for this site.
|
||
|
|
|
||
|
|
=head2 C<< $self->t_email >>
|
||
|
|
|
||
|
|
Returns the target email this item was sent to.
|
||
|
|
|
||
|
|
=head2 C<< $self->from_userid >>
|
||
|
|
|
||
|
|
Returns the userid of the person who bought this item. May be 0.
|
||
|
|
|
||
|
|
=head2 C<< $self->deliverydate >>
|
||
|
|
|
||
|
|
Returns the date this item should be delivered, in "yyyy-mm-dd" format
|
||
|
|
|
||
|
|
=head2 C<< $self->anonymous >>
|
||
|
|
|
||
|
|
Returns whether this item should be gifted anonymously, or credited to the sender
|
||
|
|
|
||
|
|
=head2 C<< $self->noremove >>
|
||
|
|
|
||
|
|
Returns whether this item may or may not be removed from the cart. May be used by
|
||
|
|
promotions which automatically add a promo item to a user's cart, to prevent the
|
||
|
|
promo item from being removed
|
||
|
|
|
||
|
|
=head2 C<< $self->from_name >>
|
||
|
|
|
||
|
|
Name of the sender in special cases. For example, can be the site name for
|
||
|
|
promotions. Not exposed/settable via the shop.
|
||
|
|
|
||
|
|
=head2 C<< $self->reason >>
|
||
|
|
|
||
|
|
Optional note from the sender explaining the reason for the gift.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub display_paid_cash { sprintf( '$%0.2f USD', $_[0]->paid_cash ) }
|
||
|
|
sub display_paid_points { sprintf( '%d points', $_[0]->paid_points ) }
|
||
|
|
sub applied { return $_[0]->{applied}; }
|
||
|
|
sub cost_points { return $_[0]->{cost_points}; }
|
||
|
|
sub t_email { return $_[0]->{target_email}; }
|
||
|
|
sub from_userid { return $_[0]->{from_userid}; }
|
||
|
|
sub deliverydate { return $_[0]->{deliverydate}; }
|
||
|
|
sub anonymous { return $_[0]->{anonymous}; }
|
||
|
|
sub noremove { return $_[0]->{noremove}; }
|
||
|
|
sub from_name { return $_[0]->{from_name}; }
|
||
|
|
sub reason { return $_[0]->{reason}; }
|
||
|
|
|
||
|
|
# this has to work with old items (pre-points) too
|
||
|
|
sub cost_cash {
|
||
|
|
my $self = $_[0];
|
||
|
|
return $self->{cost} + 0.00 if exists $self->{cost};
|
||
|
|
return $self->{cost_cash} + 0.00;
|
||
|
|
}
|
||
|
|
|
||
|
|
=head2 C<< $self->cannot_conflict >>
|
||
|
|
|
||
|
|
Returns whether this item may never conflict with any other item. If true, skip
|
||
|
|
checks for conflict.
|
||
|
|
|
||
|
|
Subclasses may override.
|
||
|
|
|
||
|
|
=cut
|
||
|
|
|
||
|
|
sub cannot_conflict { return $_[0]->{cannot_conflict}; }
|
||
|
|
|
||
|
|
1;
|