File Coverage

Glade/PerlSource.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Glade::PerlSource;
require 5.000; use strict 'vars', 'refs', 'subs';

# Copyright (c) 1999 Dermot Musgrove
#
# This library is released under the same conditions as Perl, that
# is, either of the following:
#
# a) the GNU General Public License as published by the Free
# Software Foundation; either version 1, or (at your option) any
# later version.
#
# b) the Artistic License.
#
# If you use this library in a commercial enterprise, you are invited,
# but not required, to pay what you feel is a reasonable fee to perl.org
# to ensure that useful software is available now and in the future.
#
# (visit http://www.perl.org/ or email [e-mail] for details)

BEGIN {
    use Data::Dumper;
    use File::Copy; # for copying generated files
    use Glade::PerlRun qw( :METHODS :VARS !&_);
                                            # Our run-time methods and vars
                                            # but not &_ since we do that ourselves.
    use File::Basename qw( basename );      # in check_gettext_strings
    use Text::Wrap     qw( wrap $columns ); # in write_gettext_strings
    use File::Path     qw( mkpath );        # in use_Glade_Project
    use subs        qw(
                        _
                        start_checking_gettext_strings
                    );
    use vars        qw(
                        @ISA
                        $PACKAGE $VERSION $AUTHOR $DATE
                        %fields %stubs
                        @EXPORT @EXPORT_OK %EXPORT_TAGS
                        @VARS @METHODS
                        $PARTYPE $LOOKUP $BOOL $DEFAULT $KEYSYM $LOOKUP_ARRAY

                        $widgets
                        $data
                        $forms
                        $work

                        $handlers
                        $need_handlers
                        $autosubs
                        $subs

                        $radiobuttons
                        $radiomenuitems
                        $current_data
                        $current_name
                        $current_form
                        $current_form_name
                        $current_window
                        $first_form
                        $init_string
                      );
    $PACKAGE      = __PACKAGE__;
    $VERSION      = q(0.61);
    $AUTHOR       = q(Dermot Musgrove );
    $DATE         = q(Sun Nov 17 03:21:11 GMT 2002);
    @VARS         = qw(
                        $PARTYPE $LOOKUP $BOOL $DEFAULT $KEYSYM $LOOKUP_ARRAY

                        $Glade_Perl
                        $widgets
                        $data
                        $forms
                        $work

                        $handlers
                        $need_handlers
                        $autosubs
                        $subs
                        $convert
                        @use_modules
                        $NOFILE
                        $indent
                        $tab

                        $radiobuttons
                        $radiomenuitems
                        $current_data
                        $current_name
                        $current_form
                        $current_form_name
                        $current_window
                        $first_form
                        $init_string
                    );
    @METHODS      = qw(
                        _
                        S_
                        D_
                        missing_handler
                    );
    $subs =             '';
    $autosubs =         ' destroy_Form about_Form '.
                        ' toplevel_hide toplevel_close toplevel_destroy ';
    $LOOKUP       = 2;
    $BOOL         = 4;
    $DEFAULT      = 8;
    $KEYSYM       = 16;
    $LOOKUP_ARRAY = 32;
    # Tell interpreter who we are inheriting from
    @ISA          = qw( Exporter Glade::PerlRun );
    # These symbols (globals and functions) are always exported
    @EXPORT       = qw(  );
    # Optionally exported package symbols (globals and functions)
    @EXPORT_OK    = ( @VARS, @METHODS );
    # Tags (groups of symbols) to export
    %EXPORT_TAGS  = (   'METHODS'   => [@METHODS],
                        'VARS'      => [@VARS]  );
}

%fields = (
# Insert any extra data access methods that you want to add to
#   our inherited super-constructor (or overload)
    USERDATA    => undef,
);

sub DESTROY {
    # This sub will be called on object destruction
} # End of sub DESTROY

#===============================================================================
#=========== Utilities to write output file                         ============
#===============================================================================
sub Stop_Writing_to_File { shift->Write_to_File('-1') }

sub Write_to_File {
    my ($class) = @_;
    my $me = __PACKAGE__."::Write_to_File";
    my $filename = $class->source->write;
    if (fileno UI or fileno SIGS or fileno SUBCLASS or
        $class->Building_UI_only) {
        # Files are already open or we are not writing source
        if ($class->Writing_to_File) {
            if ($filename eq '-1') {
                close UI;
                close SUBCLASS;
                close SIGS;
                $class->diag_print (2, "%s- Closing output file in %s",
                    $indent, $me);
                $class->source->write(undef);
            } else {
                $class->diag_print (2, "%s- Already writing to %s in %s",
                    $indent, $class->Writing_to_File, $me);
            }
        }

    } elsif ($filename && ($filename eq '1')) {
        $class->diag_print (3, "%s- Using default output files ".
            "in Glade  in %s",
            $indent, $me);

    } elsif ($filename && ($filename ne '-1') ) {
        # We want to write source
        if ($filename eq 'STDOUT') {
            $class->source->write('>&STDOUT');
        }
        $class->diag_print (2, "%s- Writing %s source to %s - in %s",
            $indent, 'UI  ', $filename, $me);
        open UI,     ">$filename" or
            die sprintf((
                "error %s - can't open file '%s' for output"),
                $me, $filename);
        $class->diag_print (2, "%s- Writing %s source to %s - in %s",
            $indent, 'SUBS', $filename, $me);
        open SIGS,     ">$filename" or
            die sprintf((
                "error %s - can't open file '%s' for output"),
                $me, $filename);
        $class->diag_print (2, "%s- Writing %s source to %s - in %s",
            $indent, 'SUBCLASS', $filename, $me);
        open SUBCLASS,     ">$filename" or
            die sprintf((
                "error %s - can't open file '%s' for output"),
                $me, $filename);
        UI->autoflush(1);
        SIGS->autoflush(1);
        SUBCLASS->autoflush(1);
    } else {
        # Nothing to do
    }
}

sub add_to_UI {
    my ($class, $depth, $expr, $tofileonly, $notabs) = @_;
    my $me = "$class->add_to_UI";
    my $mydebug = ($Glade_Perl->verbosity >= 6);
    if ($depth < 0) {
        $mydebug = 1;
        $depth = -$depth;
    }
    if ($Glade_Perl->Writing_to_File) {
        my $UI_String = ($indent x ($depth)).$expr;
        if (!$notabs && $tab) {
            # replace multiple spaces with tabs
            $UI_String =~ s/$tab/\t/g;
        }
        eval "push \@{${current_form}\{'UI_Strings'}}, \$UI_String";
    }
    unless ($Glade_Perl->source->quick_gen or $tofileonly) {
        eval $expr or
            ($@ && die  "\n\nin $me\n\twhile trying to eval".
                "'$expr'\n\tFAILED with Eval error '$@'\n");
    }
    if ($mydebug) {
        $expr =~ s/\%/\%\%/g;
        $Glade_Perl->diag_print (2, "UI%s'%s'", $indent, $expr);
    }
}

#===============================================================================
#=========== Documentation files
#===============================================================================
sub write_documentation {
    my ($class, $force) = @_;
    return unless $class->doc->write;
    my $me = __PACKAGE__."::write_documentation";
    my ($string, $file);
    my $count = 0;

    $class->doc->directory($class->full_Path(
        $class->doc->directory, $class->glade->directory));

    if ($class->doc->directory ne $class->glade->directory) {
        unless (-d $class->doc->directory) {
            # Source directory does not exist yet so create it
            $Glade_Perl->diag_print (2, "%s- Creating documentation directory '%s' in %s",
                $indent, $class->doc->directory, $me);
            mkpath($class->doc->directory );
        }
    }

    for $file (sort keys %{$class->doc}) {
        next unless $force || $class->doc->{$file};
        unless ("*$permitted_fields*directory*write*" =~ /\*$file\*/) {
            $class->doc->{$file} = $class->full_Path(
                $class->doc->{$file},
                $class->doc->directory);
            if ($force || !-f $class->doc->{$file}) {
                $class->diag_print(2, "%s- Generating documentation file '%s'",
                    $class->source->indent, $class->doc->{$file});
                eval "\$string = \$class->dist_$file";
                $class->save_file_from_string($class->doc->{$file}, $string);
                $count++;
                if ($class->verbosity >= 4) {
                    print "-----------------------------\n".
                        "$string\n-----------------------------\n";
                }
            }
        }
    }
    return $count;
}

sub dist_COPYING {
    my ($class) = @_;
    return $Glade_Perl->app->copying;
}

sub dist_Changelog {
    my ($class) = @_;
    return "Revision history for Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------

".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."\n";
}

sub dist_FAQ {
    my ($class) = @_;
    return "Frequently Asked Questions about Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."\n";
}

sub dist_INSTALL {
    my ($class) = @_;
    return "How to install Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------

TO INSTALL
----------
There is a standard Makefile.PL to handle some checks and install the package

To install
    perl Makefile.PL
    make
    make test
    su
    make install (if test was OK)

TO BUILD RPMS
-------------
Build the RPMs by calling eg.
    rpm -ta ".$class->app->name."-".$class->app->version.".tar.gz


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."
";
}

sub dist_NEWS {
    my ($class) = @_;
    return "NEWS about Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."\n";
}

sub dist_README {
    my ($class) = @_;
    return "Introduction to Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------

".$class->app->description."


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."
";
}

sub dist_ROADMAP {
    my ($class) = @_;
    return "ROADMAP for Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."\n";
}

sub dist_TODO {
    my ($class) = @_;
    return "Things to do for Glade-Perl application '".$Glade_Perl->app->name."'
--------------------------------------------------------------------


".$class->glade2perl->start_time." - ".$class->app->author."
".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."\n";
}

#===============================================================================
#=========== Distribution files
#===============================================================================
sub write_distribution {
    my ($class, $force) = @_;
    return unless $class->dist->write;
    my $me = __PACKAGE__."::write_distribution";
    my ($string, $file);
    my $exec_mode = 0755;
    my $count = 0;

    $class->dist->spec($class->full_Path(
        ($class->dist->spec || $class->app->name.".spec"),
        $class->glade->directory));

    for $file (sort keys %{$class->dist}) {
        next unless $force || $class->dist->{$file};
        unless ("*$permitted_fields*directory*write*type*compress*scripts*docs*bin_directory*test_directory*" =~ /\*$file\*/) {
            if ($force || !-f $class->dist->{$file}) {
                $class->diag_print(2, "%s- Generating distribution file '%s'",
                    $class->source->indent, $class->dist->{$file});
                eval "\$string = \$class->dist_$file";
                if ($class->verbosity >= 4) {
                    print "----------------------------- $file\n".
                          "$string\n".
                          "-----------------------------\n";
                }
                $class->save_file_from_string($class->dist->{$file}, $string);
                $count++;
                if ('*test_pl*bin*' =~ /\*$file\*/) {
                    chmod $exec_mode, $class->dist->{$file};
                }
            }
        }
    }
    return $count;
}

sub dist_MANIFEST_SKIP {
    my ($class) = @_;

    my $string = "\\bRCS\\b
^MANIFEST\\.
^Makefile\$
\~\$
\.html\$
\.old\$
^blib/
^MakeMaker-\\d
pod2html
.bak\$
SIGS.pm
";
    $string .= "\^".(basename $class->glade->file)."\n";
    if ($class->glade->proto->{project}{output_translatable_strings}) {
        $string .= "\^".$class->glade->proto->{project}{translatable_strings_file};
    };
    return $string;
}

sub dist_Makefile_PL {
    my ($class) = @_;

    my $name = $class->module->directory;
    $name =~ s|^$class->{dist}{directory}||;
    $name =~ s|^/||;

    my $ui_file = $class->module->ui->file;
    $ui_file =~ s|^$class->{dist}{directory}||;
    $ui_file =~ s|^/||;

return "#
#   Makefile.PL for ".$class->app->name."
#".$class->source->indent."- version ".$class->app->version.
" - This file was created by ".__PACKAGE__."
#
require 5.000;
use ExtUtils::MakeMaker;
use strict;

#--- Configuration section ---

my \@programs_to_install = qw(".$class->dist->scripts.");

my \@need_perl_modules = (
    # Check for Gtk::Types rather than the Gtk supermodule
    #   this avoids dumping MakeMaker
    {'name'     => 'Gtk',
    'test'      => 'Gtk::Types',
    'version'   => '".$Glade::PerlUI::gtk_perl_depends->{'MINIMUM REQUIREMENTS'}."',
    'reason'    => \"implements the perl bindings to Gtk+.\\n\".
                    \"The module is called Gtk-Perl on CPAN or \".
                    \"module gnome-perl in the Gnome CVS\"},

    # Check for Gnome::Types rather than the Gnome supermodule
    #   this avoids dumping MakeMaker
    {'name'     => 'Gnome',
    'test'      => 'Gnome::Types',
    'version'   => '".$Glade::PerlUI::gnome_libs_depends->{'MINIMUM REQUIREMENTS'}."',
    'reason'    => \"implements the perl bindings to Gnome.\\n\".
                   \"It is a submodule of the Gtk-Perl package and needs to be built separately.\\n\".
                   \"Read the Gtk-Perl INSTALL file for details of how to do this.\\n\".
                   \"Glade-Perl will still work but you will not be able to \\n\".
                   \"use any Gnome widgets in your Glade projects\"},
    );
#--- End Configuration - You should not have to change anything below this line

# Allow us to suppress all program installation with the -n (library only)
# option.  This is for those that don't want to mess with the configuration
# section of this file.
use Getopt::Std;
use vars qw(\$opt_n);
unless (getopts(\"n\")) {
    die \"Usage: \$0 [-n]\\n\";
}
\@programs_to_install = () if \$opt_n;

# Check for non-standard modules that are used by this library.
\$| = 1; # autoflush on
my \$missing_modules = 0;

foreach my \$mod (\@need_perl_modules) {
    print \"Checking for \$mod->{'name'}..\";
    eval \"require \$mod->{'test'}\";
    if (\$@) {
        \$missing_modules++;
        print \" failed\\n\";
        print   \"-------------------------------------------------------\".
                \"\\n\$\@\\n\",
                \"\$mod->{'name'} is needed, it \$mod->{'reason'}\\n\",
                \"We need at least version \$mod->{'version'}\\n\".
                \"-------------------------------------------------------\\n\";
        sleep(2);  # Don't hurry too much
    } else {
        print \" ok\\n\";
    }
}

#--------------------------------------
print \"-------------------------------------------------------
The missing modules can be obtained from CPAN. Visit
 to find a CPAN site near you.
-------------------------------------------------------\\n\\n\"
     if \$missing_modules;

#--------------------------------------
# Last of all generate the Makefile
WriteMakefile(
    'DISTNAME'     => '".$class->app->name."',
    'NAME'         => '$name',
    'VERSION_FROM' => '$ui_file',
    'EXE_FILES'    => [ \@programs_to_install ],
    'clean'        => { FILES => '\$(EXE_FILES)' },
    'dist'         => { COMPRESS => 'gzip', SUFFIX => 'gz' }
);

package MY;

# Pass Glade-Perl version number to pod2man
sub manifypods
{
    my \$self = shift;
    my \$ver = \$self->{'VERSION'} || \"\";
    local(\$_) = \$self->SUPER::manifypods(\@_);
    s/pod2man\\s*\$/pod2man --release ".$class->app->name."-\$ver/m;
    \$_;
}

exit(0);

# End of Makefile.PL
";
}

sub dist_spec {
    my ($class) = @_;
    my $docs;
    if ($class->dist->docs) {
        $docs = $class->dist->docs;
    } else {
        $docs = $class->doc->directory;
        $docs =~ s/^$class->{glade}{directory}//;
        $docs =~ s/^\///;
        $docs .= "/*";
    }
    my $rpm_date = `date "+%a %b %d %Y"`;
    chomp $rpm_date;
return "\%define ver     ".$class->app->version."
\%define rel     1
\%define name    ".$class->app->name."
\%define rlname  \%{name}
\%define source0 http://\%{name}-\%{ver}.tar.gz
\%define url     http://
\%define group   Application
\%define copy    GPL or Artistic
\%define filelst \%{name}-\%{ver}-files
\%define confdir /etc
\%define prefix  /usr
\%define arch    noarch

Summary: ".$class->app->description."

Name: \%name
Version: \%ver
Release: \%rel
Copyright: \%{copy}
Packager: ".$class->app->author."
Source: \%{source0}
URL: %{url}
Group: \%{group}
BuildArch: \%{arch}
BuildRoot: /var/tmp/\%{name}-\%{ver}

\%description
".$class->app->description."

\%prep
\%setup -n \%{rlname}-\%{ver}

\%build
if [ \$(perl -e 'print index(\$INC[0],\"\%{prefix}/lib/perl\");') -eq 0 ];then
    # package is to be installed in perl root
    inst_method=\"makemaker-root\"
    CFLAGS=\$RPM_OPT_FLAGS perl Makefile.PL PREFIX=\%{prefix}
else
    # package must go somewhere else (eg. /opt), so leave off the perl
    # versioning to ease integration with automatic profile generation scripts
    # if this is really a perl-version dependant package you should not omiss
    # the version info...
    inst_method=\"makemaker-site\"
    CFLAGS=\$RPM_OPT_FLAGS perl Makefile.PL PREFIX=\%{prefix} LIB=\%{prefix}/lib/perl5
fi

echo \$inst_method > inst_method

# get number of processors for parallel builds on SMP systems
numprocs=`cat /proc/cpuinfo | grep processor | wc | cut -c7`
if [ \"x\$numprocs\" = \"x\" -o \"x\$numprocs\" = \"x0\" ]; then
  numprocs=1
fi

make \"MAKE=make -j\$numprocs\"

\%install
rm -rf \$RPM_BUILD_ROOT

if [ \"\$(cat inst_method)\" = \"makemaker-root\" ];then
   make UNINST=1 PREFIX=\$RPM_BUILD_ROOT\%{prefix} install
elif [ \"\$(cat inst_method)\" = \"makemaker-site\" ];then
   make UNINST=1 PREFIX=\$RPM_BUILD_ROOT\%{prefix} LIB=\$RPM_BUILD_ROOT\%{prefix}/lib/perl5 install
fi

\%__os_install_post
find \$RPM_BUILD_ROOT -type f -print|sed -e \"s\@^\$RPM_BUILD_ROOT\@\@g\" > \%{filelst}

\%files -f \%{filelst}
\%defattr(-, root, root)
\%doc $docs

\%clean
rm -rf \$RPM_BUILD_ROOT

\%changelog
* $rpm_date - ".$class->app->author."
".$class->source->indent."This file was created by ".__PACKAGE__."\n";
}

sub dist_test_pl {
    my ($class) = @_;
    my $init_string;
    if ($class->app->allow_gnome) {
        $init_string .= "Gnome->init(\"\$PACKAGE\", \"\$VER"."SION\");";
    } else {
        $init_string .= "Gtk->init;";
    }

return "#!/usr/bin/perl
#==============================================================================
#=== This is a test script
#==============================================================================
require 5.000; use strict 'vars', 'refs', 'subs';

use Test;
BEGIN { plan tests => 2 };

use ".$class->test->use_module.";
ok(1);

$init_string
my \$window = ".$class->test->first_form."->new;
ok(\$window->INSTANCE);

";
}

sub dist_bin {
    my ($class) = @_;
return "#!/usr/bin/perl
#==============================================================================
#=== This is a toplevel script
#==============================================================================
require 5.000; use strict 'vars', 'refs', 'subs';

package ".$class->test->first_form.";

BEGIN {
    use lib \"./\";
    use ".$class->test->use_module.";
    use vars qw(\@ISA);
#    use Carp qw(cluck);
#        \$SIG{__DIE__}  = \&Carp::confess;
#        \$SIG{__WARN__} = \&Carp::cluck;
}

\$Glade::PerlRun::pixmaps_directory = \"".$class->glade->pixmaps_directory."\";

select STDOUT; \$| = 1;

my \%params = (
);

__PACKAGE__->app_run(\%params) && exit 0;

exit 1;

1;

__END__