view release on metacpan or  search on metacpan

Glade/Two/Generate.pm  view on Meta::CPAN

        if ($type & $STRING) {
#            if ((defined $default) and ($value ne $default)) {
#                $value =~ s/\n/\\n/g;    # To get through add_to_UI
                # Backslash escape any single quotes (unless they are already backslashed)
                $value =~ s/(?!\\)(.)'/$1\\'/g;
                $value =~ s/^'/\\'/g;
                $class->add_to_UI($depth, "\$widgets->{'$name'}->$method(_('$value')$args);");
#            }
        } else {
            unless (defined $default and $value == $default) {
                $class->add_to_UI($depth, "\$widgets->{'$name'}->$method('$value'$args);");
            }
        }
    }
}

sub use_set_flag {
    my ($class, $name, $proto, $property, $type, $depth, $flag, $default) = @_;
    $type ||= $BOOL;
    $flag ||= $property;
#print Dumper(\@_);
    my $value  = $class->use_par($proto, $property,  $type|$MAYBE);
    if (defined $value) {
        if (!(defined $default) or ($value != $default)) {
            $class->add_to_UI($depth, "${current_form}\{'$name'}->SET_FLAGS('$flag');");
        }
    }
}

sub use_par {
    my ($class, $proto, $key, $request, $default, $dont_undef) = @_;
    my $me = (ref $class || $class)."->use_par";

    my $type;
    my $self;
    $request ||= $MAYBE;
    if ($request&$NOT_WIDGET) {
        $self = $proto->{'property'}{$key}{'value'};
        delete $proto->{'property'}{$key} unless $dont_undef;
    } elsif ($request&$NOT_PROPERTY) {
        $self = $proto->{$key};
        delete $proto->{$key} unless $dont_undef;
    } else {
        if (defined $proto->{'widget'}{'property'}{$key}) {
            $self = $proto->{'widget'}{'property'}{$key}{'value'};
            delete $proto->{'widget'}{'property'}{$key} unless $dont_undef;
        }
    }
    unless (defined $self) {
        if (defined $default) {
            $self = $default;

        } elsif ($request & $MAYBE) {
            return undef;
            
        } else {
            # We have no value and no default to use so bail out here
            $Glade_Perl->diag_print (1, "error No value in supplied ".
                "%s and NO default was supplied in ".
                "%s called from %s line %s",
                "$proto->{'widget'}{'name'}\->{'$key'}", $me, (caller)[0], (caller)[2]);
            return undef;
        }
    }
    # We must have some sort of value to use by now
    unless ($request) {
        # Nothing to do, we are already $proto->{$key} so
        # just drop through to undef the supplied prot->{$key}
        
    } elsif ($request & $DEFAULT) {
        # Nothing to do, we are already $proto->{$key} (or default) so
        # just drop through to undef the supplied prot->{$key}
        
    } elsif ($request & $LOOKUP) {
        return '' unless $self;
        
        my $lookup;
        # make an effort to convert from Gtk to Gtk2-Perl constant/enum name
        if ($self =~ /^GNOME/) {
            $lookup = Glade::Two::Gnome->lookup($self);

        } else {
            $lookup = Glade::Two::Gtk->lookup($self);
        }
        unless ($lookup) {
            if (defined $default) {
                $Glade_Perl->diag_print(2, 
                    "warn  Unable to lookup '%s' using default of '%s'",
                    $self, $default);
                $self = $default;
            } else {
                $Glade_Perl->diag_print(1, 
                    "error Unable to lookup '%s' and no default",
                    $self);
            }
        } else {
            $self = $lookup;
        }
            
    } elsif ($request & $BOOL) {
        # Now convert whatever we have ended up with to a BOOL
        # undef becomes 0 (== false)
        $type = $self;
        $self = ('*true*y*yes*on*1*' =~ m/\*$self\*/i) ? '1' : '0';

    } elsif ($request & $KEYSYM) {
        $self =~ s/GDK_//;

    } 

    # Backslash escape any single quotes (unless they are already backslashed)
    $self =~ s/(?!\\)(.)'/$1\\'/g;
    $self =~ s/^'/\\'/g;
    return $self;
}

#===============================================================================
#=========== Utilities to build UI                                    ============
#===============================================================================
sub get_internal_child {
    my ($class, $parent, $name, $proto, $depth) = @_;