a@^n}\??????????????{?d?R?Q?A?>>>>>>k>[>Y>O>O>C>B>+>*>>>==========i=h=R=Q=;=:=/=/=%=$====<<<<<<<<new(-List => 'listshortname'); my $list_info = $ls->get(); $ls->save({key => 'value'}); =head1 DESCRIPTION This module holds the DB File backend for list settings. =head1 Public Methods =cut use strict; use lib qw(./ ../ ../../ ../../../ ./../../DADA ../../perllib); use AnyDBM_File; use Fcntl qw( O_WRONLY O_TRUNC O_CREAT O_CREAT O_RDWR O_RDONLY LOCK_EX LOCK_SH LOCK_NB); use Carp; use DADA::Config; use DADA::App::Guts; # For now, my dear. =cut =pod =head2 new returns the DADA::Mailinglist::Settings object. my $ls = DADA::MailingList::Settings->new(-List => 'listshortname'); you can also optionally pass the B<-new_list => 1> parameter to circumvent list checks. =cut sub new { my $class = shift; my %args = (-List => undef, -new_list => 0, @_); my $self = SUPER::new $class ( function => 'settings', ); $self->{new_list} = $args{-new_list}; $self->_init(\%args); return $self; } =cut =pod =head2 get my $list_info = $ls->get(); returns a hasref of the list settings. Keys are the name of the setting, value is the value of the setting. You can optionally pass the B 1> paramter to change pseudo tags in html and email messages to their value. =cut sub get { my $self = shift; my %args = (-Format => "raw", @_); $self->_raw_db_hash; my $ls = $self->{RAW_DB_HASH}; warn "$PROGRAM_NAME $VER warning! List " . $self->{function} . " db empty! List setting DB Possibly corrupted!" unless keys %$ls; warn "$PROGRAM_NAME $VER warning! no listshortname saved in list " . $self->{function} . " db! List " . $self->{function} . " DB Possibly corrupted!" if ! $ls->{list}; warn "listshortname in db, '" . $self->{name} . "' does not match saved list shortname: '" . $ls->{list} . "'" if $self->{name} ne $ls->{list}; if($args{-Format} ne 'unmunged'){ $ls = $self->_munge_for_Config_Vars($ls); $ls->{charset_value} = $self->_munge_charset( $ls); $ls = $self->_munge_for_deprecated($ls); %$ls = (%LIST_SETUP_DEFAULTS, %$ls); %$ls = (%$ls, %LIST_SETUP_OVERRIDES); $ls = $self->_format_settings($ls) if $args{-Format} eq "replaced"; } return $ls; } =cut =pod =head2 save $ls->save({settingkey => 'settingvalue'}); saves a setting. Notice that this method takes a hashref, and nothing else. =cut sub save { my ($self, $new_settings) = @_; if($new_settings){ $self->_open_db; my %RAW_DB_HASH = %{$self->{DB_HASH}}; my %merge_info = (%RAW_DB_HASH, %$new_settings); %{$self->{DB_HASH}} = %merge_info; if($self->{DB_HASH}->{list}){ unless(defined($self->{DB_HASH}->{admin_menu})){ require DADA::Template::Widgets::Admin_Menu; $self->{DB_HASH}->{admin_menu} = DADA::Template::Widgets::Admin_Menu::create_save_set(); } unless(defined($self->{DB_HASH}->{cipher_key})){ require DADA::Security::Password; $self->{DB_HASH}->{cipher_key} = DADA::Security::Password::make_cipher_key(); } }else{ warn "$PROGRAM_NAME $VER warning! listshortname isn't defined! list " . $self->{function} . " db possibly corrupted!" unless $self->{new_list}; } $self->_close_db; $self->backupToDir; return 1; } return 1; } sub perhapsCorrupted { my $self = shift; $self->_open_db; my %RAW_DB_HASH = %{$self->{DB_HASH}}; $self->_close_db; $RAW_DB_HASH{list} ? return 1 : return 0; } sub _init { my ($self, $args) = @_; if($self->{new_list} != 1){ croak('BAD List name "' . $args->{-List} . '" ' . $!) if $self->_list_name_check($args->{-List}) == 0; }else{ $self->{name} = $args->{-List}; } } sub _list_name_check { my ($self, $n) = @_; $n = $self->_trim($n); return 0 if !$n; return 0 if $self->_list_exists($n) == 0; $self->{name} = $n; return 1; } sub _list_exists { my ($self, $n) = @_; return DADA::App::Guts::check_if_list_exists(-List => $n); } sub _trim { my ($self, $s) = @_; return DADA::App::Guts::strip($s); } sub _open_db { my $self = shift; my $exception = 0; chmod($FILE_CHMOD, $self->_db_filename) if -e $self->_db_filename; tie %{$self->{DB_HASH}}, "AnyDBM_File", $self->_db_filename, O_RDWR|O_CREAT, $FILE_CHMOD or $exception = 1; if($exception == 1){ if($self->{ignore_open_db_error} == 1){ warn "$PROGRAM_NAME $VER warning! " . 'couldn\'t tie '. $self->_db_filename . ' for reading: ' . $! . "Ignoring fatal error assuming you're (hopefully) resolving the issue by visiting: " . $PROGRAM_URL . '?f=restore_lists '; $self->{DB_HASH} = {}; }else{ die 'couldn\'t tie '. $self->_db_filename . ' for reading: ' . $! . '; If your server recently upgraded software or moved your lists to a different server, you may need to restore your list ' . $self->{function} . '. Visit ' . $PROGRAM_URL . '?f=restore_lists '; } } } sub _raw_db_hash { my $self = shift; $self->_lock_db; $self->_open_db; my %RAW_DB_HASH = %{$self->{DB_HASH}}; $self->{RAW_DB_HASH} = {%RAW_DB_HASH}; $self->_close_db; $self->_unlock_db; } sub _db_filename { my $self = shift; my $fn = $self->{name}; $fn =~ s/ /_/g; $fn = $FILES . '/mj-' . $self->{name}; #untaint $fn = $self->_safe_path($fn); $fn =~ /(.*)/; $fn = $1; return $fn; } sub _close_db { my $self = shift; untie %{$self->{DB_HASH}}; } sub _format_settings { # I don't like this at all. my ($self, $ls) = @_; for($ls->{subscribed_message}, $ls->{unsubscribed_message}, $ls->{confirmation_message}, $ls->{mailing_list_message}, $ls->{not_allowed_to_post_message}, $ls->{html_confirmation_message}, $ls->{html_unsub_confirmation_message}, $ls->{html_subscribed_message}, $ls->{html_unsubscribed_message}, $ls->{unsub_confirmation_message} ){ $_ =~ s/\[list_name\]/$ls->{list_name}/g; $_ =~ s/\[list_info\]/$ls->{info}/g; $_ =~ s/\[list_owner_email\]/$ls->{list_owner_email}/g; $_ =~ s/\[list_admin_email\]/$ls->{admin_email}/g; $_ =~ s/\[privacy_policy\]/$ls->{privacy_policy}/g; $_ =~ s/\[list_privacy_policy\]/$ls->{privacy_policy}/g; $_ =~ s/\[physical_address\]/$ls->{physical_address}/g; $_ =~ s/\[program_url\]/$PROGRAM_URL/g; } return $ls; } sub _munge_for_Config_Vars { my ($self, $li) = @_; $li->{subscribed_message} ||= $SUBSCRIBED_MESSAGE; $li->{unsubscribed_message} ||= $UNSUBSCRIBED_MESSAGE; $li->{confirmation_message} ||= $CONFIRMATION_MESSAGE; $li->{unsub_confirmation_message} ||= $UNSUB_CONFIRMATION_MESSAGE; $li->{mailing_list_message} ||= $MAILlING_LIST_MESSAGE; $li->{mailing_list_message_html} ||= $MAILlING_LIST_MESSAGE_HTML; $li->{not_allowed_to_post_message} ||= $NOT_ALLOWED_TO_POST_MESSAGE; $li->{html_confirmation_message} ||= $HTML_CONFIRMATION_MESSAGE; $li->{html_unsub_confirmation_message} ||= $HTML_UNSUB_CONFIRMATION_MESSAGE; $li->{html_subscribed_message} ||= $HTML_SUBSCRIBED_MESSAGE; $li->{html_unsubscribed_message} ||= $HTML_UNSUBSCRIBED_MESSAGE; $li->{send_archive_message} ||= $SEND_ARCHIVED_MESSAGE; $li->{send_archive_message_html} ||= $HTML_SEND_ARCHIVED_MESSAGE; $li->{invite_message_text} ||= $TEXT_INVITE_MESSAGE; $li->{invite_message_html} ||= $HTML_INVITE_MESSAGE; # i guess this is here because it goes well with the above 2 $li->{invite_message_subject} ||= $li->{list_name} . ' Invitation'; return $li; } sub _munge_charset { my ($self, $li) = @_; my $charset_info = $li->{charset}; my @labeled_charsets = split(/\s/, $charset_info); return $labeled_charsets[$#labeled_charsets]; } sub _munge_for_deprecated { my ($self, $li) = @_; $li->{list_owner_email} ||= $li->{mojo_email}; $li->{admin_email} ||= $li->{list_owner_email}; $li->{privacy_policy} ||= $li->{private_policy}; #we're talkin' way back here.. if(!exists($li->{list_name})){ $li->{list_name} = $li->{list}; $li->{list_name} =~ s/_/ /g; } return $li; } sub _lock_db { my $self = shift; sysopen(DB_SAFETYLOCK, $self->_lockfile_name, O_RDWR|O_CREAT, $FILE_CHMOD) or die "$PROGRAM_NAME $VER Error - Cannot open list lock file " . $self->_lockfile_name . " - $!"; { my $sleep_count = 0; { flock DB_SAFETYLOCK, LOCK_EX | LOCK_NB and last; sleep 1; redo if ++$sleep_count < 11; die "$PROGRAM_NAME $VER Warning: Server is way too busy to open list db file," . $self->_lockfile_name . " - $!\n"; } } } sub _unlock_db { my $self = shift; close(DB_SAFETYLOCK); if(-e $self->_lockfile_name){ unlink($self->_lockfile_name) or warn "couldn't delete lock file: '$TMP/".$self->{name}."_" . $self->{function} . "db.lock' - $!"; }else{ warn 'weird, couldn\'t find ' . $self->_lockfile_name . ' to remove...?'; } } sub _lockfile_name { my $self = shift; my $fn = $self->_safe_path("$TMP/".$self->{name}."_" . $self->{function} . "db.lock"); $fn =~ /(.*)/; $fn = $1; return $fn; } =cut =pod =head1 See Also DADA::MailingList::Settings =back =head1 COPYRIGHT Copyright (c) 1999 - 2004 Justin Simoni me@justinsimoni.com http://justinsimoni.com All rights reserved. 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. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. =cut 1;subject to C. =item * I "&", "^", "|", "neg", "!", "~", C stands for unary minus. If the method for C is not specified, it can be autogenerated using the method for subtraction. If the method for C is not specified, it can be autogenerated using the methods for C, or C<"">, or C<0+>. =item * I "++", "--", If undefined, addition and subtraction methods can be used instead. These operations are called both in prefix and postfix form. =item * I "atan2", "cos", "sin", "exp", "abs", "log", "sqrt", "int" If C is unavailable, it can be autogenerated using methods for "E" or "E=E" combined with either unary minus or subtraction. Note that traditionally the Perl function L rounds to 0, thus for floating-point-like types one should follow the same semantic. If C is unavailable, it can be autogenerated using the overloading of C<0+>. =item * I 'bool', '""', '0+', If one or two of these operations are not overloaded, the remaining ones can be used instead. C is used in the flow control operators (like C) and for the ternary C operation. These functions can return any arbitrary Perl value. If the corresponding operation for this value is overloaded too, that operation will be called again with this value. As a special case if the overload returns the object itself then it will be used directly. An overloaded conversion returning the object is probably a bug, because you're likely to get something that looks like C. =item * I "<>" If not overloaded, the argument will be converted to a filehandle or glob (which may require a stringification). The same overloading happens both for the I syntax C$varE> and I syntax C${var}E>. B Even in list context, the iterator is currently called only once and with scalar context. =item * I '${}', '@{}', '%{}', '&{}', '*{}'. If not overloaded, the argument will be dereferenced I, thus should be of correct type. These functions should return a reference of correct type, or another object with overloaded dereferencing. As a special case if the overload returns the object itself then it will be used directly (provided it is the correct type). The dereference operators must be specified explicitly they will not be passed to "nomethod". =item * I "nomethod", "fallback", "=", see L>. =back See L<"Fallback"> for an explanation of when a missing method can be autogenerated. A computer-readable form of the above table is available in the hash %overload::ops, with values being space-separated lists of names: with_assign => '+ - * / % ** << >> x .', assign => '+= -= *= /= %= **= <<= >>= x= .=', num_comparison => '< <= > >= == !=', '3way_comparison'=> '<=> cmp', str_comparison => 'lt le gt ge eq ne', binary => '& | ^', unary => 'neg ! ~', mutators => '++ --', func => 'atan2 cos sin exp abs log sqrt', conversion => 'bool "" 0+', iterators => '<>', dereferencing => '${} @{} %{} &{} *{}', special => 'nomethod fallback =' =head2 Inheritance and overloading Inheritance interacts with overloading in two ways. =over =item Strings as values of C directive If C in use overload key => value; is a string, it is interpreted as a method name. =item Overloading of an operation is inherited by derived classes Any class derived from an overloaded class is also overloaded. The set of overloaded methods is the union of overloaded methods of all the ancestors. If some method is overloaded in several ancestor, then which description will be used is decided by the usual inheritance rules: If C inherits from C and C (in this order), C overloads C<+> with C<\&D::plus_sub>, and C overloads C<+> by C<"plus_meth">, then the subroutine C will be called to implement operation C<+> for an object in package C. =back Note that since the value of the C key is not a subroutine, its inheritance is not governed by the above rules. In the current implementation, the value of C in the first overloaded ancestor is used, but this is accidental and subject to change. =head1 SPECIAL SYMBOLS FOR C Three keys are recognized by Perl that are not covered by the above description. =head2 Last Resort C<"nomethod"> should be followed by a reference to a function of four parameters. If defined, it is called when the overloading mechanism cannot find a method for some operation. The first three arguments of this function coincide with the arguments for the correspon1use_alt_url_sub_successurl_templatetext/plaincontent_type0send_via_smtp0allow_group_interpolation1use_pop_before_smtp0use_alt_url_unsub_confirm_success1publish_archives_rss0print_return_path_headeralt_url_unsub_confirm_successtimjschroeder@hotmail.comadmin_email1archive_search_form0black_listsmtp_server0use_subscription_quota1send_sub_success_email0use_alt_url_unsub_confirm_failedSpam-Blockers.com Newsletterlist_name0archive_send_formalt_url_unsub_confirm_failed3prioritydada_subscriberssubscription_tablefrom_template_fileget_template_data1bulk_send_seconds_label1add_reply_toprecedence10bulk_send_amountSpam-Blockers.com Mailing Listinfohttp://www.spam-blockers.com/mailing-list-confirmed.htmlalt_url_sub_success0use_alt_url_sub_failedsasl_smtp_password0mx_check1get_sub_notice1hard_remove25smtp_port0show_hiddenphysical_address0subscription_quotaEnglish (en) iso-8859-1charsetalt_url_sub_failed1archive_subscribe_formspamblockerslist1archive_show_year0group_listmerge_fields1append_list_name_to_subject`??????????z?E?8?4?+?*???>>>>>W>B>A>6>5>(>'> > >==========y=x=_=^=F=E=+=+=====<<<<<<<_trim($n); return 0 if !$n; return 0 if $self->_list_exists($n) == 0; $self->{name} = $n; return 1; } sub _list_exists { my ($self, $n) = @_; return DADA::App::Guts::check_if_list_exists(-List => $n); } sub _trim { my ($self, $s) = @_; return DADA::App::Guts::strip($s); } sub _safe_path { my ($self, $p) = @_; $p =~ tr/\0-\037\177-\377//d; # remove unprintables $p =~ s/(['\\])/\$1/g; # escape quote, backslash $p =~ /(.*)/; return $1; } sub _open_db { my $self = shift; my $exception = 0; $self->_lock_db; chmod($FILE_CHMOD, $self->_db_filename) if -e $self->_db_filename; tie %{$self->{DB_HASH}}, "AnyDBM_File", $self->_db_filename, O_RDWR|O_CREAT, $FILE_CHMOD or $exception = 1; if($exception == 1){ if($self->{ignore_open_db_error} == 1){ warn "$PROGRAM_NAME $VER warning! " . 'couldn\'t tie '. $self->_db_filename . ' for reading: ' . $! . "Ignoring fatal error assuming you're (hopefully) resolving the issue by visiting: " . $PROGRAM_URL . '?f=restore_lists '; $self->{DB_HASH} = {}; }else{ die 'couldn\'t tie '. $self->_db_filename . ' for reading: ' . $! . '; If your server recently upgraded software or moved your lists to a different server, you may need to restore your list ' . $self->{function} . '. Visit ' . $PROGRAM_URL . '?f=restore_lists '; } } } sub _raw_db_hash { my $self = shift; my $as_ref = shift; $self->_open_db; my %RAW_DB_HASH = %{$self->{DB_HASH}}; $self->{RAW_DB_HASH} = {%RAW_DB_HASH}; $self->_close_db; $as_ref == 1 ? return \%RAW_DB_HASH : return %RAW_DB_HASH; } sub _db_filename { my $self = shift; my $fn = $self->{name}; $fn =~ s/ /_/g; my $dir = $FILES; $dir = $ARCHIVES if $self->{function} eq "archives"; $fn = $dir . '/mj-' . $self->{name}; $fn .= '-archive' if $self->{function} eq "archives"; # This isn't good, since this module # has to know about the module that # inherits it. #untaint $fn = $self->_safe_path($fn); return $fn; } sub _close_db { my $self = shift; untie %{$self->{DB_HASH}} or warn "untie didn't work: $!"; delete $self->{DB_HASH}; $self->_lock_db; } sub _lock_db { my $self = shift; sysopen(DB_SAFETYLOCK, $self->_lockfile_name, O_RDWR|O_CREAT, $FILE_CHMOD) or die "$PROGRAM_NAME $VER Error - Cannot open list lock file " . $self->_lockfile_name . " - $!"; chmod($FILE_CHMOD, $self->_lockfile_name); { my $sleep_count = 0; { flock DB_SAFETYLOCK, LOCK_EX | LOCK_NB and last; sleep 1; redo if ++$sleep_count < 11; die "$PROGRAM_NAME $VER Warning: Server is way too busy to open list db file," . $self->_lockfile_name . " - $!\n"; } } } sub _unlock_db { my $self = shift; close(DB_SAFETYLOCK); unlink($self->_lockfile_name) or warn "couldn't delete lock file: '" . $self->_lockfile_name . "' - $!"; } sub _lockfile_name { my $self = shift; return $self->_safe_path("$TMP/".$self->{name}."_" . $self->{function} . "db.lock"); } 1; 'severe' => 42, 'debugging' => 44, 'inplace' => 46, 'internal' => 48, 'malloc' => 50, 'signal' => 52, 'substr' => 54, 'syntax' => 56, 'ambiguous' => 58, 'bareword' => 60, 'digit' => 62, 'parenthesis' => 64, 'precedence' => 66, 'printf' => 68, 'prototype' => 70, 'qw' => 72, 'reserved' => 74, 'semicolon' => 76, 'taint' => 78, 'threads' => 80, 'uninitialized' => 82, 'unpack' => 84, 'untie' => 86, 'utf8' => 88, 'void' => 90, 'y2k' => 92, ); our %Bits : unique = ( 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30] 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22] 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31] 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23] 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24] 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12] 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13] 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14] 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15] 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16] 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32] 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17] 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33] 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34] 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35] 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19] 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38] 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25] 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26] 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27] 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38] 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39] 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40] 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41] 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42] 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43] 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44] 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45] 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46] ); our %DeadBits : unique = ( 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46] 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29] 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30] 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22] 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31] 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23] 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24] 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11] 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25] 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12] 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13] 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14] 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15] 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16] 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32] 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17] 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33] 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34] 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35] 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36] 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18] 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19] 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20] 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37] 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38] 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25] 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26] 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27] 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38] 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39] 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40] 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41] 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42] 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43] 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44] 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45] 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46] ); $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0"; $LAST_BIT = 94 ; $BYTES = 12 ; $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; sub Croaker { delete $Carp::CarpInternal{'warnings'}; Carp::croak(@_); } sub bits { # called from B::Deparse.pm push @_, 'all' unless @_; my $mask; my $catmask ; my $fatal = 0 ; my $no_fatal = 0 ; foreach my $word ( @_ ) { if ($word eq 'FATAL') { $fatal = 1; $no_fatal = 0; } elsif ($word eq 'NONFATAL') { $fatal = 0; $no_fatal = 1; } elsif ($catmask = $Bits{$word}) { $mask |= $catmask ; $mask |= $DeadBits{$word} if $fatal ; $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else { Croaker("Unknown warnings category '$word'")} } return $mask ; } sub import { shift; my $catmask ; my $fatal = 0 ; my $no_fatal = 0 ; my $mask = ${^WARNING_BITS} ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } push @_, 'all' unless @_; foreach my $word ( @_ ) { if ($word eq 'FATAL') { $fatal = 1; $no_fatal = 0; } elsif ($word eq 'NONFATAL') { $fatal = 0; $no_fatal = 1; } elsif ($catmask = $Bits{$word}) { $mask |= $catmask ; $mask |= $DeadBits{$word} if $fatal ; $mask &= ~($DeadBits{$word}|$All) if $no_fatal ; } else { Croaker("Unknown warnings category '$word'")} } ${^WARNING_BITS} = $mask ; } sub unimport { shift; my $catmask ; my $mask = ${^WARNING_BITS} ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); } push @_, 'all' unless @_; foreach my $word ( @_ ) { if ($word eq 'FATAL') { next; } elsif ($catmask = $Bits{$word}) { $mask &= ~($catmask | $DeadBits{$word} | $All); } else { Croaker("Unknown warnings category '$word'")} } ${^WARNING_BITS} = $mask ; } sub __chk { my $category ; my $offset ; my $isobj = 0 ; if (@_) { # check the category supplied. $category = shift ; if (ref $category) { Croaker ("not an object") if $category !~ /^([^=]+)=/ ; $category = $1 ; $isobj = 1 ; } $offset = $Offsets{$category}; Croaker("Unknown warnings category '$category'") unless defined $offset; } else { $category = (caller(1))[0] ; $offset = $Offsets{$category}; Croaker("package '$category' not registered for warnings") unless defined $offset ; } my $this_pkg = (caller(1))[0] ; my $i = 2 ; my $pkg ; if ($isobj) { while (do { { package DB; $pkg = (caller($i++))[0] } } ) { last unless @DB::args && $DB::args[0] =~ /^$category=/ ; } $i -= 2 ; } else { for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { 1archive_show_month0only_allow_group_plain_text0use_habeas_headers1archive_messages1archive_show_day10bulk_send_seconds0unsub_confirm_email0set_smtp_sender10bulk_sleep_amount1send_unsub_success_email0get_unsub_noticeNF&HV3eN*fxE$HG6=dEDuk$4iJuh_4*md9?ZMiEVcipher_key0get_batch_notificationNAV-Send A List Message=1;SUBNAV-Send a Web Page=1;SUBNAV-Send a List Invitation=1;NAV-Manage List=1;SUBNAV-Change List Information=1;SUBNAV-Change Your Password=1;SUBNAV-Mailing List Options=1;SUBNAV-Sending Options=1;SUBNAV-Group Options=1;SUBNAV-Delete This List=0;NAV-Manage Subscribers=1;SUBNAV-View=1;SUBNAV-Add=1;SUBNAV-Remove=1;SUBNAV-Statistics=1;SUBNAV-Black List Rules=1;SUBNAV-Options=0;NAV-Manage List Archive=1;SUBNAV-View Archive=1;SUBNAV-Archive Options=1;NAV-Manage Copy=1;SUBNAV-E-mail Messages=1;SUBNAV-HTML Messages=1;SUBNAV-Create a Back Link=1;NAV-Manage Appearance=1;SUBNAV-Edit Template=1;SUBNAV-Subscription Form HTML=1;NAV-About Dada Mail=1;NAV-Logout=1;NAV-Sign Into Another List=1;NAV-Customize Feature Set=0;NAV-Plugins=1;admin_menu0use_alt_url_unsub_failed0add_sendmail_f_flag0use_alt_url_unsub_success0allow_blacklisted_to_subscribewebmaster@spam-blockers.comlist_owner_email8bitplaintext_encoding5smtp_connect_triesalt_url_unsub_success0strip_message_headersalt_url_sub_confirm_failed0add_unsubs_to_black_list1get_finished_notification0print_errors_to_header10archive_index_count1use_alt_url_sub_confirm_success0use_alt_url_sub_confirm_failed1enable_bulk_batching1no_confirm_email100view_list_subscriber_number1show_archives0closed_list0clickthrough_trackingYour email address will not be sold, the only way we utilize your email address is to send you periodic newsletters.privacy_policy1sort_archives_in_reverse0allow_admin_to_subscribe_blacklisted0use_sasl_smtp_auth0hide_list8bithtml_encodinghttp://www.spam-blockers.com/mailing-list-thanks.htmlalt_url_sub_confirm_success1print_list_headersalt_url_unsub_failed1mail_group_message_to_posterexQlcnBd2ma3wpasswordsasl_smtp_username