diff options
| -rw-r--r-- | MDK/Common.pm | 19 | ||||
| -rw-r--r-- | MDK/Common/DataStructure.pm | 9 | ||||
| -rw-r--r-- | MDK/Common/Func.pm | 18 | ||||
| -rw-r--r-- | MDK/Common/Globals.pm | 61 | ||||
| -rw-r--r-- | MDK/Common/System.pm | 4 | ||||
| -rw-r--r-- | MDK/Common/Various.pm | 4 | ||||
| -rw-r--r-- | Makefile | 7 | ||||
| -rw-r--r-- | perl-MDK-Common.spec | 6 | ||||
| -rwxr-xr-x | perl_checker | 68 |
9 files changed, 157 insertions, 39 deletions
diff --git a/MDK/Common.pm b/MDK/Common.pm index 4cccc21..dbc161c 100644 --- a/MDK/Common.pm +++ b/MDK/Common.pm @@ -1,12 +1,17 @@ package MDK::Common; -use MDK::Common::DataStructure ':all'; -use MDK::Common::File ':all'; -use MDK::Common::Func ':all'; -use MDK::Common::Math ':all'; -use MDK::Common::String ':all'; -use MDK::Common::System ':all'; -use MDK::Common::Various ':all'; +use MDK::Common::DataStructure qw(:all); +use MDK::Common::File qw(:all); +use MDK::Common::Func qw(:all); +use MDK::Common::Math qw(:all); +use MDK::Common::String qw(:all); +use MDK::Common::System qw(:all); +use MDK::Common::Various qw(:all); + +use vars qw(@ISA @EXPORT $VERSION); #); +@ISA = qw(Exporter); +# perl_checker: RE-EXPORT-ALL +@EXPORT = map { @$_ } map { values %{'MDK::Common::' . $_ . 'EXPORT_TAGS'} } grep { /::$/ } keys %MDK::Common::; $VERSION = "1.0"; diff --git a/MDK/Common/DataStructure.pm b/MDK/Common/DataStructure.pm index 8619e03..afc4ae1 100644 --- a/MDK/Common/DataStructure.pm +++ b/MDK/Common/DataStructure.pm @@ -1,6 +1,7 @@ package MDK::Common::DataStructure; use MDK::Common::Math; +use MDK::Common::Func; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK); @@ -35,8 +36,12 @@ sub next_val_in_array { sub list2kv { - [ grep_index { MDK::Common::Math::even($::i) } @_ ], - [ grep_index { MDK::Common::Math::odd($::i) } @_ ]; + my (@k, @v); + for (my $i = 0; $i < @_; $i += 2) { + push @k, $_[$i + 0]; + push @v, $_[$i + 1]; + } + \@k, \@v; } 1; diff --git a/MDK/Common/Func.pm b/MDK/Common/Func.pm index 55277c9..1b30a7e 100644 --- a/MDK/Common/Func.pm +++ b/MDK/Common/Func.pm @@ -5,10 +5,26 @@ use MDK::Common::Math; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK); @ISA = qw(Exporter); -@EXPORT_OK = qw(fold_left mapn mapn_ map_index grep_index find_index map_each grep_each before_leaving catch_cdie cdie); +@EXPORT_OK = qw(may_apply if_ if__ fold_left mapn mapn_ map_index grep_index find_index map_each grep_each before_leaving catch_cdie cdie); %EXPORT_TAGS = (all => [ @EXPORT_OK ]); +sub may_apply { $_[0] ? $_[0]->($_[1]) : (@_ > 2 ? $_[2] : $_[1]) } + +# prototype is needed for things like: if_(/foo/, bar => 'boo') +sub if_($@) { + my $b = shift; + $b or return (); + wantarray || @_ <= 1 or die("if_ called in scalar context with more than one argument " . join(":", caller())); + wantarray ? @_ : $_[0]; +} +sub if__($@) { + my $b = shift; + defined $b or return (); + wantarray || @_ <= 1 or die("if_ called in scalar context with more than one argument " . join(":", caller())); + wantarray ? @_ : $_[0]; +} + sub fold_left(&@) { my ($f, $initial, @l) = @_; local ($::a, $::b); diff --git a/MDK/Common/Globals.pm b/MDK/Common/Globals.pm new file mode 100644 index 0000000..32a4fc1 --- /dev/null +++ b/MDK/Common/Globals.pm @@ -0,0 +1,61 @@ +=head1 NAME + +Shares constant values between modules + +=head1 SYNOPSIS + +use MDK::Common::Globals "foo", qw($a $b); + +MDK::Common::Globals::init(a => 2, b => 3); + +print $a; # 2 + +=cut + + +package MDK::Common::Globals; + +sub import { + my (undef, $name, @globals) = @_; + foreach (@globals) { + $name =~ /^\$/ and die q(usage : use MDK::Common::Globals "group", qw($var1 $var2 ...);); + s/^\$// or die qq(bad parameter to "use MDK::Common::Globals": missing variable ``$_'' should be written ``\$$_''); #); + + no strict 'refs'; + my $v = caller() . '::' . $_; + my $lv = "$foo __ $_"; + *$v = *$lv; + eval { undef = $$lv; tie $$lv, 'MDK::Common::Globals', $_ }; + } +} + +sub init { + @_ % 2 == 0 or die "usage MDK::Common::Globals::init(key => val, key2 => val2, ...)\n"; + my %l = @_; + foreach (keys %l) { + my $v = caller() . '::' . $_; + no strict 'refs'; + $$v = $l{$_}; + } +} + +sub TIESCALAR { + my ($class, $name) = @_; + my $var; + bless [$var, undef, $name], $class; +} + +sub STORE { + my ($o, $val) = @_; + $o->[1] and die "MDK::Common::Globals::$o->[2] already set\n"; + $o->[1] = 1; + $o->[0] = $val; +} + +sub FETCH { + my ($o) = @_; + $o->[1] or die "MDK::Common::Globals::$o->[2] unset\n"; + $o->[0]; +} + +1; diff --git a/MDK/Common/System.pm b/MDK/Common/System.pm index c8c4535..d383a1f 100644 --- a/MDK/Common/System.pm +++ b/MDK/Common/System.pm @@ -6,7 +6,7 @@ use MDK::Common::File; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK %compat_arch $printable_chars $sizeof_int $bitof_int); #); @ISA = qw(Exporter); -@EXPORT_OK = qw(%compat_arch $printable_chars $sizeof_int $bitof_int typeFromMagic list_passwd list_home list_skels syscall_ df sync psizeof availableMemory availableRamMB gettimeofday unix2dos getVarsFromSh setVarsInSh setVarsInShMode setVarsInCsh template2file template2userfile update_userkderc); #); +@EXPORT_OK = qw(%compat_arch $printable_chars $sizeof_int $bitof_int typeFromMagic list_passwd list_home list_skels syscall_ psizeof availableMemory availableRamMB gettimeofday unix2dos getVarsFromSh setVarsInSh setVarsInShMode setVarsInCsh template2file template2userfile update_userkderc); #); %EXPORT_TAGS = (all => [ @EXPORT_OK ]); @@ -74,7 +74,7 @@ sub syscall_ { my $f = shift; require 'syscall.ph'; - syscall(&{$common::{"SYS_$f"}}, @_) == 0; + syscall(&{"SYS_$f"}, @_) == 0; } diff --git a/MDK/Common/Various.pm b/MDK/Common/Various.pm index b012343..93fbb80 100644 --- a/MDK/Common/Various.pm +++ b/MDK/Common/Various.pm @@ -2,7 +2,7 @@ package MDK::Common::Various; use vars qw(@ISA %EXPORT_TAGS @EXPORT_OK); @ISA = qw(Exporter); -@EXPORT_OK = qw(first second top bool to_int to_float bool2text bool2yesno text2bool chomp_ backtrace); +@EXPORT_OK = qw(first second top to_bool to_int to_float bool2text bool2yesno text2bool chomp_ backtrace); %EXPORT_TAGS = (all => [ @EXPORT_OK ]); @@ -10,7 +10,7 @@ sub first { $_[0] } sub second { $_[1] } sub top { $_[-1] } -sub bool { $_[0] ? 1 : 0 } +sub to_bool { $_[0] ? 1 : 0 } sub to_int { $_[0] =~ /(\d*)/; $1 } sub to_float { $_[0] =~ /(\d*(\.\d*)?)/; $1 } sub bool2text { $_[0] ? "true" : "false" } @@ -12,9 +12,10 @@ clean: find -name "*~" | xargs rm -rf install: clean test - install -d $(BINDIR) $(INSTALLSITEARCH) + install -d $(BINDIR) $(INSTALLSITEARCH)/MDK/Common install perl_checker $(BINDIR) - cp -r MDK $(INSTALLSITEARCH) + install -m 644 MDK/Common.pm $(INSTALLSITEARCH)/MDK + install -m 644 MDK/Common/*.pm $(INSTALLSITEARCH)/MDK/Common rpm: update tar build commit @@ -31,5 +32,5 @@ tar: clean build: cp -f ../$(TAR) $(RPM)/SOURCES perl -MMDK::Common -pe 's/THEVERSION/$$MDK::Common::VERSION/' $(NAME).spec > $(RPM)/SPECS/$(NAME).spec - -rpm -ba $(NAME).spec + -rpm -ba $(RPM)/SPECS/$(NAME).spec rm -f ../$(TAR) diff --git a/perl-MDK-Common.spec b/perl-MDK-Common.spec index 6f61129..5b2e6c6 100644 --- a/perl-MDK-Common.spec +++ b/perl-MDK-Common.spec @@ -1,4 +1,6 @@ -# do not change here, change in MDK/Common.pm +# MODIFY IN THE CVS: cvs.mandrakesoft.com:/cooker soft/perl-MDK-Common + +# do not change the version here, change in MDK/Common.pm %define version THEVERSION %define release 0.1mdk %define perl_sitelib %(eval "`perl -V:installsitelib`"; echo $installsitelib) @@ -11,6 +13,7 @@ Source0: %{name}.tar.bz2 License: GPL Group: Development/Perl BuildRoot: %{_tmppath}/%{name}-buildroot +Requires: /usr/bin/perl %description Various simple functions created for DrakX @@ -34,6 +37,7 @@ rm -rf $RPM_BUILD_ROOT %{_bindir}/* %{perl_sitelib}/MDK +# MODIFY IN THE CVS: cvs.mandrakesoft.com:/cooker soft/perl-MDK-Common %changelog * Tue Jul 24 2001 Pixel <pixel@mandrakesoft.com> 1.0-0.1mdk - first version diff --git a/perl_checker b/perl_checker index 822726b..ce3980d 100755 --- a/perl_checker +++ b/perl_checker @@ -1,26 +1,38 @@ #!/usr/bin/perl -n BEGIN { + while ($ARGV[0] =~ /-I(.*)/) { + unshift @INC, $1; + shift; + } + $NO_CW = $ARGV[0] eq "-no_cw" and shift; $USES = $ARGV[0] eq "-uses" and shift; @exclude_calls = qw(chomp chop chr crypt hex index lc lcfirst length oct ord pack reverse rindex sprintf substr uc ucfirst pos quotemeta split study abs atan2 cos exp hex int log oct rand sin sqrt srand pop push shift splice unshift grep join map reverse sort unpack delete each exists keys values binmode close closedir dbmclose dbmopen die eof fileno flock format getc print printf read readdir rewinddir seek seekdir select syscall sysread sysseek syswrite tell telldir truncate warn write pack read syscall sysread syswrite unpack vec chdir chmod chown chroot fcntl glob ioctl link lstat mkdir open opendir readlink rename rmdir stat symlink umask unlink utime caller continue die do dump eval exit goto last next redo return sub wantarray caller import local my package use defined dump eval formline local my reset scalar undef wantarray alarm exec fork getpgrp getppid getpriority kill pipe setpgrp setpriority sleep system times wait waitpid do import no package require use bless dbmclose dbmopen package ref tie tied untie use accept bind connect getpeername getsockname getsockopt listen recv send setsockopt shutdown socket socketpair msgctl msgget msgrcv msgsnd semctl semget semop shmctl shmget shmread shmwrite endgrent endhostent endnetent endpwent getgrent getgrgid getgrnam getlogin getpwent getpwnam getpwuid setgrent setpwent endprotoent endservent gethostbyaddr gethostbyname gethostent getnetbyaddr getnetbyname getnetent getprotobyname getprotobynumber getprotoent getservbyname getservbyport getservent sethostent setnetent setprotoent setservent gmtime localtime time times abs bless chomp chr exists formline glob import lc lcfirst map my no prototype qx qw readline readpipe ref sysopen tie tied uc ucfirst untie use qq Dumper packdrake Eth); @exclude_calls{@exclude_calls} = undef; - @exclude_uses = qw(globals diagnostics strict vars lib Config Socket Locale::GetText CORE POSIX Gtk Data::Dumper Net::FTP Gtk::XmHTML Gtk::Gdk Gtk::Gdk::ImlibImage Newt Newt::Component Newt::Grid DynaLoader IO::Socket packdrake); + @exclude_uses = qw(globals diagnostics strict vars lib Carp Config Exporter Socket Locale::GetText CORE POSIX Gtk Data::Dumper Net::FTP Gtk::XmHTML Gtk::Gdk Gtk::Gdk::ImlibImage Newt Newt::Component Newt::Grid DynaLoader IO::Socket packdrake); while ($ARGV[0] =~ /-exclude(.*)/) { push @exclude_uses, $1; shift; } @exclude_uses{@exclude_uses} = undef; - foreach (@ARGV) { - system("perl", "-cw", $_); - $? == 0 or die "perl -cw $_ failed\n"; + if (!$NO_CW) { + foreach (@ARGV) { + system("perl", "-cw", $_); + $? == 0 or die "perl -cw $_ failed\n"; + } } $package = 'main'; } chop; + +if (/^# perl_checker: RE-EXPORT-ALL/) { + push @re_exported, $package; +} + /^\s*#/ and next; if (/^\s*require\s+([\w:]+);/) { @@ -38,7 +50,6 @@ s/\bm\b(.)(.*?)\1//g; # m// operator s|\(/.*?/|(|g; # m// operator s{([!=]~|\bif\b)\s*/.*?/}{}g; - s/#.*//; if (/^\s*package ([\w:]+)/) { @@ -49,10 +60,15 @@ if (/^\s*package ([\w:]+)/) { if (/\@EXPORT = qw\((.*)\)/) { @{$export{$package}}{split ' ', $1} = undef; - #$export_info{$package} = info(); } - -if (/%EXPORT_TAGS = \(/ .. /^\);$/) { +if (/\@EXPORT_OK = qw\((.*)\)/) { + @{$export_ok{$package}}{split ' ', $1} = undef; + $export_info{$package} = info(); +} +if (/%EXPORT_TAGS = \((\w+) => \[ \@EXPORT_OK \]\)/) { + $export_tags{$package}->{$1} = $export_ok{$package}; +} +if (/%EXPORT_TAGS = \(\s*$/ .. /^\);$/) { /\s+(\w+)\s+.*?qw\((.*)\)/; @{$export_tags{$package}->{$1}}{split ' ', $2} = undef; $export_tags_info{$package}->{$1} = info(); @@ -74,7 +90,7 @@ while (/&([\w:]+)/g) { add_call($1); } #} /^use\s+([\w:]+);/ and add_use($1); -if (my ($p, $v) = /^use\s(\w+)\s+(.*)/) { +if (my ($p, $v) = /^use\s([\w:]+)\s+(.*)/) { $v =~ /^qw\((.*?)\)/ ? add_use($p, $1) : err("<<$_>> should be written <<use $p qw(:A :B ...)>>", info()) if !exists $exclude_uses{$p}; } @@ -83,10 +99,10 @@ if (my ($p, $v) = /^\s*(\S+)->import\((.*)\)/) { } /^\s*sub\s+(\w+)/ and $sub{$package}->{$1} = 1; - -$. = 0 if eof; -$package = 'main' if eof; - +if (eof) { + $. = 0; +# $package = "_ano_$ARGV[0]"; +} sub add_call { $_[0] =~ /^\d/ and return; @@ -111,13 +127,17 @@ sub add_use { my ($path, $f) = "$p.pm" =~ /(.*::)?(.*)/; $path =~ s|::|/|g; - $path{$p} = updirs($path{$package}, (($package =~ tr/://) / 2)) . $path || "./"; - if (-e "$path{$p}$f") { - push @ARGV, "$path{$p}$f"; -# err("added package $p", info()); - } else { - err("can't find package $p", info()); + $path{$p} = updirs($path{$package}, (($package =~ tr/://) / 2)); + foreach ($path{$p}, @INC) { + $_ .= "/" if !m|/$|; + my $file = "$_$path$f"; + if (-e $file) { + push @ARGV, $file; + $file2package{$file} = $p; + return; + } } + err("can't find package $p", info()); } #sub add_usevar { @@ -151,13 +171,19 @@ sub warn_ { } END { - $export_tags{common}->{common}->{'_'} = 1; # hack!!! + foreach my $package (reverse @re_exported) { + my $h = $export{$package} ||= {}; + foreach (keys %{$use{$package}}) { + %$h = (%$h, %{$export{$_}}, map { %$_ } values %{$export_tags{$_}}); + } + } + while (my ($package, $v) = each %use) { while (my ($k, $s) = each %$v) { @$s and defined($export_tags{$k}) || err("package $k does not export tags"); foreach (@$s) { s/\"//g; - s/^:// or err("<<use $k qw($s ...)>> should be <<use $k qw(:$s ...)>>", $use_info{$package}->{$k}); + s/^:// or err("<<use $k qw(@$s ...)>> should be <<use $k qw(:@$s ...)>>", $use_info{$package}->{$k}); exists $export_tags{$k}->{$_} or err("package $k does not export tag $_", $use_info{$package}->{$k}); } |