Prima
view release on metacpan or search on metacpan
1.18 2005-04-20
- Extend function of listboxes and outlines.
- Change syntax of Drawable:: text methods.
1.17 2005-01-27
- Add Window::onTop.
- Add =SYNOPSIS sections in selected modules.
1.16 2004-10-03
- Add Clipboard::UTF8 exchange format.
- Add Drawable ::lineJoin and ::fillWinding.
1.15 2004-05-05
- Add message hooks.
- Add DirectoryOutline widget.
- Add tying properties.
1.14 2004-02-12
- Add system-specific file dialogs.
- Add Edit::undo.
- Port to cygwin.
1.10 2003-04-24
- Add libtiff support.
- Add grid widgets.
1.09 2003-02-07
- No new features
1.08 2002-11-21
- Add limited utf8/unicode support.
- Enhance image conversion functionality.
1.07 2002-09-25
- Documentation completed.
- Add man pages installation.
1.06 2002-06-26
- Add libXpm support.
1.05 Unknown
api/exception.c
api/file.c
api/hash.c
api/list.c
api/matrix.c
api/thunks.c
api/omp.c
api/options.c
api/perl.c
api/semistatic.c
api/utf8.c
class/AbstractMenu.c
class/AbstractMenu.cls
class/AccelTable.c
class/AccelTable.cls
class/Application.c
class/Application.cls
class/Clipboard.c
class/Clipboard.cls
class/Component.c
class/Component.cls
Makefile.PL view on Meta::CPAN
use File::Basename;
use File::Copy;
use vars qw(
$ARGV_STR
$COUTOFLAG
$COUTEXEFLAG
$CLIBPATHFLAG
$CLINKPREFIX
$LDLIBFLAG
$LDOUTFLAG
$TMPDIR
$NULLDEV
$SCRIPT_EXT
$LD_LIB_EXT
$LIB_EXT
$LIB_PREFIX
$LDFLAGS
$LDDLFLAGS
@LIBS
@INCPATH
Makefile.PL view on Meta::CPAN
$OPTIMIZE = $Config{optimize};
if ( $compiler_type eq 'cl') {
$COUTOFLAG = '-Fo';
$COUTEXEFLAG = '-Fe';
$CLIBPATHFLAG = '/LIBPATH:';
$CLINKPREFIX = '/link';
$CLINKPREFIX .= " $1" if $Config{libs} =~ /(bufferoverflowU.lib)/i;
$LDLIBFLAG = '';
$LDOUTFLAG = '/OUT:';
$LD_LIB_EXT = '.lib';
$OPTIMIZE = '-Zi' if $cmd_options{DEBUG};
$CC_OPENMP = '/openmp';
$LD_OPENMP = '';
# link flag is /DEBUG, but we don't care because ActiveState has it on by default anyway
}
else {
$COUTOFLAG = '-o ';
$COUTEXEFLAG = '-o ';
$CLIBPATHFLAG = '-L';
$CLINKPREFIX = '';
$LDLIBFLAG = '-l';
$LDOUTFLAG = '-o ';
$LD_LIB_EXT = '';
$OPTIMIZE = '-g' if $cmd_options{DEBUG};
$CC_OPENMP = '-fopenmp';
$LD_OPENMP = '-fopenmp';
$OPTIMIZE .= ' -Wall' if gcc;
if ($cmd_options{DEBUG}) {
$passthru_options{LDDLFLAGS} .= ' -g';
$passthru_options{LDDLFLAGS} =~ s/(^| )\-s\b//;
}
}
Makefile.PL view on Meta::CPAN
return $cc;
}
sub ld_command_line
{
my ( $dstf) = shift;
my $ld = "$passthru_options{LD} $passthru_options{LDDLFLAGS}";
$ld .= " $LDFLAGS";
$ld .= " $cmd_options{EXTRA_LDFLAGS}" if length $cmd_options{EXTRA_LDFLAGS};
$ld .= " $LDOUTFLAG$dstf @_";
$ld .= ' ' . join(' ', map { "$LDLIBFLAG$_$LD_LIB_EXT"} @LIBS);
return $ld;
}
sub null_output
{
open OLDSTDOUT, ">&STDOUT" or die "STDOUT dup failed: $!";
open OLDSTDERR, ">&STDERR" or die "STDERR dup failed: $!";
# $NULLDEV = ( $Win32) ? "CON" : "/dev/tty";
# $NULLDEV = ( $Win32) ? "NUL" : "/dev/null";
Makefile.PL view on Meta::CPAN
genclsoptions => '--tml --h --inc',
cobjflag => ${_quote($COUTOFLAG)},
coutexecflag => ${_quote($COUTEXEFLAG)},
clinkprefix => ${_quote($CLINKPREFIX)},
clibpathflag => ${_quote($CLIBPATHFLAG)},
cdefs => [],
libext => ${_quote($LIB_EXT)},
libprefix => ${_quote($LIB_PREFIX)},
libname => ${_quotepath("$cwd/blib/arch/auto/Prima/${LIB_PREFIX}Prima$LIB_EXT")},
dlname => ${_quotepath("$cwd/blib/arch/auto/Prima/Prima.$Config{dlext}")},
ldoutflag => ${_quote($LDOUTFLAG)},
ldlibflag => ${_quote($LDLIBFLAG)},
ldlibpathflag => ${_quote($CLIBPATHFLAG)},
ldpaths => [$libpath],
ldlibs => [$ldlibs],
ldlibext => ${_quote($LD_LIB_EXT)},
inline => ${_quote($DEFINES{__INLINE__})},
dl_load_flags => $DL_LOAD_FLAGS,
optimize => '$OPTIMIZE',
openmp => '$cc_openmp',
Prima/Application.pm view on Meta::CPAN
factor so that when the DPI is 96 it is 1.0, 192 it is 2.0, etc. The increase
step is 0.25, so that bitmaps may look not that distorted. However, when the
value is manually set, there is no such step, any value can be set.
See also: L<Prima/Stress>.
=item wantUnicodeInput BOOLEAN
Selects if the system is allowed to generate key codes in unicode. Returns the
effective state of the unicode input flag, which cannot be changed if perl or
operating system do not support UTF8.
If 1, C<Prima::Clipboard::text> property may return UTF8 text from system
clipboards is available.
Default value: 1
=back
=head2 Events
=over
Prima/Application.pm view on Meta::CPAN
encoded formats C<'image/bmp'>, C<'image/png'> etc are queried if the default
C<'Image'> is not found.
The C<PasteImage> mechanism is devised to read images from clipboard in GTK
environment.
=item PasteText $CLIPBOARD, $$TEXT_REF
The notification queries C<$CLIPBOARD> for text content and stores in
C<$$TEXT_REF>. Default action is that C<'Text'> format is queried if
C<wantUnicodeInput> is unset. Otherwise, C<'UTF8'> format is queried
beforehand.
The C<PasteText> mechanism is devised to ease defining text unicode/ascii
conversion between clipboard and standard widgets, in a standard way.
=back
=head2 Methods
=over
Prima/Application.pm view on Meta::CPAN
sv::MouseButtons - number of the mouse buttons
sv::WheelPresent - 1 if the mouse wheel is present, 0 otherwise
sv::SubmenuDelay - timeout ( in ms ) before a sub-menu shows on
an implicit selection
sv::FullDrag - 1 if the top-level windows are dragged dynamically,
0 - with marquee mode
sv::DblClickDelay - mouse double-click timeout in milliseconds
sv::ShapeExtension - 1 if Prima::Widget::shape functionality is supported,
0 otherwise
sv::ColorPointer - 1 if system accepts color pointer icons.
sv::CanUTF8_Input - 1 if system can generate key codes in unicode
sv::CanUTF8_Output - 1 if system can output utf8 text
sv::CompositeDisplay - 1 if system uses double-buffering and alpha composition for the desktop,
0 if it doesn't, -1 if unknown
sv::LayeredWidgets - 1 if system supports layering
sv::FixedPointerSize - 0 if system doesn't support arbitrary sized pointers and will resize custom icons to the system size
sv::MenuCheckSize - width and height of default menu check icon
sv::FriBidi - 1 if Prima is compiled with libfribidi and full bidi unicode support is available
sv::Antialias - 1 if system supports antialiasing and alpha layer for primitives
sv::LibThai - 1 if Prima is compiled with libthai
The method can be called with a class string instead of an object instance.
Prima/Classes.pm view on Meta::CPAN
$clipboard->store($_, undef) for map { $_->{mime} } @{ $self-> {GTKImageClipboardFormats} // [] };
}
}
sub on_formatexists
{
my ( $self, $format, $clipboard, $ref) = @_;
if ( $format eq 'Text') {
if ( $self-> wantUnicodeInput) {
return $$ref = 'UTF8' if $clipboard-> format_exists( 'UTF8');
}
$$ref = $clipboard-> format_exists( $format ) ? $format : undef;
} elsif ( $format eq 'Image') {
$$ref = undef;
return $$ref = 'Image' if $clipboard-> format_exists( 'Image');
my $codecs = $self-> {GTKImageClipboardFormats} or return;
my %formats = map { $_ => 1 } $clipboard-> get_formats;
my @codecs = grep { $formats{$_->{mime}} } @$codecs or return;
$$ref = $codecs[0]->{mime} if $clipboard-> format_exists($codecs[0]->{mime});
} else {
Prima/Classes.pm view on Meta::CPAN
}
undef;
}
sub on_paste
{
my ( $self, $format, $clipboard, $ref) = @_;
if ( $format eq 'Text') {
if ( $self-> wantUnicodeInput) {
return if defined ( $$ref = $clipboard-> fetch( 'UTF8'));
}
$$ref = $clipboard-> fetch( 'Text');
} elsif ( $format eq 'Image') {
my $codecs = $self-> {GTKImageClipboardFormats} or goto DEFAULT;
my %formats = map { $_ => 1 } $clipboard-> get_formats;
my @codecs = grep { $formats{$_->{mime}} && $_->{w} > 1 } @$codecs or goto DEFAULT;
my $data = $clipboard-> fetch($codecs[0]->{mime});
return unless defined $data;
my $handle;
Prima/Config.pm view on Meta::CPAN
genclsoptions => '--tml --h --inc',
cobjflag => '-o ',
coutexecflag => '-o ',
clinkprefix => '',
clibpathflag => '-L',
cdefs => [],
libext => '.a',
libprefix => '',
libname => '/home/dk/src/Prima/blib/arch/auto/Prima/Prima.a',
dlname => '/home/dk/src/Prima/blib/arch/auto/Prima/Prima.so',
ldoutflag => '-o ',
ldlibflag => '-l',
ldlibpathflag => '-L',
ldpaths => [],
ldlibs => ['jpeg','heif','gif','fribidi','thai','X11','Xext','Xft','freetype','fontconfig','Xrender','harfbuzz','gtk-3','gdk-3','pangocairo-1.0','pango-1.0','atk-1.0','cairo-gobject','cairo','gdk_pixbuf-2.0','gio-2.0','gobject-2.0','g...
ldlibext => '',
inline => 'inline',
dl_load_flags => 1,
optimize => '-O2 -g -Wall',
openmp => '-fopenmp',
Prima/Const.pm view on Meta::CPAN
sv::MouseButtons - number of the mouse buttons
sv::WheelPresent - 1 if the mouse wheel is present, 0 otherwise
sv::SubmenuDelay - timeout ( in ms ) before a sub-menu shows on
an implicit selection
sv::FullDrag - 1 if the top-level windows are dragged dynamically,
0 - with marquee mode
sv::DblClickDelay - mouse double-click timeout in milliseconds
sv::ShapeExtension - 1 if Prima::Widget::shape functionality is supported,
0 otherwise
sv::ColorPointer - 1 if system accepts color pointer icons.
sv::CanUTF8_Input - 1 if system can generate key codes in unicode
sv::CanUTF8_Output - 1 if system can output utf8 text
sv::CompositeDisplay - 1 if system uses double-buffering and alpha composition for the desktop,
0 if it doesn't, -1 if unknown
sv::LayeredWidgets - 1 if system supports layering
sv::FixedPointerSize - 0 if system doesn't support arbitrary sized pointers and will resize custom icons to the system size
sv::MenuCheckSize - width and height of default menu check icon
sv::FriBidi - 1 if Prima is compiled with libfribidi and full bidi unicode support is available
sv::Antialias - 1 if system supports antialiasing and alpha layer for primitives
sv::LibThai - 1 if Prima is compiled with libthai
=head2 ta:: - alignment constants
Prima/Drawable/Glyphs.pm view on Meta::CPAN
1;
=pod
=head1 NAME
Prima::Drawable::Glyphs - helper routines for bi-directional text input and complex scripts output
=head1 SYNOPSIS
=encoding utf-8
=for latex-makedoc header
\usepackage{amsmath,amssymb}
\DeclareFontFamily{U}{rcjhbltx}{}
\DeclareFontShape{U}{rcjhbltx}{m}{n}{<->rcjhbltx}{}
\DeclareSymbolFont{hebrewletters}{U}{rcjhbltx}{m}{n}
\DeclareMathSymbol{\alef}{\mathord}{hebrewletters}{39}
\DeclareMathSymbol{\pe}{\mathord}{hebrewletters}{112}
\DeclareMathSymbol{\samekh}{\mathord}{hebrewletters}{115}
Prima/Drawable/Path.pm view on Meta::CPAN
my ($self, $text, %opt) = @_;
return unless my $c = $self->{canvas};
my $state = $c->get_paint_state;
unless ($state) {
return unless $c->begin_paint_info;
}
$self->translate( 0, $c->font->descent )
unless $opt{baseline} // $c->textOutBaseline;
my $cache = $opt{cache} || {};
my $unicode = utf8::is_utf8($text);
for my $char ( split //, $text ) {
my $ix = ord($char);
$self->glyph($ix, %opt, unicode => $unicode);
my $r = $cache->{$char} //= do {
my $p = $c->get_font_abc($ix,$ix,$unicode);
$p->[0] + $p->[1] + $p->[2]
};
$self->translate($r,0);
}
Prima/Drawable/Path.pm view on Meta::CPAN
Adds sector to the path. Is there only for compatibility with C<Prima::Drawable>.
=item spline, rspline $POINTS, %OPTIONS.
Adds B-spline to path. See L<Prima::Drawable/spline> for C<%OPTIONS> descriptions.
=item text TEXT, %OPTIONS
Adds C<TEXT> to the path. C<%OPTIONS> are same as in L<Prima::Drawable/render_glyph>,
except that C<unicode> is deduced automatically based on whether C<TEXT> has utf8 bit
on or off; and an extra option C<cache> with a hash can be used to speed up the function
with subsequent calls. C<baseline> option is same as L<Prima::Drawable/textOutBaseline>.
=back
=head2 Properties
=over
=item canvas DRAWABLE
Prima/Drawable/TextBlock.pm view on Meta::CPAN
walk( $b, %opt,
position => \@xy,
trace => tb::TRACE_REALIZE_FONTS | tb::TRACE_TEXT | tb::TRACE_GEOMETRY |
(( $opt{restoreCanvas} // 1) ? tb::TRACE_PAINT_STATE : 0 ),
text => sub {
my ($ofs, $len, undef, $t) = @_;
my ($whole, $this_c_width);
if ( !defined $first_a_width) {
my $char = substr( $t, 0, 1 );
( $first_a_width, undef, $this_c_width ) = @{ $canvas->get_font_abc(
ord($char), ord($char), utf8::is_utf8($t)
) };
$whole++ if $len == 1;
}
if ( $ofs == $last_letter_ofs ) {
if ( $whole ) {
$last_c_width = $this_c_width;
} else {
my $char = substr( $t, -1, 1 );
( undef, undef, $last_c_width ) = @{ $canvas->get_font_abc(ord($char), ord($char), utf8::is_utf8($t)) };
}
}
},
);
if ( defined $first_a_width ) {
$first_a_width = ( $first_a_width < 0 ) ? -$first_a_width : 0;
$last_c_width = ( $last_c_width < 0 ) ? -$last_c_width : 0;
} else {
$first_a_width = $last_c_width = 0;
}
Prima/Edit.pm view on Meta::CPAN
$self-> begin_undo_group;
my $block = $self-> has_selection;
$self-> delete_block if $block;
my @cs = $self-> cursor;
my $c = $self-> get_line( $cs[1]);
my $l = 0;
my $chr = chr $code;
utf8::upgrade($chr) if $mod & km::Unicode;
my $ll = $self-> get_chunk_cluster_length($cs[1]);
$c .= ' ' x ($cs[0] - $ll) if $cs[0] > $ll;
my $s = $self->get_shaped_chunk($cs[1]);
my ($new_text, $new_offset) = $self->handle_bidi_input(
action => (($block || $self->insertMode) ? q(insert) : q(overtype)),
at => $cs[0],
input => $chr x $repeat,
text => $c,
rtl => $self->textDirection,
glyphs => $s,
Prima/IniFile.pm view on Meta::CPAN
$self-> {fileName} = canonicalize_fname($fname);
eval
{
my $f;
open $f, "<", $fname or do
{
open $f, ">", $fname or die "Cannot create $fname: $!\n";
close $f;
open $f, "<", $fname or die "Cannot open $fname: $!\n";
};
binmode $f, ":utf8";
my @chunks;
my %sectionChunks = ('' => [0]);
my %sectionItems = ('' => []);
my $currentChunk = [];
my $items = {};
my $chunkNum = 0;
my $line = 0;
push @chunks, $currentChunk;
push @{$sectionItems{''}}, $items;
while (<$f>)
Prima/IniFile.pm view on Meta::CPAN
}
sub write
{
my $self = $_[0];
return unless defined($self-> {fileName}) && $self-> {changed};
my $fname = $self-> {fileName};
eval {
my $f;
open $f, ">", $fname or die "Cannot write to the $fname: $!\n";
binmode $f, ":utf8";
pop @{$self-> {chunks}-> [-1]} if scalar(@{$self-> {chunks}-> [-1]}) && $self-> {chunks}-> [-1]-> [-1] =~ /^\s*$/;
for ( @{$self-> {chunks}})
{
for (@$_) { print $f "$_\n" }
}
push( @{$self-> {chunks}-> [-1]}, '') if scalar(@{$self-> {chunks}-> [-1]}) && $self-> {chunks}-> [-1]-> [-1] !~ /^\s*$/;
close $f;
};
$self-> {changed} = undef if $@;
warn($@) if $@;
Prima/InputLine.pm view on Meta::CPAN
# typing part
if (
!$self-> {readOnly} &&
( $code >= ord(' ')) &&
(( $mod & (km::Alt | km::Ctrl)) == 0) &&
(( $key == kb::NoKey) || ( $key == kb::Space))
) {
my $chr = chr $code;
$self-> begin_undo_group;
utf8::upgrade($chr) if $is_unicode;
my ($curpos, $advance);
if ( $p_start != $p_end) {
substr( $cap, $p_start, $p_end - $p_start) = '';
$self-> charOffset($self->{glyphs}->index2cluster($p_start));
$self-> edit_text( $cap);
local $self->{insertMode} = 1;
$self-> handle_input($chr);
} else {
$self-> handle_input($chr);
}
Prima/PS/PDF.pm view on Meta::CPAN
{
my ( $self, $docName) = @_;
return 0 if $self-> get_paint_state;
$self-> {ps_data} = '';
$self-> {can_draw} = 1;
$self-> {content_size} = 0;
$docName = $::application ? $::application-> name : "Prima::PS::PDF"
unless defined $docName;
$docName = Encode::encode('UTF-16', $docName)
if Encode::is_utf8($docName);
$self-> {fp_hash} = {};
$self-> {xref} = [];
my ($sec,$min,$hour,$mday,$mon,$year) = localtime;
my $date = sprintf("%04d%02d%02d%02d%02d%02d", $year + 1900, $mon, $mday, $hour, $min, $sec);
my $four = pack('C*', 0xde, 0xad, 0xbe, 0xef);
$self-> emit( <<PDFHEADER);
%PDF-1.4
%$four
PDFHEADER
Prima/PodView.pm view on Meta::CPAN
bigofs => 0,
wrapstate => '',
wrapindent => 0,
topicStack => [[-1]],
format => 1,
createIndex => 1,
encoding => undef,
bom => undef,
utf8 => undef,
verbatim => undef,
@opt,
};
}
sub load_image
{
my ( $self, $src, $frame, $rest ) = @_;
return Prima::Image::base64->load_icon($rest, index => $frame, iconUnmask => 1)
Prima/PodView.pm view on Meta::CPAN
sub read
{
my ( $self, $pod) = @_;
my $r = $self-> {readState};
return unless $r;
unless ( defined $r->{bom} ) {
if ( $pod =~ s/^(\x{ef}\x{bb}\x{bf})// ) { # don't care about other BOMs so far
$r-> {bom} = $1;
$r-> {encoding} = Encode::find_encoding('utf-8');
}
}
my $odd = 0;
for ( split ( "(\n)", $pod)) {
next unless $odd = !$odd;
$_ = $r->{encoding}->decode($_, Encode::FB_HTMLCREF) if $r->{encoding};
if (defined $r-> {paragraph_buffer}) {
if ( /^\s*$/) {
Prima/Utils.pm view on Meta::CPAN
This means that files with names that cannot be converted to ANSI (ie
user-preferred) codepage are not visible in perl, but the functions below
mitigate that problem.
The following fine points need to be understood prior to using these functions though:
=over
=item *
Prima makes a distinction whether scalars have their utf8 bit set or not
throughout the whole toolking. For example, text output in both unix and
windows is different depending on the bit, treating non-utf8-bit text as
locale-specific, and utf8-bit text as unicode. The same model is applied for
the file systems.
=item *
Perl implementation for native Win32 creates virtual environments for each
thread, keeping current directory, environment variables, etc. This means that
under Win32 calling C<Prima::Utils::chdir> will NOT automatically make
C<CORE::chdir> assume that value, even if the path is convertable to ANSI. Keep
that in mind when mixing Prima and core functions. (To add more confusion,
under the unix these two chdirs are identical when the path is fully
convertable).
=item *
Under unix, reading entries from environment or file system is opportunistic:
if is a valid utf8, then it is a utf8 string. Mostly because .UTF-8 locale are
default and standard everywhere. Prima ignores C< $ENV{LANG} > here. This is a
bit problematic on Perls under 5.22 as these don't provide means to check for
utf8 string validity, so everything will be slapped a utf8 bit on here --
Beware.
=item *
Setting environment variables may or may not sync with C< %ENV >, depending on
how perl is built. Also, C< %ENV > will warn when trying to set scalars with
utf-8 bit there.
=back
=over
=item access PATH, MODE
Same as C<POSIX::access>.
=item chdir DIR
Prima/Utils.pm view on Meta::CPAN
"dir" - directory
"blk" - block special file
"reg" - regular file
"lnk" - symbolic link
"sock" - socket
"wht" - whiteout
This function was implemented for faster directory reading,
to avoid successive call of C<stat> for every file.
Also, getdir is consistently inclined to treat filenames in utf8,
disregarding both perl unicode settings and the locale.
=item getenv NAME
Reads directly from environment, possibly bypassing C< %ENV >, and disregarding
thread local environment on Win32.
=item link OLDNAME, NEWNAME
Same as C<CORE::link>.
=item local2sv TEXT
Converts 8-bit text into either 8-bit non-utf8-bit or unicode utf8-bit string.
May return undef on memory allocation failure.
=item mkdir DIR, [ MODE = 0666 ]
Same as C<CORE::mkdir>.
=item open_file PATH, FLAGS
Same as C<POSIX::open>
Prima/Utils.pm view on Meta::CPAN
Same as C<CORE::rmdir>
=item setenv NAME, VAL
Directly sets environment variable, possibly bypassing C< %ENV >, depending on
how perl is built. Also disregards thread local environment on Win32.
Note that effective synchronization between this call and C< %ENV > is not
always possible, since Win32 perl implementation simply does not allow that.
One is advised to assign to C< %ENV > manually, but only if both NAME and VAL
don't have their utf8 bit set, otherwise perl will warn about wide characters.
=item stat PATH
Same as C<CORE::stat>, except where there is sub-second time resolution provided,
returns atime/mtime/ctime entries as floats, same as C<Time::HiRes::stat>.
=item sv2local TEXT, FAIL_IF_CANNOT = 1
Converts either 8-bit non-utf8-bit or unicode utf8-bit string into a local encoding.
May return undef on memory allocation failure, or if TEXT contains unconvertible
characters when FAIL_IF_CANNOT = 1
=item unlink PATH
Same as C<CORE::unlink>.
=item utime ATIME, MTIME, PATH
Same as C<CORE::utime>, except where there is sub-second time resolution provided,
Prima/sys/FS.pm view on Meta::CPAN
sub _A ($) { __x sub { ( time - $_[8] ) / 86400 }, $_[0] }
sub _M ($) { __x sub { ( time - $_[9] ) / 86400 }, $_[0] }
sub _C ($) { __x sub { ( time - $_[10] ) / 86400 }, $_[0] }
# adapted from Cwd.pm
sub abs_path
{
unless ( $^O =~ /win32|cygwin/i ) {
require Cwd;
my $p = $_[0];
my $was_utf8 = Encode::is_utf8($p);
$p = Cwd::abs_path($p);
$p = Encode::decode('utf-8', $p) if $was_utf8;
return $p;
}
my $cwd = Prima::Utils::getcwd();
defined $cwd or return undef;
my $path = @_ ? shift : '.';
unless (_e $path) {
require Errno;
$! = Errno::ENOENT();
Prima/sys/Gencls.pm view on Meta::CPAN
sub type2sv
{
my ( $type, $name) = @_;
$type = $mapTypes{ $type} || $type;
if ( ref $type) {
return "sv_$type->[PROPS]->{name}2HV(&($name))";
} elsif ( $type eq 'Handle') {
return "( $name ? (( $incInst)$name)-> $hMate : &PL_sv_undef)";
} elsif ( $type eq 'string') {
my $fname = $name;
$fname =~ s/(.*)\b(\w+)$/${1}is_utf8.$2/;
return "prima_svpv_utf8($name, $fname)";
} elsif ( $type eq 'SV*') {
return $name;
} else {
return "new${xsConv{$type}[7]}( $name$xsConv{$type}[5])";
}
}
sub sv2type
{
my ( $type, $name) = @_;
Prima/sys/Gencls.pm view on Meta::CPAN
for ( sort { $structs{$a}-> [PROPS]-> {order} <=> $structs{$b}-> [PROPS]-> {order}} keys %structs)
{
my $s = $structs{$_};
if ( $$s[PROPS]{genh})
{
my @types = @{$$s[TYPES]};
my @ids = @{$$s[IDS]};
my @def = @{$$s[DEFS]};
print HEADER "typedef struct _$_ {\n";
my ($maxw_undefs, @undefs) = (0);
my ($maxw_utfs, @utfs) = (0);
for ( my $j = 0; $j < @types; $j++) {
if ( ref $types[$j]) {
print HEADER "\t$types[$j]->[PROPS]->{name} $ids[$j];\n";
} elsif ( $types[$j] eq "string") {
print HEADER "\tchar $ids[$j]\[256\];\n";
push @utfs, $ids[$j];
$maxw_utfs = length $ids[$j] if length($ids[$j]) > $maxw_utfs;
} else {
print HEADER "\t$types[$j] $ids[$j];\n";
}
if (($def[$j] // '') =~ /^undef:/) {
push @undefs, $ids[$j];
$maxw_undefs = length $ids[$j] if length($ids[$j]) > $maxw_undefs;
}
}
my $wtab = $maxw_undefs // 0;
$wtab = $maxw_utfs if ($maxw_utfs // 0) > $wtab;
if ( @undefs ) {
print HEADER "\tstruct {\n";
printf HEADER "\t\tunsigned %\-${wtab}s : 1;\n", $_ for @undefs;
print HEADER "\t} undef;\n";
}
if ( @utfs ) {
print HEADER "\tstruct {\n";
printf HEADER "\t\tunsigned %\-${wtab}s : 1;\n", $_ for @utfs;
print HEADER "\t} is_utf8;\n";
}
print HEADER "} $_, *P$_;\n\n";
if ( $$s[PROPS]{hash})
{
print HEADER "extern $_ * SvHV_$_( SV * hashRef, $_ * strucRef, const char * errorAt);\n";
print HEADER "extern SV * sv_${_}2HV( $_ * strucRef);\n";
}
print HEADER "extern $_ ${_}_buffer;\n\n";
}
}
Prima/sys/Gencls.pm view on Meta::CPAN
sv_free( sv);
}
CONTAINED_STRUCTURE
} else {
print HEADER "\t$incSV = hv_fetch( $incHV, \"$lName\", $lNameLen, 0);\n";
if ($def =~ /^undef:(.*)$/) {
print HEADER "\tstrucRef-> undef.$lName = ($incSV == NULL);\n";
$def = $1;
}
if ( $lType eq 'string') {
print HEADER "\tstrucRef->is_utf8.$lName = ($incSV && prima_is_utf8_sv(*$incSV)) ? 1 : 0;\n";
}
$inter = "$incSV ? " . sv2type( $lType, "*$incSV") . " : $def";
print HEADER "\t", cwrite( $lType, $inter, "strucRef-> $lName"), "\n\n";
}
}
print HEADER "\treturn strucRef;\n";
print HEADER "}\n\n";
print HEADER "SV * sv_${_}2HV( $_ * strucRef)\n{\t\n";
print HEADER "\tHV * $incHV = newHV();\n";
Prima/sys/gtk/FileDialog.pm view on Meta::CPAN
return wantarray ? () : undef;
}
$self-> {directory} = Prima::Application-> sys_action( 'gtk.OpenFile.directory');
$self-> {directory} .= '/' unless $self-> {directory} =~ /\/$/;
$self-> {fileName} = $ret;
$self-> {filterIndex} = Prima::Application-> sys_action( 'gtk.OpenFile.filterindex');
for (qw(directory fileName)) {
local $SIG{__DIE__};
my $p;
eval { $p = Encode::decode('UTF-8', $self->{$_}, Encode::FB_CROAK ) };
next if $@;
$self->{$_} = $p;
}
# emulate some flags now
if ( $self-> {pathMustExist}) {
unless ( -d $self-> {directory}) {
message_box( $self-> text, "Directory $self->{directory} does not exist", mb::OK | mb::Error);
next DIALOG;
}
Prima/sys/win32/FileDialog.pm view on Meta::CPAN
sub showDotFiles { 1 }
# mere callbacks if someone wants these to inherit
sub ok {}
sub cancel {}
sub _set
{
my @cmd = @_;
for my $c ( @cmd ) {
unless ( Encode::is_utf8($c)) {
my $v = Prima::Utils::local2sv($c);
$c = $v if defined $v;
}
$c = Encode::encode('utf-8', $c);
}
my $cmd = shift @cmd;
Prima::Application-> sys_action( "win32.OpenFile.$cmd=".join('', @cmd));
}
sub _get
{
my $cmd = shift;
$cmd = Prima::Application-> sys_action( "win32.OpenFile.$cmd");
return Encode::decode('utf-8', $cmd);
}
sub execute
{
my $self = $_[0];
_set( flags => join(',', grep { $self->{flags}->{$_}} keys %{$self->{flags}}));
_set( filters => join("\0", map { "$$_[0] ($$_[1])\0$$_[1]" } @{$self->{filter}}) . "\0");
_set( filterindex => ($self->{filterIndex}+1));
my $dir = $self->{directory};
vmt = vmt-> base;
return vmt != NULL;
}
XS( Prima_message_FROMPERL)
{
dXSARGS;
(void)items;
if ( items != 1)
croak("Invalid usage of Prima::%s", "message");
apc_show_message((char*) SvPV_nolen( ST(0)), prima_is_utf8_sv(ST(0)));
XSRETURN_EMPTY;
}
XS( Prima_dl_export)
{
dXSARGS;
(void)items;
if ( items != 1)
croak("Invalid usage of Prima::%s", "dl_export");
apc_dl_export((char*) SvPV_nolen( ST(0)));
#include "apricot.h"
#include "guts.h"
#ifdef __cplusplus
extern "C" {
#endif
FILE*
prima_open_file( const char *text, Bool is_utf8, const char * mode)
{
int fd, o, m;
const char * omode = mode;
char *cwd = NULL;
FILE * ret;
(void)cwd;
switch ( *mode++ ) {
case 'r':
#if defined(PERL_IMPLICIT_SYS)
if (
(*text != '/') &&
!(isalpha(text[0]) && text[1] == ':')
) {
cwd = apc_fs_getcwd();
apc_fs_chdir(PerlEnv_get_childdir(), false);
}
#endif
if (( fd = apc_fs_open_file( text, is_utf8, m | o, 0666)) < 0) {
free(cwd);
return NULL;
}
#if defined(PERL_IMPLICIT_SYS)
if (cwd) {
apc_fs_chdir(cwd, true);
free(cwd);
}
#endif
PUSHs( sv_2mortal( newSViv( _int)));
break;
case 's':
_string = va_arg( params, char *);
PUSHs( sv_2mortal( newSVpv( _string, 0)));
break;
case 'U':
_string = va_arg( params, char *);
_SV = newSVpv( _string, 0 );
_int = va_arg( params, int);
if ( _int ) SvUTF8_on(_SV);
PUSHs( sv_2mortal( _SV ));
break;
case 'n':
_number = va_arg( params, double);
PUSHs( sv_2mortal( newSVnv( _number)));
break;
case 'S':
_SV = va_arg( params, SV *);
PUSHs( sv_2mortal( newSVsv( _SV)));
break;
#include "apricot.h"
#include "guts.h"
#ifdef __cplusplus
extern "C" {
#endif
int
prima_utf8_length( const char * utf8, int maxlen)
{
int ulen = 0;
if ( maxlen < 0 ) maxlen = INT16_MAX;
while ( maxlen > 0 && *utf8 ) {
const char *u = (char*) utf8_hop(( U8*) utf8, 1);
ulen++;
maxlen -= u - utf8;
utf8 = u;
}
return ulen;
}
Bool
prima_is_utf8_sv( SV * sv)
{
/* from Encode.xs */
if (SvGMAGICAL(sv)) {
SV * sv2 = newSVsv(sv); /* GMAGIG will be done */
Bool ret = SvUTF8(sv2) ? 1 : 0;
SvREFCNT_dec(sv2); /* it was a temp copy */
return ret;
} else {
return SvUTF8(sv) ? 1 : 0;
}
}
SV*
prima_svpv_utf8( const char *text, int is_utf8)
{
SV *sv = newSVpv(text, 0);
if ( is_utf8 ) SvUTF8_on(sv);
return sv;
}
#ifdef __cplusplus
}
#endif
class/AbstractMenu.c view on Meta::CPAN
r-> flags. rightAdjust = rightAdjust ? 1 : 0;
r-> id = ++(var-> autoEnum);
#define a_get( l_, fl_, num) \
if ( num >= 0 ) { \
holder = av_fetch( item, num, 0); \
if ( holder) { \
if ( SvOK(*holder)) { \
l_ = duplicate_string( SvPV_nolen( *holder)); \
fl_ = prima_is_utf8_sv(*holder); \
} \
} else { \
warn("menu build error: array panic"); \
my-> dispose_menu( self, m); \
return NULL; \
} \
}
a_get( r-> accel , r-> flags. utf8_accel, l_accel);
a_get( r-> variable, r-> flags. utf8_variable, l_var);
if ( l_key >= 0) {
holder = av_fetch( item, l_key, 0);
if ( !holder) {
warn("menu build error: array panic");
my-> dispose_menu( self, m);
return NULL;
}
r-> key = key_normalize( SvPV_nolen( *holder));
}
class/AbstractMenu.c view on Meta::CPAN
subItem = *holder;
if ( SvROK( subItem)) {
Handle c_object = gimme_the_mate( subItem);
if ( !register_image(c_object))
goto TEXT;
r-> bitmap = c_object;
} else {
TEXT:
r-> text = duplicate_string( SvPV_nolen( subItem));
r-> flags. utf8_text = prima_is_utf8_sv( subItem);
}
}
/* parsing sub */
if ( l_sub >= 0)
{
holder = av_fetch( item, l_sub, 0);
if ( !holder) {
warn("menu build error: array panic");
my-> dispose_menu( self, m);
class/AbstractMenu.c view on Meta::CPAN
if ( r-> down == NULL) {
/* seems error was occurred inside this call */
my-> dispose_menu( self, m);
return NULL;
}
}
} else {
if ( SvPOK( subItem)) {
r-> perlSub = duplicate_string( SvPV_nolen( subItem));
r-> flags. utf8_perlSub = prima_is_utf8_sv( subItem);
} else {
warn("menu build error: invalid sub name passed");
}
}
}
/* parsing options */
if ( l_options >= 0)
{
holder = av_fetch( item, l_options, 0);
class/AbstractMenu.c view on Meta::CPAN
if ( m-> flags. checked) name[ --shift] = '*';
if ( m-> flags. autotoggle) name[ --shift] = '@';
if ( m-> flags. custom_draw)name[ --shift] = '?';
sv = newSVpv( name, slen);
free(name);
} else
sv = newSVpv( m-> variable, len);
} else /* has name but no flags */
sv = newSVpv( m-> variable, 0);
if ( m-> flags. utf8_variable)
SvUTF8_on( sv);
av_push( loc, sv);
} else { /* has flags but no name - autogenerate */
int len;
char buffer[20];
len = sprintf( buffer, "%s%s%s%s#%d",
m-> flags. disabled ? "-" : "",
m-> flags. checked ? "*" : "",
m-> flags. autotoggle ? "@" : "",
m-> flags. custom_draw ? "?" : "",
m-> id);
av_push( loc, newSVpv( buffer, ( STRLEN) len));
}
if ( m-> bitmap) {
if ( PObject( m-> bitmap)-> stage < csDead)
av_push( loc, newRV( SvRV((( PObject)( m-> bitmap))-> mate)));
else
av_push( loc, newSVpv( "", 0));
} else {
SV * sv = newSVpv( m-> text, 0);
if ( m-> flags. utf8_text) SvUTF8_on( sv);
av_push( loc, sv);
}
if ( m-> accel) {
SV * sv = newSVpv( m-> accel, 0);
av_push( loc, sv);
if ( m-> flags. utf8_accel) SvUTF8_on( sv);
} else {
av_push( loc, newSVpv( "", 0));
}
av_push( loc, newSViv( m-> key));
if ( m-> down) {
av_push( loc, fullTree ?
new_av( m-> down, level + 1, true) :
newRV_noinc(( SV *) newAV())
);
} else if ( m-> code) {
av_push( loc, newSVsv( m-> code));
} else if ( m-> perlSub) {
SV * sv = newSVpv( m-> perlSub, 0);
if ( m-> flags. utf8_perlSub) SvUTF8_on( sv);
av_push( loc, sv);
} else {
av_push( loc, newSVpv( "", 0));
}
if ( m-> options)
av_push( loc, newSVsv(m->options));
} else {
/* divider */
if ( m-> variable) {
SV * sv = newSVpv( m-> variable, 0);
if ( m-> flags. utf8_perlSub) SvUTF8_on( sv);
av_push( loc, sv);
} else {
int len;
char buffer[20];
len = sprintf( buffer, "#%d", m-> id);
av_push( loc, newSVpv( buffer, ( STRLEN) len));
}
}
return newRV_noinc(( SV *) loc);
class/AbstractMenu.c view on Meta::CPAN
return NULL_SV;
m = m->down;
} else
m = var-> tree;
if ( !m ) return NULL_SV;
av = newAV();
while ( m != NULL ) {
if ( m-> variable) {
SV * sv = newSVpv( m-> variable, 0);
if ( m-> flags. utf8_perlSub) SvUTF8_on( sv);
av_push( av, sv);
} else {
int len;
char buffer[20];
len = sprintf( buffer, "#%d", m-> id);
av_push( av, newSVpv( buffer, ( STRLEN) len));
}
m = m-> next;
}
class/AbstractMenu.c view on Meta::CPAN
SV *
AbstractMenu_accel( Handle self, Bool set, char * varName, SV * accel)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_SV;
m = find_menuitem( self, varName, true);
if ( !m) return NULL_SV;
if ( !set) {
SV * sv = newSVpv( m-> accel ? m-> accel : "", 0);
if ( m-> flags. utf8_accel) SvUTF8_on( sv);
return sv;
}
if ( m-> text == NULL) return NULL_SV;
free( m-> accel);
m-> accel = NULL;
m-> accel = duplicate_string( SvPV_nolen( accel));
m-> flags. utf8_accel = prima_is_utf8_sv( accel);
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_accel( self, m);
notify( self, "<ssUS", "Change", "accel",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
accel);
}
return NULL_SV;
}
SV *
AbstractMenu_action( Handle self, Bool set, char * varName, SV * action)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_SV;
m = find_menuitem( self, varName, true);
if ( !m) return NULL_SV;
if ( !set) {
if ( m-> code) return newSVsv( m-> code);
if ( m-> perlSub) {
SV * sv = newSVpv( m-> perlSub, 0);
if ( m-> flags. utf8_perlSub) SvUTF8_on( sv);
return sv;
}
return NULL_SV;
}
if ( m-> flags. divider || m-> down) return NULL_SV;
if ( SvROK( action))
{
if ( m-> code) sv_free( m-> code);
m-> code = NULL;
if ( SvTYPE( SvRV( action)) == SVt_PVCV)
{
m-> code = newSVsv( action);
free( m-> perlSub);
m-> perlSub = NULL;
}
m-> flags. utf8_perlSub = 0;
} else {
char * line = ( char *) SvPV_nolen( action);
free( m-> perlSub);
if ( m-> code) sv_free( m-> code);
m-> code = NULL;
m-> perlSub = duplicate_string( line);
m-> flags. utf8_perlSub = prima_is_utf8_sv( action);
}
return NULL_SV;
}
Bool
AbstractMenu_autoToggle( Handle self, Bool set, char * varName, Bool autotoggle)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return false;
m = find_menuitem( self, varName, true);
if ( m == NULL) return false;
if ( !set)
return m ? m-> flags. autotoggle : false;
if ( m-> flags. divider || m-> down) return false;
m-> flags. autotoggle = autotoggle ? 1 : 0;
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_autotoggle( self, m);
notify( self, "<ssUi", "Change", "autoToggle",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
autotoggle);
}
return autotoggle;
}
static void
set_check( Handle self, char * varName, PMenuItemReg m, Bool checked)
{
char buffer[16];
m-> flags. checked = checked ? 1 : 0;
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_check( self, m);
if ( varName == NULL )
varName = AbstractMenu_make_var_context( self, m, buffer);
notify( self, "<ssUi", "Change", "checked",
varName,
m->variable ? m-> flags.utf8_variable : 0,
checked);
}
static Bool
update_group( Handle self, PMenuItemReg m, PMenuItemReg src)
{
if ( m-> group == src->group && m != src && m->flags.checked )
set_check(self, NULL, m, 0);
return false;
}
class/AbstractMenu.c view on Meta::CPAN
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return 0;
m = find_menuitem( self, varName, true);
if ( m == NULL) return 0;
if ( !set) return m-> group;
if ( m-> group == group ) return group;
m-> group = group;
notify( self, "<ssUS", "Change", "group",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
group);
return group;
}
Bool
AbstractMenu_enabled( Handle self, Bool set, char * varName, Bool enabled)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return false;
class/AbstractMenu.c view on Meta::CPAN
if ( !set)
return m ? !m-> flags. disabled : false;
if (m-> flags. divider) return false;
m-> flags. disabled = !enabled;
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_enabled( self, m);
notify( self, "<ssUi", "Change", "enabled",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
enabled);
}
return enabled;
}
Handle
AbstractMenu_icon( Handle self, Bool set, char * varName, Handle icon)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_HANDLE;
class/AbstractMenu.c view on Meta::CPAN
if ( PObject( m-> icon)-> stage < csDead)
SvREFCNT_dec( SvRV(( PObject( m-> icon))-> mate));
unprotect_object( m-> icon);
}
m-> icon = icon;
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_icon( self, m);
notify( self, "<ssUH", "Change", "icon",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
icon);
}
return NULL_HANDLE;
}
Handle
AbstractMenu_image( Handle self, Bool set, char * varName, Handle image)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_HANDLE;
class/AbstractMenu.c view on Meta::CPAN
return NULL_HANDLE;
if ( PObject( m-> bitmap)-> stage < csDead)
SvREFCNT_dec( SvRV(( PObject( m-> bitmap))-> mate));
unprotect_object( m-> bitmap);
m-> bitmap = image;
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_image( self, m);
notify( self, "<ssUH", "Change", "image",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
image);
}
return NULL_HANDLE;
}
SV *
AbstractMenu_options( Handle self, Bool set, char * varName, SV * options)
{
HV * profile;
PMenuItemReg m;
class/AbstractMenu.c view on Meta::CPAN
if ( pexist(group)) {
if ( m-> flags. divider )
warn("Cannot set group on a divider item");
else
my->group(self, true, varName, pget_i(group));
pdelete(icon);
}
}
notify( self, "<ssUS", "Change", "options",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
options);
return NULL_SV;
}
SV *
AbstractMenu_submenu( Handle self, Bool set, char * varName, SV * submenu)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_SV;
class/AbstractMenu.c view on Meta::CPAN
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_delete( self, m-> down);
my-> dispose_menu( self, m-> down);
m-> down = ( PMenuItemReg) my-> new_menu( self, submenu, 1, NULL);
if ( var-> stage <= csNormal && var-> system)
apc_menu_update( self, m-> down, m-> down);
notify( self, "<ssU", "Change", "submenu",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0);
return NULL_SV;
}
SV *
AbstractMenu_text( Handle self, Bool set, char * varName, SV * text)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_SV;
m = find_menuitem( self, varName, true);
if ( m == NULL) return NULL_SV;
if ( m-> text == NULL) return NULL_SV;
if ( !set) {
SV * sv = newSVpv( m-> text ? m-> text : "", 0);
if ( m-> flags. utf8_text) SvUTF8_on( sv);
return sv;
}
free( m-> text);
m-> text = NULL;
m-> text = duplicate_string( SvPV_nolen( text));
m-> flags. utf8_accel = prima_is_utf8_sv( text);
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_text( self, m);
notify( self, "<ssUS", "Change", "text",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
text);
}
return NULL_SV;
}
SV *
AbstractMenu_key( Handle self, Bool set, char * varName, SV * key)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return NULL_SV;
class/AbstractMenu.c view on Meta::CPAN
if ( m-> flags. divider || m-> down) return NULL_SV;
if ( !set)
return newSViv( m-> key);
m-> key = key_normalize( SvPV_nolen( key));
if ( m-> id > 0) {
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_set_key( self, m);
notify( self, "<ssUi", "Change", "key",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
m->key);
}
return NULL_SV;
}
void
AbstractMenu_set_variable( Handle self, char * varName, SV * newName)
{
PMenuItemReg m;
if ( var-> stage > csFrozen) return;
m = find_menuitem( self, varName, true);
if ( m == NULL) return;
notify( self, "<ssUS", "Change", "rename",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0,
newName);
free( m-> variable);
if ( SvOK(newName)) {
STRLEN len;
char * v;
v = SvPV( newName, len);
if ( len > 0) {
m-> variable = duplicate_string( v);
m-> flags. utf8_variable = prima_is_utf8_sv( newName);
return;
}
}
m-> variable = NULL;
m-> flags. utf8_variable = 0;
}
Bool
AbstractMenu_sub_call( Handle self, PMenuItemReg m)
{
Handle owner;
char buffer[16], *context;
if ( m == NULL) return false;
context = AbstractMenu_make_var_context( self, m, buffer);
class/AbstractMenu.c view on Meta::CPAN
if ( !m->flags.checked )
set_check(self, context, m, 1);
else if ( m-> flags. autotoggle )
set_check(self, context, m, 0);
my-> first_that( self, (void*)update_group, m, true);
} else if ( m-> flags. autotoggle )
set_check(self, context, m, m-> flags. checked ? 0 : 1);
owner = var-> owner;
if ( owner == NULL_HANDLE ) return false;
if ( m-> code) {
if ( m-> flags. utf8_variable) {
SV * sv = newSVpv( context, 0);
SvUTF8_on( sv);
cv_call_perl((( PComponent) owner)-> mate, SvRV( m-> code), "Si", sv, m-> flags. checked);
sv_free( sv);
} else
cv_call_perl((( PComponent) owner)-> mate, SvRV( m-> code), "si", context, m-> flags. checked);
return true;
} else if ( m-> perlSub) {
if ( m-> flags. utf8_variable) {
SV * sv = newSVpv( context, 0);
SvUTF8_on( sv);
call_perl( owner, m-> perlSub, "Si", sv, m-> flags. checked);
sv_free( sv);
} else
call_perl( owner, m-> perlSub, "si", context, m-> flags. checked);
return true;
}
return false;
}
Bool
class/AbstractMenu.c view on Meta::CPAN
{
PMenuItemReg m;
SV * sv;
char buffer[16], *context;
keyRealize( key);
m = ( PMenuItemReg) my-> first_that( self, (void*)key_match, &key, false);
if ( m == NULL ) return NULL_SV;
context = AbstractMenu_make_var_context( self, m, buffer);
sv = newSVpv( context, 0 );
if ( m-> flags. utf8_variable)
SvUTF8_on( sv);
return sv;
}
Bool AbstractMenu_selected( Handle self, Bool set, Bool selected)
{
return false;
}
SV *
AbstractMenu_get_handle( Handle self)
class/AbstractMenu.c view on Meta::CPAN
if ( var-> stage <= csNormal && var-> system)
apc_menu_item_delete( self, m);
up = ( PMenuItemReg) my-> first_that( self, (void*)up_match, m, true);
prev = ( PMenuItemReg) my-> first_that( self, (void*)prev_match, m, true);
if ( up) up -> down = m-> next;
if ( prev) prev-> next = m-> next;
if ( m == var-> tree) var-> tree = m-> next;
m-> next = NULL;
notify( self, "<ssU", "Change", "remove",
m->variable ? m-> variable : varName,
m->variable ? m-> flags.utf8_variable : 0);
my-> dispose_menu( self, m);
}
void
AbstractMenu_insert( Handle self, SV * menuItems, char * rootName, int index)
{
int level;
PMenuItemReg *up, m, addFirst, addLast, branch;
if ( var-> stage > csFrozen) return;
class/AbstractMenu.c view on Meta::CPAN
if ( m && m-> flags. rightAdjust) {
while ( addFirst != addLast-> next) {
addFirst-> flags. rightAdjust = true;
addFirst = addFirst-> next;
}
}
if ( var-> stage <= csNormal && var-> system)
apc_menu_update( self, branch, branch);
notify( self, "<ssU", "Change", "insert", rootName, branch->flags.utf8_variable);
}
Bool
AbstractMenu_is_custom( Handle self, char * varName)
{
PMenuItemReg m = find_menuitem( self, varName, true);
return m && m-> flags. custom_draw;
}
Bool
class/AbstractMenu.c view on Meta::CPAN
m = ( PMenuItemReg) my-> first_that( self, (void*)id_match, &event->gen.i, false);
if ( m == NULL ) return;
context = AbstractMenu_make_var_context( self, m, buffer);
if ( event-> cmd == cmMenuItemMeasure ) {
AV * pt = newAV();
SV * ref = newRV_noinc((SV*)pt);
av_push(pt, newSViv(event->gen.P.x));
av_push(pt, newSViv(event->gen.P.y));
my->notify( self, "<sUS", "ItemMeasure",
context, m-> flags.utf8_variable, ref );
if ( !prima_read_point( ref, (int*)&event->gen.P, 2, NULL))
warn("bad size array returned from onItemMeasure");
sv_free(ref);
} else {
Handle drawable = (Handle) create_object("Prima::Drawable", "");
++SvREFCNT( SvRV((( PAnyObject) drawable)-> mate));
PDrawable(drawable)-> w = event->gen.P.x;
PDrawable(drawable)-> h = event->gen.P.y;
protect_object(drawable);
PObject(drawable)-> options. optSystemDrawable = 1;
PObject(drawable)-> options. optInDraw = 1;
event-> gen.H = drawable;
if ( apc_menu_item_begin_paint(self, event)) {
PComponent(self)->self->notify( self, "<sUHiR", "ItemPaint",
context, m->flags.utf8_variable, event->gen.H, event->gen.B, event->gen.R);
apc_menu_item_end_paint(self, event);
}
PObject(drawable)-> options. optInDraw = 0;
--SvREFCNT( SvRV((( PAnyObject) drawable)-> mate));
unprotect_object(drawable);
Object_destroy(event->gen.H);
}
}
class/Application.c view on Meta::CPAN
{
int count, i;
AV * glo = newAV();
PFont fmtx = apc_fonts( self,
(name && name[0]) ? name : NULL,
(encoding && encoding[0]) ? encoding : NULL,
&count);
for ( i = 0; i < count; i++) {
SV * sv = sv_Font2HV( &fmtx[ i]);
HV * profile = ( HV*) SvRV( sv);
if ( fmtx[i].is_utf8.name ) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "name", 4, 0);
if ( entry && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i].is_utf8.family ) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "family", 6, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( fmtx[i].is_utf8.encoding ) {
SV ** entry = hv_fetch(( HV*) SvRV( sv), "encoding", 8, 0);
if ( name && SvOK( *entry))
SvUTF8_on( *entry);
}
if ( name[0] == 0 && encoding[0] == 0) {
/* Read specially-coded (const char*) encodings[] vector,
stored in fmtx[i].encoding. First pointer is filled with 0s,
except the last byte which is a counter. Such scheme
allows max 31 encodings per entry to be coded with sizeof(char*)==8.
The interface must be re-implemented, but this requires
either change in gencls syntax so arrays can be members of hashes,
or passing of a dynamic-allocated pointer vector here.
*/
class/Application.c view on Meta::CPAN
uiScaling = (double)((int)((double) res.x/ (96.0/UISCALING_STEP) + 0.5)) / UISCALING_STEP; /* 96-143 = 1.5, 144-191 = 1.5 etc */
if ( uiScaling < 0.25 ) uiScaling = 0.25;
}
return var-> uiScaling = uiScaling;
}
Bool
Application_wantUnicodeInput( Handle self, Bool set, Bool want_ui)
{
if ( !set) return var-> wantUnicodeInput;
if ( apc_sys_get_value( svCanUTF8_Input))
var-> wantUnicodeInput = want_ui;
return 0;
}
void Application_update_sys_handle( Handle self, HV * profile) {}
Bool Application_get_capture( Handle self) { return false; }
Bool Application_set_capture( Handle self, Bool capture, Handle confineTo) { return false; }
void Application_set_centered( Handle self, Bool x, Bool y) {}
class/Clipboard.c view on Meta::CPAN
{
char *id;
Handle sysId;
ClipboardExchangeFunc *server;
void *data;
Bool written;
Bool success;
} ClipboardFormatReg, *PClipboardFormatReg;
static SV * text_server ( Handle self, PClipboardFormatReg, int, SV *);
static SV * utf8_server ( Handle self, PClipboardFormatReg, int, SV *);
static SV * image_server ( Handle self, PClipboardFormatReg, int, SV *);
static SV * binary_server( Handle self, PClipboardFormatReg, int, SV *);
static int clipboards = 0;
static int formatCount = 0;
static Bool protect_formats = false;
static PClipboardFormatReg formats = NULL;
void *
Clipboard_register_format_proc( Handle self, char * format, void * serverProc);
void
Clipboard_init( Handle self, HV * profile)
{
inherited init( self, profile);
if ( !apc_clipboard_create(self))
croak( "Cannot create clipboard");
if (clipboards == 0) {
Clipboard_register_format_proc( self, "Text", (void*)text_server);
Clipboard_register_format_proc( self, "Image", (void*)image_server);
Clipboard_register_format_proc( self, "UTF8", (void*)utf8_server);
protect_formats = 1;
}
clipboards++;
CORE_INIT_TRANSIENT(Clipboard);
}
void
Clipboard_done( Handle self)
{
clipboards--;
class/Clipboard.c view on Meta::CPAN
}
void
Clipboard_deregister_format( Handle self, char * format)
{
PClipboardFormatReg fr, list;
if ( protect_formats && (
( strlen( format) == 0) ||
( strcmp( format, "Text") == 0) ||
( strcmp( format, "UTF8") == 0) ||
( strcmp( format, "Image") == 0)))
return;
fr = first_that( self, (void*)find_format, format);
if ( fr == NULL) return;
list = formats;
fr-> server( self, fr, cefDone, NULL_SV);
free( fr-> id);
formatCount--;
memmove( fr, fr + 1, sizeof( ClipboardFormatReg) * ( formatCount - ( fr - list)));
class/Clipboard.c view on Meta::CPAN
var-> openCount++;
if ( var-> openCount > 1) return true;
first_that( self, (void*) reset_written, NULL);
return apc_clipboard_open( self);
}
void
Clipboard_close( Handle self)
{
PClipboardFormatReg text, utf8;
if ( var-> openCount <= 0) {
var-> openCount = 0;
return;
}
var-> openCount--;
if ( var-> openCount > 0) return;
text = formats + cfText;
utf8 = formats + cfUTF8;
/* automatically downgrade UTF8 to TEXT */
if ( utf8-> written && !text-> written) {
SV *utf8_sv, *text_sv;
if (( utf8_sv = utf8-> server( self, utf8, cefFetch, NULL_SV))) {
STRLEN bytelen, charlen;
U8 * src;
src = ( U8 *) SvPV( utf8_sv, bytelen);
text_sv = newSVpvn("", 0);
while ( bytelen > 0) {
register UV u = prima_utf8_uvchr(src, bytelen, &charlen);
char c = ( u < 0x7f) ? u : '?';
src += charlen;
bytelen -= charlen;
sv_catpvn( text_sv, &c, 1);
if ( charlen == 0 ) break;
}
text-> server( self, text, cefFetch, text_sv);
sv_free( text_sv);
}
}
class/Clipboard.c view on Meta::CPAN
return newSVpv( buf, 0);
}
Bool
Clipboard_register_format( Handle self, char * format)
{
void * proc;
if (( strlen( format) == 0) ||
( strcmp( format, "Text") == 0) ||
( strcmp( format, "UTF8") == 0) ||
( strcmp( format, "Image") == 0))
return false;
proc = Clipboard_register_format_proc( self, format, (void*)binary_server);
return proc != NULL;
}
XS( Clipboard_get_formats_FROMPERL)
{
dXSARGS;
class/Clipboard.c view on Meta::CPAN
case cefFetch:
if ( apc_clipboard_get_data( self, cfText, &c)) {
data = newSVpv(( char*) c. data, c. length);
free( c. data);
return data;
}
break;
case cefStore:
if ( prima_is_utf8_sv( data)) {
/* jump to UTF8. close() will later downgrade data to ascii, if any */
instance = formats + cfUTF8;
return instance-> server( self, instance, cefStore, data);
} else {
STRLEN l;
c. data = ( Byte*) SvPV( data, l);
c. length = l;
instance-> success = apc_clipboard_set_data( self, cfText, &c);
instance-> written = true;
}
break;
}
return NULL_SV;
}
static SV *
utf8_server( Handle self, PClipboardFormatReg instance, int function, SV * data)
{
ClipboardDataRec c;
STRLEN l;
switch( function) {
case cefInit:
return ( SV *) cfUTF8;
case cefFetch:
if ( apc_clipboard_get_data( self, cfUTF8, &c)) {
data = newSVpv(( char*) c. data, c. length);
SvUTF8_on( data);
free( c. data);
return data;
}
break;
case cefStore:
c. data = ( Byte*) SvPV( data, l);
c. length = l;
instance-> success = apc_clipboard_set_data( self, cfUTF8, &c);
instance-> written = true;
break;
}
return NULL_SV;
}
static SV *
image_server( Handle self, PClipboardFormatReg instance, int function, SV * data)
{
ClipboardDataRec c;
class/Component.c view on Meta::CPAN
}
}
SV *
Component_name( Handle self, Bool set, SV * name)
{
if ( set) {
free( var-> name);
var-> name = NULL;
var-> name = duplicate_string( SvPV_nolen( name));
opt_assign( optUTF8_name, prima_is_utf8_sv(name));
if ( var-> stage >= csNormal)
apc_component_fullname_changed_notify( self);
} else {
name = newSVpv( var-> name ? var-> name : "", 0);
if ( is_opt( optUTF8_name)) SvUTF8_on( name);
return name;
}
return NULL_SV;
}
Handle
Component_owner( Handle self, Bool set, Handle owner)
{
HV * profile;
if ( !set)
class/Drawable/fonts.c view on Meta::CPAN
dest-> undef = source-> undef;
if ( useHeight) dest-> height = source-> height;
if ( useWidth ) dest-> width = source-> width;
if ( useDir ) dest-> direction = source-> direction;
if ( useStyle ) dest-> style = source-> style;
if ( usePitch ) dest-> pitch = source-> pitch;
if ( useSize ) dest-> size = source-> size;
if ( useVec ) dest-> vector = source-> vector;
if ( useName ) {
strcpy( dest-> name, source-> name);
dest->is_utf8.name = source->is_utf8.name;
}
if ( useEnc ) {
strcpy( dest-> encoding, source-> encoding);
dest->is_utf8.encoding = source->is_utf8.encoding;
}
}
/* nulling dependencies */
if ( !useHeight && useSize)
dest-> height = 0;
if ( !useWidth && ( usePitch || useHeight || useName || useSize || useDir || useStyle))
dest-> width = 0;
if ( !usePitch && ( useStyle || useName || useDir || useWidth))
dest-> pitch = fpDefault;
class/Drawable/fonts.c view on Meta::CPAN
/* validating entries */
if ( dest-> height <= 0) dest-> height = 1;
else if ( dest-> height > 16383 ) dest-> height = 16383;
if ( dest-> width < 0) dest-> width = 1;
else if ( dest-> width > 16383 ) dest-> width = 16383;
if ( dest-> size <= 0) dest-> size = 1;
else if ( dest-> size > 16383 ) dest-> size = 16383;
if ( dest-> name[0] == 0) {
strcpy( dest-> name, "Default");
dest->is_utf8.name = false;
}
if ( dest-> undef.pitch || dest-> pitch < fpDefault || dest-> pitch > fpFixed)
dest-> pitch = fpDefault;
if ( dest-> undef. direction )
dest-> direction = 0;
if ( dest-> undef. style )
dest-> style = 0;
if ( dest-> undef. vector || dest-> vector < fvBitmap || dest-> vector > fvDefault)
dest-> vector = fvDefault;
if ( dest-> undef. encoding )
class/Drawable/fonts.c view on Meta::CPAN
Drawable_get_font_abcdef( Handle self, int first, int last, int flags, PFontABC (*func)(Handle, int, int, int))
{
int i;
AV * av;
PFontABC abc;
if ( first < 0) first = 0;
if ( last < 0) last = 255;
if ( flags & toGlyphs )
flags &= ~toUTF8;
else if ( !(flags & toUTF8)) {
if ( first > 255) first = 255;
if ( last > 255) last = 255;
}
if ( first > last)
abc = NULL;
else {
gpARGS;
gpENTER( newRV_noinc(( SV *) newAV()));
abc = func( self, first, last, flags );
class/Drawable/shape.c view on Meta::CPAN
}
static uint32_t*
sv2uint32( SV * text, unsigned int * size, unsigned int * flags)
{
STRLEN dlen;
register char * src;
uint32_t *ret;
src = SvPV(text, dlen);
if (prima_is_utf8_sv(text)) {
*flags |= toUTF8;
*size = prima_utf8_length(src, dlen);
} else {
*size = dlen;
}
if (!(ret = ( uint32_t*) warn_malloc(sizeof(uint32_t) * (*size))))
return NULL;
if (*flags & toUTF8 ) {
uint32_t *dst = ret;
while ( dlen > 0 && dst - ret < *size) {
STRLEN charlen;
UV uv;
uv = prima_utf8_uvchr(src, dlen, &charlen);
if ( uv > 0x10FFFF ) uv = 0x10FFFF;
*(dst++) = uv;
if ( charlen == 0 ) break;
src += charlen;
dlen -= charlen;
}
*size = dst - ret;
} else {
register int i = *size;
register uint32_t *dst = ret;
class/Drawable/shape.c view on Meta::CPAN
}
if ( skip_if_simple ) {
Bool is_simple = true;
for ( i = 0; i < t.n_glyphs; i++) {
if ( i != t.indexes[i] ) {
is_simple = false;
break;
}
}
if ( is_simple && !(t.flags & toUTF8))
for ( i = 0; i < t.len; i++) {
if (t.text[i] > 0x7f) {
is_simple = false;
break;
}
}
if ( is_simple ) {
return_zero = true;
goto EXIT;
}
( run in 1.625 second using v1.01-cache-2.11-cpan-fd5d4e115d8 )