diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Imager')
69 files changed, 25718 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Imager/API.pod b/Master/tlpkg/tlperl0/lib/Imager/API.pod new file mode 100755 index 00000000000..2f16868eb9f --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/API.pod @@ -0,0 +1,258 @@ +=head1 NAME + +Imager::API - Imager's C API - introduction. + +=head1 SYNOPSIS + + #include "imext.h" + #include "imperl.h" + + DEFINE_IMAGER_CALLBACKS; + + MODULE = Your::Module PACKAGE = Your::Module + + ... + + BOOT: + PERL_INITIALIZE_IMAGER_CALLBACKS; + + +=head1 DESCRIPTION + +The API allows you to access Imager functions at the C level from XS +and from Inline::C. + +The intent is to allow users to: + +=over + +=item * + +write C code that does Imager operations the user might do from Perl, +but faster, for example, the Imager::CountColor example. + +=item * + +write C code that implements an application specific version of some +core Imager object, for example, Imager::SDL. + +=item * + +write C code that hooks into Imagers existing methods, such as filter +or file format handlers. + +=back + +See L<Imager::Inline> for information on using Imager's Inline::C +support. + +=head1 Beware + +=over + +=item * + +don't return an object you received as a parameter - this will cause +the object to be freed twice. + +=back + +=head1 Types + +The API makes the following types visible: + +=over + +=item * + +i_img - used to represent an image + +=item * + +i_color - used to represent a color with up to 8 bits per sample. + +=item * + +i_fcolor - used to represent a color with a double per sample. + +=item * + +i_fill_t - an abstract fill + +=back + +At this point there is no consolidated font object type, and hence the +font functions are not visible through Imager's API. + +=head2 i_img - images + +This contains the dimensions of the image (xsize, ysize, channels), +image metadata (ch_mask, bits, type, virtual), potentially image data +(idata) and the a function table, with pointers to functions to +perform various low level image operations. + +The only time you should directly write to any value in this type is +if you're implementing your own image type. + +The typemap includes typenames Imager and Imager::ImgRaw as typedefs +for C<i_img *>. + +For incoming parameters the typemap will accept either Imager or +Imager::ImgRaw objects. + +For return values the typemap will produce a full Imager object for an +Imager return type and a raw image object for an Imager::ImgRaw return +type. + +=head2 i_color - 8-bit color + +Represents an 8-bit per sample color. This is a union containing +several different structs for access to components of a color: + +=over + +=item * + +gray - single member gray_color. + +=item * + +rgb - r, g, b members. + +=item * + +rgba - r, g, b, a members. + +=item * + +channels - array of channels. + +=back + +Use Imager::Color for parameter and return value types. + +=head2 i_fcolor - floating point color + +Similar to i_color except that each component is a double instead of +an unsigned char. + +Use Imager::Color::Float for parameter and return value types. + +=head2 i_fill_t - fill objects + +Abstract type containing pointers called to perform low level fill +operations. + +Unless you're defining your own fill objects you should treat this as +an opaque type. + +Use Imager::FillHandle for parameter and return value types. At the +Perl level this is stored in the C<fill> member of the Perl level +Imager::Fill object. + +=head1 Create an XS module using the Imager API + +=head2 Foo.pm + +Load Imager: + + use Imager 0.48; + +and bootstrap your XS code - see L<XSLoader> or L<DynaLoader>. + +=head2 Foo.xs + +You'll need the following in your XS source: + +=over + +=item * + +include the Imager external API header, and the perl interface header: + + #include "imext.h" + #include "imperl.h" + +=item * + +create the variables used to hold the callback table: + + DEFINE_IMAGER_CALLBACKS; + +=item * + +initialize the callback table in your BOOT code: + + BOOT: + PERL_INITIALIZE_IMAGER_CALLBACKS; + +=back + +=head2 foo.c + +In any other source files where you want to access the Imager API, +you'll need to: + +=over + +=item * + +include the Imager external API header: + + #include "imext.h" + +=back + +=head2 Makefile.PL + +If you're creating an XS module that depends on Imager's API your +Makefile.PL will need to do the following: + +=over + +=item * + +C<use Imager::ExtUtils;> + +=item * + +include Imager's include directory in INC: + + INC => Imager::ExtUtils->includes + +=item * + +use Imager's typemap: + + TYPEMAPS => [ Imager::ExtUtils->typemap ] + +=item * + +include Imager 0.48 as a PREREQ_PM: + + PREREQ_PM => + { + Imager => 0.48, + }, + +=item * + +Since you use Imager::ExtUtils in Makefile.PL (or Build.PL) you should +include Imager in your configure_requires: + + META_MERGE => + { + configure_requires => { Imager => "0.48" } + }, + +=back + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::ExtUtils, Imager::APIRef, Imager::Inline + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/APIRef.pod b/Master/tlpkg/tlperl0/lib/Imager/APIRef.pod new file mode 100755 index 00000000000..320f0648593 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/APIRef.pod @@ -0,0 +1,1451 @@ +Do not edit this file, it is generated automatically by apidocs.perl +from Imager's source files. + +Each function description has a comment listing the source file where +you can find the documentation. + +=head1 NAME + +Imager::APIRef - Imager's C API - reference. + +=head1 SYNOPSIS + + i_color color; + color.rgba.r = 255; color.rgba.g = 0; color.rgba.b = 255; + + + # Data Types + i_img *img; + i_color black; + black.rgba.r = black.rgba.g = black.rgba.b = black.rgba.a = 0; + i_fill_t *fill; + i_img_dim x; + + # Drawing + i_arc(im, 50, 50, 20, 45, 135, &color); + i_arc_cfill(im, 50, 50, 35, 90, 135, fill); + i_arc_aa(im, 50, 50, 35, 90, 135, &color); + i_arc_aa_cfill(im, 50, 50, 35, 90, 135, fill); + i_circle_aa(im, 50, 50, 45, &color); + i_box(im, 0, 0, im->xsize-1, im->ysize-1, &color). + i_box_filled(im, 0, 0, im->xsize-1, im->ysize-1, &color); + i_box_cfill(im, 0, 0, im->xsize-1, im->ysize-1, fill); + i_flood_fill(im, 50, 50, &color); + i_flood_cfill(im, 50, 50, fill); + i_flood_fill_border(im, 50, 50, &color, &border); + i_flood_cfill_border(im, 50, 50, fill, border); + + # Error handling + i_clear_error(); + i_push_error(0, "Yep, it's broken"); + i_push_error(errno, "Error writing"); + i_push_errorf(errno, "Cannot open file %s: %d", filename, errno); + + # Files + i_set_image_file_limits(500, 500, 1000000); + i_get_image_file_limits(&width, &height, &bytes) + i_i_int_check_image_file_limits(width, height, channels, sizeof(i_sample_t)) + + # Fills + i_fill_t *fill = i_new_fill_solidf(&fcolor, combine); + i_fill_t *fill = i_new_fill_solid(&color, combine); + i_fill_t *fill = i_new_fill_hatch(&fg_color, &bg_color, combine, hatch, custom_hatch, dx, dy); + i_fill_t *fill = i_new_fill_hatchf(&fg_fcolor, &bg_fcolor, combine, hatch, custom_hatch, dx, dy); + i_fill_t *fill = i_new_fill_image(src_img, matrix, x_offset, y_offset, combine); + fill = i_new_fill_fount(0, 0, 100, 100, i_ft_linear, i_ft_linear, + i_fr_triangle, 0, i_fts_grid, 9, 1, segs); + i_fill_destroy(fill); + + # Image + + # Image creation/destruction + i_img *img = i_img_8_new(width, height, channels); + i_img *img = i_sametype(src, width, height); + i_img *img = i_sametype_chans(src, width, height, channels); + i_img *img = i_img_pal_new(width, height, channels, max_palette_size) + i_img *img = i_img_double_new(width, height, channels); + i_img *img = i_img_16_new(width, height, channels); + i_img_destroy(img) + + # Image Implementation + + # Image Information + // only channel 0 writeable + i_img_setmask(img, 0x01); + int mask = i_img_getmask(img); + int channels = i_img_getchannels(img); + i_img_dim width = i_img_get_width(im); + i_img_dim height = i_img_get_height(im); + + # Image quantization + + # Logging + + # Paletted images + + # Tags + i_tags_set(&img->tags, "i_comment", -1); + i_tags_setn(&img->tags, "i_xres", 204); + i_tags_setn(&img->tags, "i_yres", 196); + +=head1 DESCRIPTION + +=head2 Data Types + +=over + +=item i_img + +This is Imager's image type. + +It contains the following members: + +=over + +=item * + +channels - the number of channels in the image + +=item * + +xsize, ysize - the width and height of the image in pixels + +=item * + +bytes - the number of bytes used to store the image data. Undefined +where virtual is non-zero. + +=item * + +ch_mask - a mask of writable channels. eg. if this is 6 then only +channels 1 and 2 are writable. There may be bits set for which there +are no channels in the image. + +=item * + +bits - the number of bits stored per sample. Should be one of +i_8_bits, i_16_bits, i_double_bits. + +=item * + +type - either i_direct_type for direct color images, or i_palette_type +for paletted images. + +=item * + +virtual - if zero then this image is-self contained. If non-zero then +this image could be an interface to some other implementation. + +=item * + +idata - the image data. This should not be directly accessed. A new +image implementation can use this to store its image data. +i_img_destroy() will myfree() this pointer if it's non-null. + +=item * + +tags - a structure storing the image's tags. This should only be +accessed via the i_tags_*() functions. + +=item * + +ext_data - a pointer for use internal to an image implementation. +This should be freed by the image's destroy handler. + +=item * + +im_data - data internal to Imager. This is initialized by +i_img_init(). + +=item * + +i_f_ppix, i_f_ppixf, i_f_plin, i_f_plinf, i_f_gpix, i_f_gpixf, +i_f_glin, i_f_glinf, i_f_gsamp, i_f_gampf - implementations for each +of the required image functions. An image implementation should +initialize these between calling i_img_alloc() and i_img_init(). + +=item * + +i_f_gpal, i_f_ppal, i_f_addcolors, i_f_getcolors, i_f_colorcount, +i_f_maxcolors, i_f_findcolor, i_f_setcolors - implementations for each +paletted image function. + +=item * + +i_f_destroy - custom image destruction function. This should be used +to release memory if necessary. + +=item * + +i_f_gsamp_bits - implements i_gsamp_bits() for this image. + +=item * + +i_f_psamp_bits - implements i_psamp_bits() for this image. + +=back + + +=for comment +From: File imdatatypes.h + +=item i_color + +Type for 8-bit/sample color. + +Samples as per; + + i_color c; + +i_color is a union of: + +=over + +=item * + +gray - contains a single element gray_color, eg. c.gray.gray_color + +=item * + +rgb - contains three elements r, g, b, eg. c.rgb.r + +=item * + +rgba - contains four elements r, g, b, a, eg. c.rgba.a + +=item * + +cmyk - contains four elements c, m, y, k, eg. C<c.cmyk.y>. Note that +Imager never uses CMYK colors except when reading/writing files. + +=item * + +channels - an array of four channels, eg C<c.channels[2]>. + +=back + + +=for comment +From: File imdatatypes.h + +=item i_fcolor + +This is the double/sample color type. + +Its layout exactly corresponds to i_color. + + +=for comment +From: File imdatatypes.h + +=item i_fill_t + +This is the "abstract" base type for Imager's fill types. + +Unless you're implementing a new fill type you'll typically treat this +as an opaque type. + + +=for comment +From: File imdatatypes.h + +=item i_img_dim + +A signed integer type that represents an image dimension or ordinate. + +May be larger than int on some platforms. + + +=for comment +From: File imdatatypes.h + + +=back + +=head2 Drawing + +=over + +=item i_arc(im, x, y, rad, d1, d2, color) + + +Fills an arc centered at (x,y) with radius I<rad> covering the range +of angles in degrees from d1 to d2, with the color. + + +=for comment +From: File draw.c + +=item i_arc_aa(im, x, y, rad, d1, d2, color) + + +Antialias fills an arc centered at (x,y) with radius I<rad> covering +the range of angles in degrees from d1 to d2, with the color. + + +=for comment +From: File draw.c + +=item i_arc_aa_cfill(im, x, y, rad, d1, d2, fill) + + +Antialias fills an arc centered at (x,y) with radius I<rad> covering +the range of angles in degrees from d1 to d2, with the fill object. + + +=for comment +From: File draw.c + +=item i_arc_cfill(im, x, y, rad, d1, d2, fill) + + +Fills an arc centered at (x,y) with radius I<rad> covering the range +of angles in degrees from d1 to d2, with the fill object. + + +=for comment +From: File draw.c + +=item i_box(im, x1, y1, x2, y2, color) + + +Outlines the box from (x1,y1) to (x2,y2) inclusive with I<color>. + + +=for comment +From: File draw.c + +=item i_box_cfill(im, x1, y1, x2, y2, fill) + + +Fills the box from (x1,y1) to (x2,y2) inclusive with fill. + + +=for comment +From: File draw.c + +=item i_box_filled(im, x1, y1, x2, y2, color) + + +Fills the box from (x1,y1) to (x2,y2) inclusive with color. + + +=for comment +From: File draw.c + +=item i_circle_aa(im, x, y, rad, color) + + +Antialias fills a circle centered at (x,y) for radius I<rad> with +color. + + +=for comment +From: File draw.c + +=item i_flood_cfill(im, seedx, seedy, fill) + + +Flood fills the 4-connected region starting from the point (seedx, +seedy) with I<fill>. + +Returns false if (seedx, seedy) are outside the image. + + +=for comment +From: File draw.c + +=item i_flood_cfill_border(im, seedx, seedy, fill, border) + + +Flood fills the 4-connected region starting from the point (seedx, +seedy) with I<fill>, the fill stops when it reaches pixels of color +I<border>. + +Returns false if (seedx, seedy) are outside the image. + + +=for comment +From: File draw.c + +=item i_flood_fill(im, seedx, seedy, color) + + +Flood fills the 4-connected region starting from the point (seedx, +seedy) with I<color>. + +Returns false if (seedx, seedy) are outside the image. + + +=for comment +From: File draw.c + +=item i_flood_fill_border(im, seedx, seedy, color, border) + + +Flood fills the 4-connected region starting from the point (seedx, +seedy) with I<color>, fill stops when the fill reaches a pixels with +color I<border>. + +Returns false if (seedx, seedy) are outside the image. + + +=for comment +From: File draw.c + +=item i_glin(im, l, r, y, colors) + + +Retrieves (r-l) pixels starting from (l,y) into I<colors>. + +Returns the number of pixels retrieved. + + +=for comment +From: File imext.c + +=item i_glinf(im, l, r, y, colors) + + +Retrieves (r-l) pixels starting from (l,y) into I<colors> as floating +point colors. + +Returns the number of pixels retrieved. + + +=for comment +From: File imext.c + +=item i_gpal(im, x, r, y, indexes) + + +Reads palette indexes for the horizontal line (x, y) to (r-1, y) into +indexes. + +Returns the number of indexes read. + +Always returns 0 for direct color images. + + +=for comment +From: File imext.c + +=item i_gpix(im, x, y, color) + + +Retrieves the I<color> of the pixel (x,y). + +Returns 0 if the pixel was retrieved, or -1 if not. + + +=for comment +From: File imext.c + +=item i_gpixf(im, x, y, fcolor) + + +Retrieves the color of the pixel (x,y) as a floating point color into +I<fcolor>. + +Returns 0 if the pixel was retrieved, or -1 if not. + + +=for comment +From: File imext.c + +=item i_gsamp(im, l, r, y, samp, chans, chan_count) + + +Reads sample values from im for the horizontal line (l, y) to (r-1,y) +for the channels specified by chans, an array of int with chan_count +elements. + +If chans is NULL then the first chan_count channels are retrieved for +each pixel. + +Returns the number of samples read (which should be (r-l) * +chan_count) + + +=for comment +From: File imext.c + +=item i_gsampf(im, l, r, y, samp, chans, chan_count) + + +Reads floating point sample values from im for the horizontal line (l, +y) to (r-1,y) for the channels specified by chans, an array of int +with chan_count elements. + +If chans is NULL then the first chan_count channels are retrieved for +each pixel. + +Returns the number of samples read (which should be (r-l) * +chan_count) + + +=for comment +From: File imext.c + +=item i_line(im, x1, y1, x2, y2, val, endp) + + +Draw a line to image using bresenhams linedrawing algorithm + + im - image to draw to + x1 - starting x coordinate + y1 - starting x coordinate + x2 - starting x coordinate + y2 - starting x coordinate + val - color to write to image + endp - endpoint flag (boolean) + + +=for comment +From: File draw.c + +=item i_line_aa(im, x1, x2, y1, y2, color, endp) + + +Antialias draws a line from (x1,y1) to (x2, y2) in color. + +The point (x2, y2) is drawn only if endp is set. + + +=for comment +From: File draw.c + +=item i_plin(im, l, r, y, colors) + + +Sets (r-l) pixels starting from (l,y) using (r-l) values from +I<colors>. + +Returns the number of pixels set. + + +=for comment +From: File imext.c + +=item i_plinf(im, l, r, fcolors) + + +Sets (r-l) pixels starting from (l,y) using (r-l) floating point +colors from I<colors>. + +Returns the number of pixels set. + + +=for comment +From: File imext.c + +=item i_ppal(im, x, r, y, indexes) + + +Writes palette indexes for the horizontal line (x, y) to (r-1, y) from +indexes. + +Returns the number of indexes written. + +Always returns 0 for direct color images. + + +=for comment +From: File imext.c + +=item i_ppix(im, x, y, color) + + +Sets the pixel at (x,y) to I<color>. + +Returns 0 if the pixel was drawn, or -1 if not. + +Does no alpha blending, just copies the channels from the supplied +color to the image. + + +=for comment +From: File imext.c + +=item i_ppixf(im, x, y, fcolor) + + +Sets the pixel at (x,y) to the floating point color I<fcolor>. + +Returns 0 if the pixel was drawn, or -1 if not. + +Does no alpha blending, just copies the channels from the supplied +color to the image. + + +=for comment +From: File imext.c + + +=back + +=head2 Error handling + +=over + +=item i_clear_error() + +Clears the error stack. + +Called by any imager function before doing any other processing. + + +=for comment +From: File error.c + +=item i_push_error(int code, char const *msg) + +Called by an Imager function to push an error message onto the stack. + +No message is pushed if the stack is full (since this means someone +forgot to call i_clear_error(), or that a function that doesn't do +error handling is calling function that does.). + + +=for comment +From: File error.c + +=item i_push_errorf(int code, char const *fmt, ...) + +A version of i_push_error() that does printf() like formating. + +Does not support perl specific format codes. + + +=for comment +From: File error.c + +=item i_push_errorvf(int code, char const *fmt, va_list ap) + + +Intended for use by higher level functions, takes a varargs pointer +and a format to produce the finally pushed error message. + +Does not support perl specific format codes. + + +=for comment +From: File error.c + + +=back + +=head2 Files + +=over + +=item i_get_image_file_limits(&width, &height, &bytes) + + +Retrieves the file limits set by i_set_image_file_limits(). + + +=for comment +From: File limits.c + +=item i_int_check_image_file_limits(width, height, channels, sample_size) + + +Checks the size of a file in memory against the configured image file +limits. + +This also range checks the values to those permitted by Imager and +checks for overflows in calculating the size. + +Returns non-zero if the file is within limits. + +This function is intended to be called by image file read functions. + + +=for comment +From: File limits.c + +=item i_set_image_file_limits(width, height, bytes) + + +Set limits on the sizes of images read by Imager. + +Setting a limit to 0 means that limit is ignored. + +Negative limits result in failure. + +Returns non-zero on success. + + +=for comment +From: File limits.c + + +=back + +=head2 Fills + +=over + +=item i_new_fill_fount(xa, ya, xb, yb, type, repeat, combine, super_sample, ssample_param, count, segs) + + + +Creates a new general fill which fills with a fountain fill. + + +=for comment +From: File filters.im + +=item i_new_fill_hatch(fg, bg, combine, hatch, cust_hatch, dx, dy) + + +Creates a new hatched fill with the fg color used for the 1 bits in +the hatch and bg for the 0 bits. If combine is non-zero alpha values +will be combined. + +If cust_hatch is non-NULL it should be a pointer to 8 bytes of the +hash definition, with the high-bits to the left. + +If cust_hatch is NULL then one of the standard hatches is used. + +(dx, dy) are an offset into the hatch which can be used to unalign adjoining areas, or to align the origin of a hatch with the the side of a filled area. + + +=for comment +From: File fills.c + +=item i_new_fill_hatchf(fg, bg, combine, hatch, cust_hatch, dx, dy) + + +Creates a new hatched fill with the fg color used for the 1 bits in +the hatch and bg for the 0 bits. If combine is non-zero alpha values +will be combined. + +If cust_hatch is non-NULL it should be a pointer to 8 bytes of the +hash definition, with the high-bits to the left. + +If cust_hatch is NULL then one of the standard hatches is used. + +(dx, dy) are an offset into the hatch which can be used to unalign adjoining areas, or to align the origin of a hatch with the the side of a filled area. + + +=for comment +From: File fills.c + +=item i_new_fill_image(im, matrix, xoff, yoff, combine) + + +Create an image based fill. + +matrix is an array of 9 doubles representing a transformation matrix. + +xoff and yoff are the offset into the image to start filling from. + + +=for comment +From: File fills.c + +=item i_new_fill_solid(color, combine) + + +Create a solid fill based on an 8-bit color. + +If combine is non-zero then alpha values will be combined. + + +=for comment +From: File fills.c + +=item i_new_fill_solidf(color, combine) + + +Create a solid fill based on a float color. + +If combine is non-zero then alpha values will be combined. + + +=for comment +From: File fills.c + +=item i_fill_destroy(fill) + +Call to destroy any fill object. + + +=for comment +From: File fills.c + + +=back + +=head2 Image + +=over + +=item i_copy(src) + + +Creates a new image that is a copy of src. + +Tags are not copied, only the image data. + +Returns: i_img * + + +=for comment +From: File image.c + +=item i_copyto(dest, src, x1, y1, x2, y2, tx, ty) + + +Copies image data from the area (x1,y1)-[x2,y2] in the source image to +a rectangle the same size with it's top-left corner at (tx,ty) in the +destination image. + +If x1 > x2 or y1 > y2 then the corresponding co-ordinates are swapped. + + +=for comment +From: File paste.im + +=item i_copyto_trans(im, src, x1, y1, x2, y2, tx, ty, trans) + + +(x1,y1) (x2,y2) specifies the region to copy (in the source coordinates) +(tx,ty) specifies the upper left corner for the target image. +pass NULL in trans for non transparent i_colors. + + +=for comment +From: File image.c + +=item i_img_info(im, info) + + +Return image information + + im - Image pointer + info - pointer to array to return data + +info is an array of 4 integers with the following values: + + info[0] - width + info[1] - height + info[2] - channels + info[3] - channel mask + + +=for comment +From: File image.c + +=item i_rubthru(im, src, tx, ty, src_minx, src_miny, src_maxx, src_maxy ) + + +Takes the sub image I<src[src_minx, src_maxx)[src_miny, src_maxy)> and +overlays it at (I<tx>,I<ty>) on the image object. + +The alpha channel of each pixel in I<src> is used to control how much +the existing colour in I<im> is replaced, if it is 255 then the colour +is completely replaced, if it is 0 then the original colour is left +unmodified. + + +=for comment +From: File rubthru.im + + +=back + +=head2 Image creation/destruction + +=over + +=item i_img_16_new(x, y, ch) + + +Create a new 16-bit/sample image. + +Returns the image on success, or NULL on failure. + + +=for comment +From: File img16.c + +=item i_img_8_new(x, y, ch) + + + +Creates a new image object I<x> pixels wide, and I<y> pixels high with +I<ch> channels. + + +=for comment +From: File image.c + +=item i_img_double_new(int x, int y, int ch) + +Creates a new double per sample image. + + +=for comment +From: File imgdouble.c + +=item i_img_pal_new(x, y, channels, maxpal) + + +Creates a new paletted image of the supplied dimensions. + +I<maxpal> is the maximum palette size and should normally be 256. + +Returns a new image or NULL on failure. + + +=for comment +From: File palimg.c + +=item i_sametype(i_img *im, int xsize, int ysize) + + +Returns an image of the same type (sample size, channels, paletted/direct). + +For paletted images the palette is copied from the source. + + +=for comment +From: File image.c + +=item i_sametype_chans(i_img *im, int xsize, int ysize, int channels) + + +Returns an image of the same type (sample size). + +For paletted images the equivalent direct type is returned. + + +=for comment +From: File image.c + +=item i_img_destroy(img) + +Destroy an image object + + +=for comment +From: File image.c + + +=back + +=head2 Image Implementation + +=over + +=item i_img_alloc() + +Allocates a new i_img structure. + +When implementing a new image type perform the following steps in your +image object creation function: + +=over + +=item 1. + +allocate the image with i_img_alloc(). + +=item 2. + +initialize any function pointers or other data as needed, you can +overwrite the whole block if you need to. + +=item 3. + +initialize Imager's internal data by calling i_img_init() on the image +object. + +=back + + +=for comment +From: File image.c + +=item i_img_init(img) + +Imager interal initialization of images. + +Currently this does very little, in the future it may be used to +support threads, or color profiles. + + +=for comment +From: File image.c + + +=back + +=head2 Image Information + +=over + +=item i_img_color_channels(im) + + +The number of channels holding color information. + + +=for comment +From: File immacros.h + +=item i_img_get_height(im) + +Returns the height in pixels of the image. + + +=for comment +From: File image.c + +=item i_img_get_width(im) + +Returns the width in pixels of the image. + + +=for comment +From: File image.c + +=item i_img_getchannels(im) + +Get the number of channels in I<im>. + + +=for comment +From: File image.c + +=item i_img_getmask(im) + +Get the image channel mask for I<im>. + + +=for comment +From: File image.c + +=item i_img_has_alpha(im) + + +Return true if the image has an alpha channel. + + +=for comment +From: File immacros.h + +=item i_img_setmask(im, ch_mask) + +Set the image channel mask for I<im> to I<ch_mask>. + +The image channel mask gives some control over which channels can be +written to in the image. + + +=for comment +From: File image.c + + +=back + +=head2 Image quantization + +=over + +=item i_quant_makemap(quant, imgs, count) + + +Analyzes the I<count> images in I<imgs> according to the rules in +I<quant> to build a color map (optimal or not depending on +quant->make_colors). + + +=for comment +From: File quant.c + +=item i_quant_translate(quant, img) + + +Quantize the image given the palette in quant. + +On success returns a pointer to a memory block of img->xsize * +img->ysize i_palidx entries. + +On failure returns NULL. + +You should call myfree() on the returned block when you're done with +it. + +This function will fail if the supplied palette contains no colors. + + +=for comment +From: File quant.c + +=item i_quant_transparent(quant, data, img, trans_index) + + +Dither the alpha channel on I<img> into the palette indexes in +I<data>. Pixels to be transparent are replaced with I<trans_pixel>. + +The method used depends on the tr_* members of quant. + + +=for comment +From: File quant.c + + +=back + +=head2 Logging + +=over + +=item i_lhead(file, line) + +This is an internal function called by the mm_log() macro. + + +=for comment +From: File log.c + +=item i_loog(level, format, ...) + +This is an internal function called by the mm_log() macro. + + +=for comment +From: File log.c + +=item mm_log((level, format, ...)) + +This is the main entry point to logging. Note that the extra set of +parentheses are required due to limitations in C89 macros. + +This will format a string with the current file and line number to the +log file if logging is enabled. + + +=for comment +From: File log.h + + +=back + +=head2 Paletted images + +=over + +=item i_addcolors(im, colors, count) + + +Adds colors to the image's palette. + +On success returns the index of the lowest color added. + +On failure returns -1. + +Always fails for direct color images. + + +=for comment +From: File imext.c + +=item i_colorcount(im) + + +Returns the number of colors in the image's palette. + +Returns -1 for direct images. + + +=for comment +From: File imext.c + +=item i_findcolor(im, color, &entry) + + +Searches the images palette for the given color. + +On success sets *I<entry> to the index of the color, and returns true. + +On failure returns false. + +Always fails on direct color images. + + +=for comment +From: File imext.c + +=item i_getcolors(im, index, colors, count) + + +Retrieves I<count> colors starting from I<index> in the image's +palette. + +On success stores the colors into I<colors> and returns true. + +On failure returns false. + +Always fails for direct color images. + +Fails if there are less than I<index>+I<count> colors in the image's +palette. + + +=for comment +From: File imext.c + +=item i_maxcolors(im) + + +Returns the maximum number of colors the palette can hold for the +image. + +Returns -1 for direct color images. + + +=for comment +From: File imext.c + +=item i_setcolors(im, index, colors, count) + + +Sets I<count> colors starting from I<index> in the image's palette. + +On sucess returns true. + +On failure returns false. + +The image must have at least I<index>+I<count> colors in it's palette +for this to succeed. + +Always fails on direct color images. + + +=for comment +From: File imext.c + + +=back + +=head2 Tags + +=over + +=item i_tags_delbycode(tags, code) + + +Delete any tags with the given code. + +Returns the number of tags deleted. + + +=for comment +From: File tags.c + +=item i_tags_delbyname(tags, name) + + +Delete any tags with the given name. + +Returns the number of tags deleted. + + +=for comment +From: File tags.c + +=item i_tags_delete(tags, index) + + +Delete a tag by index. + +Returns true on success. + + +=for comment +From: File tags.c + +=item i_tags_destroy(tags) + + +Destroys the given tags structure. Called by i_img_destroy(). + + +=for comment +From: File tags.c + +=item i_tags_find(tags, name, start, &entry) + + +Searchs for a tag of the given I<name> starting from index I<start>. + +On success returns true and sets *I<entry>. + +On failure returns false. + + +=for comment +From: File tags.c + +=item i_tags_findn(tags, code, start, &entry) + + +Searchs for a tag of the given I<code> starting from index I<start>. + +On success returns true and sets *I<entry>. + +On failure returns false. + + +=for comment +From: File tags.c + +=item i_tags_get_color(tags, name, code, &value) + + +Retrieve a tag specified by name or code as color. + +On success sets the i_color *I<value> to the color and returns true. + +On failure returns false. + + +=for comment +From: File tags.c + +=item i_tags_get_float(tags, name, code, value) + + +Retrieves a tag as a floating point value. + +If the tag has a string value then that is parsed as a floating point +number, otherwise the integer value of the tag is used. + +On success sets *I<value> and returns true. + +On failure returns false. + + +=for comment +From: File tags.c + +=item i_tags_get_int(tags, name, code, &value) + + +Retrieve a tag specified by name or code as an integer. + +On success sets the int *I<value> to the integer and returns true. + +On failure returns false. + + +=for comment +From: File tags.c + +=item i_tags_get_string(tags, name, code, value, value_size) + + +Retrieves a tag by name or code as a string. + +On success copies the string to value for a max of value_size and +returns true. + +On failure returns false. + +value_size must be at least large enough for a string representation +of an integer. + +The copied value is always NUL terminated. + + +=for comment +From: File tags.c + +=item i_tags_new(i_img_tags *tags) + + +Initialize a tags structure. Should not be used if the tags structure +has been previously used. + +This should be called tags member of an i_img object on creation (in +i_img_*_new() functions). + +To destroy the contents use i_tags_destroy() + + +=for comment +From: File tags.c + +=item i_tags_set(tags, name, data, size) + +Sets the given tag to the string I<data> + +If size is -1 then the strlen(I<data>) bytes are stored. + +Even on failure, if an existing tag I<name> exists, it will be +removed. + + +=for comment +From: File tags.c + +=item i_tags_set_color(tags, name, code, &value) + + +Stores the given color as a tag with the given name and code. + + +=for comment +From: File tags.c + +=item i_tags_set_float(tags, name, code, value) + + +Equivalent to i_tags_set_float2(tags, name, code, value, 30). + + +=for comment +From: File tags.c + +=item i_tags_set_float2(tags, name, code, value, places) + + +Sets the tag with the given name and code to the given floating point +value. + +Since tags are strings or ints, we convert the value to a string before +storage at the precision specified by C<places>. + + +=for comment +From: File tags.c + +=item i_tags_setn(tags, name, idata) + +Sets the given tag to the integer I<idata> + +Even on failure, if an existing tag I<name> exists, it will be +removed. + + +=for comment +From: File tags.c + + +=back + + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::ExtUtils, Imager::Inline + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Color.pm b/Master/tlpkg/tlperl0/lib/Imager/Color.pm new file mode 100755 index 00000000000..b22f29fba30 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Color.pm @@ -0,0 +1,605 @@ +package Imager::Color; + +use Imager; +use strict; +use vars qw($VERSION); + +$VERSION = "1.010"; + +# It's just a front end to the XS creation functions. + +# used in converting hsv to rgb +my @hsv_map = + ( + 'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn' + ); + +sub _hsv_to_rgb { + my ($hue, $sat, $val) = @_; + + # HSV conversions from pages 401-403 "Procedural Elements for Computer + # Graphics", 1985, ISBN 0-07-053534-5. + + my @result; + if ($sat <= 0) { + return ( 255 * $val, 255 * $val, 255 * $val ); + } + else { + $val >= 0 or $val = 0; + $val <= 1 or $val = 1; + $sat <= 1 or $sat = 1; + $hue >= 360 and $hue %= 360; + $hue < 0 and $hue += 360; + $hue /= 60.0; + my $i = int($hue); + my $f = $hue - $i; + $val *= 255; + my $m = $val * (1.0 - $sat); + my $n = $val * (1.0 - $sat * $f); + my $k = $val * (1.0 - $sat * (1 - $f)); + my $v = $val; + my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, ); + return @fields{split //, $hsv_map[$i]}; + } +} + +# cache of loaded gimp files +# each key is a filename, under each key is a hashref with the following +# keys: +# mod_time => last mod_time of file +# colors => hashref name to arrayref of colors +my %gimp_cache; + +# palette search locations +# this is pretty rude +# $HOME is replaced at runtime +my @gimp_search = + ( + '$HOME/.gimp-1.2/palettes/Named_Colors', + '$HOME/.gimp-1.1/palettes/Named_Colors', + '$HOME/.gimp/palettes/Named_Colors', + '/usr/share/gimp/1.2/palettes/Named_Colors', + '/usr/share/gimp/1.1/palettes/Named_Colors', + '/usr/share/gimp/palettes/Named_Colors', + ); + +sub _load_gimp_palette { + my ($filename) = @_; + + if (open PAL, "< $filename") { + my $hdr = <PAL>; + chomp $hdr; + unless ($hdr =~ /GIMP Palette/) { + close PAL; + $Imager::ERRSTR = "$filename is not a GIMP palette file"; + return; + } + my $line; + my %pal; + my $mod_time = (stat PAL)[9]; + while (defined($line = <PAL>)) { + next if $line =~ /^#/ || $line =~ /^\s*$/; + chomp $line; + my ($r,$g, $b, $name) = split ' ', $line, 4; + if ($name) { + $name =~ s/\s*\([\d\s]+\)\s*$//; + $pal{lc $name} = [ $r, $g, $b ]; + } + } + close PAL; + + $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal }; + + return 1; + } + else { + $Imager::ERRSTR = "Cannot open palette file $filename: $!"; + return; + } +} + +sub _get_gimp_color { + my %args = @_; + + my $filename; + if ($args{palette}) { + $filename = $args{palette}; + } + else { + # try to make one up - this is intended to die if tainting is + # enabled and $ENV{HOME} is tainted. To avoid that untaint $ENV{HOME} + # or set the palette parameter + for my $attempt (@gimp_search) { + my $work = $attempt; # don't modify the source array + $work =~ /\$HOME/ && !defined $ENV{HOME} + and next; + $work =~ s/\$HOME/$ENV{HOME}/; + if (-e $work) { + $filename = $work; + last; + } + } + if (!$filename) { + $Imager::ERRSTR = "No GIMP palette found"; + return (); + } + } + + if ((!$gimp_cache{$filename} + || (stat $filename)[9] != $gimp_cache{$filename}) + && !_load_gimp_palette($filename)) { + return (); + } + + if (!$gimp_cache{$filename}{colors}{lc $args{name}}) { + $Imager::ERRSTR = "Color '$args{name}' isn't in $filename"; + return (); + } + + return @{$gimp_cache{$filename}{colors}{lc $args{name}}}; +} + +my @x_search = + ( + '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this + '/usr/lib/X11/rgb.txt', # seems fairly standard + '/usr/local/lib/X11/rgb.txt', # seems possible + '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first + '/usr/openwin/lib/rgb.txt', + '/usr/openwin/lib/X11/rgb.txt', + ); + +# called by the test code to check if we can test this stuff +sub _test_x_palettes { + @x_search; +} + +# x rgb.txt cache +# same structure as %gimp_cache +my %x_cache; + +sub _load_x_rgb { + my ($filename) = @_; + + local *RGB; + if (open RGB, "< $filename") { + my $line; + my %pal; + my $mod_time = (stat RGB)[9]; + while (defined($line = <RGB>)) { + # the version of rgb.txt supplied with GNU Emacs uses # for comments + next if $line =~ /^[!#]/ || $line =~ /^\s*$/; + chomp $line; + my ($r,$g, $b, $name) = split ' ', $line, 4; + if ($name) { + $pal{lc $name} = [ $r, $g, $b ]; + } + } + close RGB; + + $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal }; + + return 1; + } + else { + $Imager::ERRSTR = "Cannot open palette file $filename: $!"; + return; + } +} + +sub _get_x_color { + my %args = @_; + + my $filename; + if ($args{palette}) { + $filename = $args{palette}; + } + else { + for my $attempt (@x_search) { + if (-e $attempt) { + $filename = $attempt; + last; + } + } + if (!$filename) { + $Imager::ERRSTR = "No X rgb.txt palette found"; + return (); + } + } + + if ((!$x_cache{$filename} + || (stat $filename)[9] != $x_cache{$filename}) + && !_load_x_rgb($filename)) { + return (); + } + + if (!$x_cache{$filename}{colors}{lc $args{name}}) { + $Imager::ERRSTR = "Color '$args{name}' isn't in $filename"; + return (); + } + + return @{$x_cache{$filename}{colors}{lc $args{name}}}; +} + +# Parse color spec into an a set of 4 colors + +sub _pspec { + return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_; + return (@_ ) if @_ == 4 && !grep /[^\d.+eE-]/, @_; + if ($_[0] =~ + /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { + return (hex($1),hex($2),hex($3),hex($4)); + } + if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { + return (hex($1),hex($2),hex($3),255); + } + if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) { + return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255); + } + my %args; + if (@_ == 1) { + # a named color + %args = ( name => @_ ); + } + else { + %args = @_; + } + my @result; + if (exists $args{gray}) { + @result = $args{gray}; + } + elsif (exists $args{grey}) { + @result = $args{grey}; + } + elsif ((exists $args{red} || exists $args{r}) + && (exists $args{green} || exists $args{g}) + && (exists $args{blue} || exists $args{b})) { + @result = ( exists $args{red} ? $args{red} : $args{r}, + exists $args{green} ? $args{green} : $args{g}, + exists $args{blue} ? $args{blue} : $args{b} ); + } + elsif ((exists $args{hue} || exists $args{h}) + && (exists $args{saturation} || exists $args{'s'}) + && (exists $args{value} || exists $args{v})) { + my $hue = exists $args{hue} ? $args{hue} : $args{h}; + my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'}; + my $val = exists $args{value} ? $args{value} : $args{v}; + + @result = _hsv_to_rgb($hue, $sat, $val); + } + elsif (exists $args{web}) { + if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) { + @result = (hex($1),hex($2),hex($3)); + } + elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) { + @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17); + } + } + elsif ($args{name}) { + unless (@result = _get_gimp_color(%args)) { + unless (@result = _get_x_color(%args)) { + require Imager::Color::Table; + unless (@result = Imager::Color::Table->get($args{name})) { + $Imager::ERRSTR = "No color named $args{name} found"; + return (); + } + } + } + } + elsif ($args{gimp}) { + @result = _get_gimp_color(name=>$args{gimp}, %args); + } + elsif ($args{xname}) { + @result = _get_x_color(name=>$args{xname}, %args); + } + elsif ($args{builtin}) { + require Imager::Color::Table; + @result = Imager::Color::Table->get($args{builtin}); + } + elsif ($args{rgb}) { + @result = @{$args{rgb}}; + } + elsif ($args{rgba}) { + @result = @{$args{rgba}}; + return @result if @result == 4; + } + elsif ($args{hsv}) { + @result = _hsv_to_rgb(@{$args{hsv}}); + } + elsif ($args{channels}) { + return @{$args{channels}}; + } + elsif (exists $args{channel0} || $args{c0}) { + my $i = 0; + while (exists $args{"channel$i"} || exists $args{"c$i"}) { + push(@result, + exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"}); + ++$i; + } + } + else { + $Imager::ERRSTR = "No color specification found"; + return (); + } + if (@result) { + if (exists $args{alpha} || exists $args{a}) { + push(@result, exists $args{alpha} ? $args{alpha} : $args{a}); + } + while (@result < 4) { + push(@result, 255); + } + return @result; + } + return (); +} + +sub new { + shift; # get rid of class name. + my @arg = _pspec(@_); + return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : (); +} + +sub set { + my $self = shift; + my @arg = _pspec(@_); + return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : (); +} + +sub equals { + my ($self, %opts) = @_; + + my $other = $opts{other} + or return Imager->_set_error("'other' parameter required"); + my $ignore_alpha = $opts{ignore_alpha} || 0; + + my @left = $self->rgba; + my @right = $other->rgba; + my $last_chan = $ignore_alpha ? 2 : 3; + for my $ch (0 .. $last_chan) { + $left[$ch] == $right[$ch] + or return; + } + + return 1; +} + +sub CLONE_SKIP { 1 } + +1; + +__END__ + +=head1 NAME + +Imager::Color - Color handling for Imager. + +=head1 SYNOPSIS + + use Imager; + + $color = Imager::Color->new($red, $green, $blue); + $color = Imager::Color->new($red, $green, $blue, $alpha); + $color = Imager::Color->new("#C0C0FF"); # html color specification + + $color->set($red, $green, $blue); + $color->set($red, $green, $blue, $alpha); + $color->set("#C0C0FF"); # html color specification + + ($red, $green, $blue, $alpha) = $color->rgba(); + @hsv = $color->hsv(); # not implemented but proposed + + $color->info(); + + if ($color->equals(other=>$other_color)) { + ... + } + + +=head1 DESCRIPTION + +This module handles creating color objects used by imager. The idea is +that in the future this module will be able to handle colorspace calculations +as well. + +An Imager color consists of up to four components, each in the range 0 +to 255. Unfortunately the meaning of the components can change +depending on the type of image you're dealing with: + +=over + +=item * + +for 3 or 4 channel images the color components are red, green, blue, +alpha. + +=item * + +for 1 or 2 channel images the color components are gray, alpha, with +the other two components ignored. + +=back + +An alpha value of zero is fully transparent, an alpha value of 255 is +fully opaque. + +=head1 METHODS + +=over 4 + +=item new + +This creates a color object to pass to functions that need a color argument. + +=item set + +This changes an already defined color. Note that this does not affect any places +where the color has been used previously. + +=item rgba + +This returns the rgba code of the color the object contains. + +=item info + +Calling info merely dumps the relevant colorcode to the log. + +=item equals(other=>$other_color) + +=item equals(other=>$other_color, ignore_alpha=>1) + +Compares $self and color $other_color returning true if the color +components are the same. + +Compares all four channels unless C<ignore_alpha> is set. If +C<ignore_alpha> is set only the first three channels are compared. + +=back + +You can specify colors in several different ways, you can just supply +simple values: + +=over + +=item * + +simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components. + +=item * + +a six hex digit web color, either 'RRGGBB' or '#RRGGBB' + +=item * + +an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'. + +=item * + +a 3 hex digit web color, '#RGB' - a value of F becomes 255. + +=item * + +a color name, from whichever of the gimp Named_Colors file or X +rgb.txt is found first. The same as using the name keyword. + +=back + +You can supply named parameters: + +=over + +=item * + +'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'. +The color components in the range 0 to 255. + + # all of the following are equivalent + my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0); + my $c2 = Imager::Color->new(r=>100, b=>255, g=>0); + my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0); + +=item * + +'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and +'v', to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v +<= 1. + + # the same as RGB(127,255,127) + my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5); + my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5); + +=item * + +'web', which can specify a 6 or 3 hex digit web color, in any of the +forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'. + + my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red + +=item * + +'gray' or 'grey' which specifies a single channel, from 0 to 255. + + # exactly the same + my $c1 = Imager::Color->new(gray=>128); + my $c1 = Imager::Color->new(grey=>128); + +=item * + +'rgb' which takes a 3 member arrayref, containing each of the red, +green and blue values. + + # the same + my $c1 = Imager::Color->new(rgb=>[255, 100, 0]); + my $c1 = Imager::Color->new(r=>255, g=>100, b=>0); + +=item * + +'hsv' which takes a 3 member arrayref, containting each of hue, +saturation and value. + + # the same + my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]); + my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5); + +=item * + +'gimp' which specifies a color from a GIMP palette file. You can +specify the filename of the palette file with the 'palette' parameter, +or let Imager::Color look in various places, typically +"$HOME/gimp-1.x/palettes/Named_Colors" with and without the version +number, and in /usr/share/gimp/palettes/. The palette file must have +color names. + + my $c1 = Imager::Color->new(gimp=>'snow'); + my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal); + +=item * + +'xname' which specifies a color from an X11 rgb.txt file. You can +specify the filename of the rgb.txt file with the 'palette' parameter, +or let Imager::Color look in various places, typically +'/usr/lib/X11/rgb.txt'. + + my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255) + +=item * + +'builtin' which specifies a color from the built-in color table in +Imager::Color::Table. The colors in this module are the same as the +default X11 rgb.txt file. + + my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0) + +=item * + +'name' which specifies a name from either a GIMP palette, an X rgb.txt +file or the built-in color table, whichever is found first. + +=item * + +'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc. + +=item * + +'channels' which takes an arrayref of the channel values. + +=back + +Optionally you can add an alpha channel to a color with the 'alpha' or +'a' parameter. + +These color specifications can be used for both constructing new +colors with the new() method and modifying existing colors with the +set() method. + +=head1 AUTHOR + +Arnar M. Hrafnkelsson, addi@umich.edu +And a great deal of help from others - see the README for a complete +list. + +=head1 SEE ALSO + +Imager(3), Imager::Color +http://imager.perl.org/ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Color/Float.pm b/Master/tlpkg/tlperl0/lib/Imager/Color/Float.pm new file mode 100755 index 00000000000..01d15bafd37 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Color/Float.pm @@ -0,0 +1,128 @@ +package Imager::Color::Float; + +use Imager; +use strict; +use vars qw($VERSION); + +$VERSION = "1.004"; + +# It's just a front end to the XS creation functions. + + +# Parse color spec into an a set of 4 colors + +sub _pspec { + return (@_,1) if @_ == 3; + return (@_ ) if @_ == 4; + if ($_[0] =~ + /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { + return (hex($1)/255.99,hex($2)/255.99,hex($3)/255.99,hex($4)/255.99); + } + if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) { + return (hex($1)/255.99,hex($2)/255.99,hex($3)/255.99,1); + } + return (); +} + +sub new { + shift; # get rid of class name. + my @arg = _pspec(@_); + return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : (); +} + +sub set { + my $self = shift; + my @arg = _pspec(@_); + return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : (); +} + +sub CLONE_SKIP { 1 } + +1; + +__END__ + +=head1 NAME + +Imager::Color::Float - Rough floating point sample colour handling + +=head1 SYNOPSIS + + $color = Imager::Color->new($red, $green, $blue); + $color = Imager::Color->new($red, $green, $blue, $alpha); + $color = Imager::Color->new("#C0C0FF"); # html color specification + + $color->set($red, $green, $blue); + $color->set($red, $green, $blue, $alpha); + $color->set("#C0C0FF"); # html color specification + + ($red, $green, $blue, $alpha) = $color->rgba(); + @hsv = $color->hsv(); # not implemented but proposed + + $color->info(); + + +=head1 DESCRIPTION + +This module handles creating color objects used by imager. The idea is +that in the future this module will be able to handle colorspace calculations +as well. + +A floating point Imager color consists of up to four components, each +in the range 0.0 to 1.0. Unfortunately the meaning of the components +can change depending on the type of image you're dealing with: + +=over + +=item * + +for 3 or 4 channel images the color components are red, green, blue, +alpha. + +=item * + +for 1 or 2 channel images the color components are gray, alpha, with +the other two components ignored. + +=back + +An alpha value of zero is fully transparent, an alpha value of 1.0 is +fully opaque. + +=head1 METHODS + +=over 4 + +=item new + +This creates a color object to pass to functions that need a color argument. + +=item set + +This changes an already defined color. Note that this does not affect any places +where the color has been used previously. + +=item rgba + +This returns the rgba code of the color the object contains. + +=item info + +Calling info merely dumps the relevant colorcode to the log. + +=back + +=head1 AUTHOR + +Arnar M. Hrafnkelsson, addi@umich.edu +And a great deal of help from others - see the README for a complete +list. + +=head1 SEE ALSO + +Imager(3), Imager::Color. + +http://imager.perl.org/ + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Color/Table.pm b/Master/tlpkg/tlperl0/lib/Imager/Color/Table.pm new file mode 100755 index 00000000000..04ff2ede2d3 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Color/Table.pm @@ -0,0 +1,852 @@ +package Imager::Color::Table; +use strict; +use vars qw($VERSION); + +$VERSION = "1.002"; + + my %colors; + +{ + local $_; + while (<DATA>) { + next if /^#/ or !/\S/; + chomp; + my ($r, $g, $b, $name) = split ' ', $_, 4; + if ($name) { + $colors{lc $name} = [ $r, $g, $b ]; + } + } +} + +sub get { + my ($class, $name) = @_; + + exists $colors{lc $name} or return; + + return @{$colors{lc $name}}; +} + +1; + +__DATA__ +# This color data was extracted from the freedesktop.org CVS tree, and +# appears to be under the following license: +# +# Copyright (C) 2004 X Consortium +# +# Permission is hereby granted, free of charge, to any person obtaining a copy +# of this software and associated documentation files (the "Software"), to +# deal in the Software without restriction, including without limitation the +# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +# sell copies of the Software, and to permit persons to whom the Software is +# furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN +# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- +# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +# +# Except as contained in this notice, the name of the X Consortium shall not +# be used in advertising or otherwise to promote the sale, use or other deal- +# ings in this Software without prior written authorization from the X Consor- +# tium. +# +# X Window System is a trademark of X Consortium, Inc. + +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 +169 169 169 dark grey +169 169 169 DarkGrey +169 169 169 dark gray +169 169 169 DarkGray +0 0 139 dark blue +0 0 139 DarkBlue +0 139 139 dark cyan +0 139 139 DarkCyan +139 0 139 dark magenta +139 0 139 DarkMagenta +139 0 0 dark red +139 0 0 DarkRed +144 238 144 light green +144 238 144 LightGreen +__END__ + +=head1 NAME + +Imager::Color::Table - built-in Imager color table + +=head1 SYNOPSIS + + use Imager::Color::Table; + my @rgb = Imager::Color::Table->get($name) + or die "Color $name not found"; + +=head1 DESCRIPTION + +This class provides a base color table for use in resolving color names. + +The table contains the standard X11 rgb.txt colors. + +This table is not included as part of Imager::Color itself since it's +moderately large. + +There is only one method: + +=over + +=item get + + my @rgb = Imager::Color::Table->get('red') + or die "No red found"; + +Retrieves a color from Imager::Color::Tables built-in color table. + +=back + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Cookbook.pod b/Master/tlpkg/tlperl0/lib/Imager/Cookbook.pod new file mode 100755 index 00000000000..8d9cba4a273 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Cookbook.pod @@ -0,0 +1,429 @@ +=head1 NAME + +Imager::Cookbook - recipes working with Imager + +=head1 DESCRIPTION + +Various simple and not so simple ways to do things with Imager. + +=head1 FILES + +This is described in detail in L<Imager::Files>. + +=head2 Reading an image from a file + + my $image = Imager->new; + + $image->read(file=>$filename) or die $image->errstr; + +See L<Imager::Files>. + +=head2 Writing an image to a file + + $image->write(file=>$filename) or die $image->errstr; + +=head2 Write an animated gif. + + # build an array of images to use in the gif + my @images; + # synthesize the images or read them from files, it doesn't matter + ... + + # write the gif + Imager->write_multi({ file=>$filename, type=>'gif' }, @images) + or die Imager->errstr; + +See L<Imager::Files/"Writing an animated GIF"> for a more detailed +example. + +=head2 Reading multiple images from one file + +Some formats, like GIF and TIFF support multiple images per file. Use +the L<read_multi()|Imager::Files> method to read them: + + my @images = Imager->read_multi(file=>$filename) + or die Imager->errstr; + +=head2 Converting from one file format to another + +This is as simple as reading the original file and writing the new +file, for single images: + + my $image = Imager->new; + # Imager auto-detects the input file type + $image->read(file => $input_filename) + or die $image->errstr; + # Imager derives the output file format from the filename + $image->write(file => $output_filename) + or die $image->errstr; + + # or you can supply a type parameter: + $image->write(file => $output_filename, type => 'gif') + or die $image->errstr; + +The main issue that can occur with this is if the input file has +transparency and the output file format doesn't support that. This +can be a problem when converting from GIFs to JPEGs for example. + +To work around that you can compose the source image onto a background +color: + + if ($image->getchannels == 4 or $image->getchannels == 2) { + my $back = Imager->new(xsize => $image->getwidth, + ysize => $image->getheight); + # grey background for grayscale images, red for color + my $back_color = $image->getchannels == 2 ? [ 128 ] : 'red'; + $back->box(filled => 1, color => $back_color); + $back->rubthrough(src => $image); + $image = $back; + } + # now we can write safely to jpeg or pnm + +Some formats support multiple files, so if you want to convert from +say tiff to jpeg, you'll need multiple output files: + + my @images = Imager->read_multi(file => 'input.tif') + or die Imager->errstr; + my $index = 1; + for my $image (@images) { + $image->write(file => sprintf('output%02d.jpg', $index++)) + or die $image->errstr; + } + +=head1 IMAGE SYNTHESIS + +=head2 Creating an image + +To create a simple RGB image, supply the image width and height to the +new() method: + + my $rgb = Imager->new(xsize=>$width, ysize=>$height); + +If you also want an alpha channel: + + my $rgb_alpha = Imager->new(xsize=>$width, ysize=>$height, channels=>4); + +To make a grayscale image: + + my $gray = Imager->new(xsize=>$width, ysize=>$height, channels=>1); + +and a grayscale image with an alpha channel: + + my $gray_alpha = Imager->new(xsize=>$width, ysize=>$height, channels=>2); + +When a new image is created this way all samples are set to zero - +black for 1 or 3 channel images, transparent black for 2 or 4 channel +images. + +You can also create paletted images and images with more than 8-bits +per channel, see L<Imager::ImageTypes> for more details. + +=head2 Setting the background of a new image + +To set the background of a new image to a solid color, use the box() +method with no limits, and C<< filled=>1 >>: + + $image->box(filled=>1, color=>$color); + +As always, a color can be specified as an L<Imager::Color> object: + + my $white = Imager::Color->new(255, 255, 255); + $image->box(filled=>1, color=>$white); + +or you supply any single scalar that Imager::Color's new() method +accepts as a color description: + + $image->box(filled=>1, color=>'white'); + $image->box(filled=>1, color=>'#FF0000'); + $image->box(filled=>1, color=>[ 255, 255, 255 ]); + +You can also fill the image with a fill object: + + use Imager::Fill; + # create the fill object + my $fill = Imager::Fill->new(hatch=>'check1x1') + $image->box(fill=>$fill); + + # let Imager create one automatically + $image->box(fill=>{ hatch=>'check1x1' }); + +See L<Imager::Fill> for information on Imager's fill objects. + +=head1 WORLD WIDE WEB + +As with any CGI script it's up to you to validate data and set limits +on any parameters supplied to Imager. + +For example, if you allow the caller to set the size of an output +image you should limit the size to prevent the client from specifying +an image size that will consume all available memory. + +This is beside any any other controls you need over access to data. + +See L<CGI> for a module useful for processing CGI submitted data. + +=head2 Returning an image from a CGI script + +This is similar to writing to a file, but you also need to supply the +information needed by the web browser to identify the file format: + + my $img = ....; # create the image and generate the contents + ++$|; # make sure the content type isn't buffered + print "Content-Type: image/png\n\n"; + binmode STDOUT; + $img->write(fd=>fileno(STDOUT), type=>'png') + or die $img->errstr; + +You need to set the Content-Type header depending on the file format +you send to the web browser. + +If you want to supply a content-length header, write the image to a +scalar as a buffer: + + my $img = ....; # create the image and generate the contents + my $data; + $img->write(type=>'png', data=>\$data) + or die $img->errstr; + print "Content-Type: image/png\n"; + print "Content-Length: ",length($data),"\n\n"; + binmode STDOUT; + print $data; + +See C<samples/samp-scale.cgi> and C<samples/samp-image.cgi> for a +couple of simple examples of producing an image from CGI. + +=head2 Inserting a CGI image in a page + +There's occasionally confusion on how to display an image generated by +Imager in a page generated by a CGI. + +Your web browser handles this process as two requests, one for the +HTML page, and another for the image itself. + +Each request needs to perform validation since an attacker can control +the values supplied to both requests. + +How you make the data available to the image generation code depends +on your application. + +See C<samples/samp-form.cgi> and C<samples/samp-image.cgi> in the +Imager distribution for one approach. The POD in C<samp-form.cgi> +also discusses some of the issues involved. + +=head2 Parsing an image posted via CGI + +C<WARNING>: file format attacks have become a common attack vector, +make sure you have up to date image file format libraries, otherwise +trying to parse uploaded files, whether with Imager or some other +tool, may result in a remote attacker being able to run their own code +on your system. + +If your HTML form uses the correct magic, it can upload files to your +CGI script, in particular, you need to use C< method="post" > and +C<enctype="multipart/form-data"> in the C<form> tag, and use +C<type="file"> in the C<input>, for example: + + <form action="/cgi-bin/yourprogram" method="post" + enctype="multipart/form-data"> + <input type="file" name="myimage" /> + <input type="submit value="Upload Image" /> + </form> + +To process the form: + +=over + +=item 1. + +first check that the user supplied a file + +=item 2. + +get the file handle + +=item 3. + +have Imager read the image + +=back + + # returns the client's name for the file, don't open this locally + my $cgi = CGI->new; + # 1. check the user supplied a file + my $filename = $cgi->param('myimage'); + if ($filename) { + # 2. get the file handle + my $fh = $cgi->upload('myimage'); + if ($fh) { + binmode $fh; + + # 3. have Imager read the image + my $img = Imager->new; + if ($img->read(fh=>$fh)) { + # we can now process the image + } + } + # else, you probably have an incorrect form or input tag + } + # else, the user didn't select a file + +See C<samples/samp-scale.cgi> and C<samples/samp-tags.cgi> in the +Imager distribution for example code. + +You may also want to set limits on the size of the image read, using +Imager's C<set_file_limits> method, documented in +L<Imager::Files/set_file_limits>. For example: + + # limit to 10 million bytes of memory usage + Imager->set_file_limits(bytes => 10_000_000); + + # limit to 1024 x 1024 + Imager->set_file_limits(width => 1024, height => 1024); + +=head1 DRAWING + +=head2 Adding a border to an image + +First make a new image with space for the border: + + my $border_width = ...; + my $border_height = ...; + my $out = Imager->new(xsize => $source->getwidth() + 2 * $border_width, + ysize => $source->getheight() + 2 * $border_height, + bits => $source->bits, + channels => $source->getchannels); + +Then paste the source image into the new image: + + $out->paste(left => $border_width, + top => $border_height, + img => $source); + +Whether you draw the border before or after pasting the original image +depends on whether you want the border to overlap the image, for +example a semi-tranparent border drawn after pasting the source image +could overlap the edge without hiding it. + +If you want a solid border you could just fill the image before +pasting the source for simplicity: + + $out->box(filled=>1, color=>'red'); + $out->paste(left => $border_width, + top => $border_height, + img => $source); + + +=head1 TEXT + +=head2 Drawing text + +=head2 Aligning text + +=head2 Measuring text + +=head2 Word wrapping text + +=head2 Shearing (slanting) or Rotating text + +This requires that you have Imager installed with Freetype 2.x support +installed, and that the font be created using the Freetype 2.x driver, +for example: + + my $font = Imager::Font->new(file=>$fontfile, type=>'ft2'); + +First you need a transformation matrix, for shearing that could be: + + my $angle_in_radians = ...; + my $tan_angle = sin($angle_rads) / cos($angle_rads); + # shear horizontally, supply this as y instead to do it vertically + my $matrix = Imager::Matrix2d->shear(x=>$tan_angle); + +For rotation that would be: + + my $matrix = Imager::Matrix2d->rotate(radians => $angle_in_radians); + +or: + + my $matrix = Imager::Matrix2d->rotate(degrees => $angle_in_degrees); + +Feed that to the font object: + + $font->transform(matrix => $matrix); + +and draw the text as normal: + + $image->string(string => $text, + x => $where_x, + y => $where_y, + color => $color, + font => $font); + +See samples/slant_text.pl for a comprehensive example, including +calculating the transformed bounding box to create an image to fit the +transformed text into. + +=head1 IMAGE TRANSFORMATION + +=head2 Shearing an image + +=head2 Convert to grayscale + +To convert an RGB image to a grayscale image, use the convert method: + + my $grey = $image->convert(preset => 'gray'); + +convert() returns a new image. + +See: L<Imager::Transformations/"Color transformations"> + +=head1 METADATA + +=head2 Image format + +When Imager reads a file it does a magic number check to determine the +file type, so "foo.png" could actually be a GIF image, and Imager will +read it anyway. + +You can check the actual format of the image by looking at the +C<i_format> tag. + + my $format = $image->tags(name=>'i_format'); + +=head2 Image spatial resolution + +Most image file formats store information about the physical size of +the pixels, though in some cases that information isn't useful. + +Imager stores this information in the tags C<i_xres> and C<i_yres>, +and this is always stored in dots per inch. + +Some formats, including TIFF and JPEG allow you to change the units +spatial resolution information is stored in, if you set the tag that +changes this the Imager will convert C<i_xres> and C<i_yres> to those +units when it writes the file. + +For example to set the resolution to 300 dpi: + + $image->settag(name => 'i_xres', value => 300); + $image->settag(name => 'i_yres', value => 300); + +If you want the file format to store the resolution in some other +unit, for example you can write a TIFF file that stores the resolution +in pixels per centimeter, you would do: + + # 150 pixels/cm + $image->settag(name => 'i_xres', value => 150 * 2.54); + $image->settag(name => 'i_yres', value => 150 * 2.54); + $image->settag(name => 'tiff_resolutionunit', value => 3); + +Keywords: DPI + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 SEE ALSO + +L<Imager>, L<Imager::Files>, L<Imager::Draw>. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/CountColor.pm b/Master/tlpkg/tlperl0/lib/Imager/CountColor.pm new file mode 100755 index 00000000000..514bc7f9526 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/CountColor.pm @@ -0,0 +1,57 @@ +package Imager::CountColor; +use strict; +use Imager; +use vars qw($VERSION @ISA @EXPORT_OK); +require Exporter; +@EXPORT_OK = 'count_color'; + +BEGIN { + $VERSION = "0.01"; + @ISA = qw(Exporter); + + eval { + require XSLoader; + XSLoader::load('Imager::CountColor', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::CountColor $VERSION; + }; +} + +1; + +__END__ + +=head1 NAME + +Imager::CountColor - demonstrates writing a simple function using Imager. + +=head1 SYNOPSIS + + use Imager; + use Imager::CountColor; + my $im = Imager->new(...); # some Imager image + ...; # some sort of manipulation + print count_color($im, $color_object); + +=head1 DESCRIPTION + +This module is a simple demonstration of how to create an XS module +that works with Imager objects. + +You may want to copy the source for this module as a start. + +=head1 SEE ALSO + +Imager, Imager::Filter::DynTest + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=cut + + + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Draw.pod b/Master/tlpkg/tlperl0/lib/Imager/Draw.pod new file mode 100755 index 00000000000..c907627f6e1 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Draw.pod @@ -0,0 +1,1165 @@ +=head1 NAME + +Imager::Draw - Draw primitives to images + +=head1 SYNOPSIS + + use Imager; + use Imager::Fill; + + $img = ...; + $blue = Imager::Color->new( 0, 0, 255 ); + $fill = Imager::Fill->new(hatch=>'stipple'); + + $img->line(color=>$blue, x1=>10, x2=>100, + y1=>20, y2=>50, aa=>1, endp=>1 ); + + $img->polyline(points=>[[$x0,$y0], [$x1,$y1], [$x2,$y2]], + color=>$blue); + $img->polyline(x=>[$x0,$x1,$x2], y=>[$y0,$y1,$y2], aa=>1); + + $img->box(color=> $blue, xmin=> 10, ymin=>30, + xmax=>200, ymax=>300, filled=>1); + $img->box(fill=>$fill); + + $img->arc(color=>$blue, r=>20, x=>200, y=>100, + d1=>10, d2=>20 ); + + $img->circle(color=>$blue, r=>50, x=>200, y=>100); + + $img->polygon(points=>[[$x0,$y0], [$x1,$y1], [$x2,$y2]], + color=>$blue); + + $img->polygon(x=>[$x0,$x1,$x2], y=>[$y0,$y1,$y2]); + + $img->flood_fill(x=>50, y=>50, color=>$color); + + $img->setpixel(x=>50, y=>70, color=>$color); + + $img->setpixel(x=>[ 50, 60, 70 ], y=>[20, 30, 40], color=>$color); + + my $color = $img->getpixel(x=>50, y=>70); + + my @colors = $img->getpixel(x=>[ 50, 60, 70 ], y=>[20, 30, 40]); + + # drawing text + my $font = Imager::Font->new(...) or die; + $img->string(x => 50, y => 70, + font => $font, + string => "Hello, World!", + color => 'red', + size => 30, + aa => 1); + + # bottom right-hand corner of the image + $img->align_string(x => $img->getwidth() - 1, + y => $img->getheight() - 1, + halign => 'right', + valign => 'bottom', + string => 'Imager', + font => $font, + size => 12); + + # low-level functions + my @colors = $img->getscanline(y=>50, x=>10, width=>20); + + $img->setscanline(y=>60, x=>20, pixels=>\@colors); + + my @samples = $img->getsamples(y=>50, x=>10, width=>20, + channels=>[ 2, 0 ]); + +=head1 DESCRIPTION + +It is possible to draw with graphics primitives onto images. Such +primitives include boxes, arcs, circles, polygons and lines. The +coordinate system in Imager has the origin C<(0,0)> in the upper left +corner of an image with co-ordinates increasing to the right and +bottom. For non antialiasing operation all coordinates are rounded +towards the nearest integer. For antialiased operations floating +point coordinates are used. + +Drawing is assumed to take place in a coordinate system of infinite +resolution. This is the typical convention and really only matters when +it is necessary to check for off-by-one cases. Typically it's usefull to +think of C<(10, 20)> as C<(10.00, 20.00)> and consider the consiquences. + +=head2 Color Parameters + +X<color parameters>The C<color> parameter for any of the drawing +methods can be an L<Imager::Color> object, a simple scalar that +Imager::Color can understand, a hashref of parameters that +Imager::Color->new understands, or an arrayref of red, green, blue +values, for example: + + $image->box(..., color=>'red'); + $image->line(..., color=>'#FF0000'); + $image->flood_fill(..., color=>[ 255, 0, 255 ]); + +=head2 Fill Parameters + +X<fill parameters>All filled primitives, i.e. C<arc()>, C<box()>, +C<circle()>, C<polygon()> and the C<flood_fill()> method can take a +C<fill> parameter instead of a C<color> parameter which can either be +an Imager::Fill object, or a reference to a hash containing the +parameters used to create the fill, for example: + + $image->box(..., fill=>{ hatch => 'check1x1' }); + my $fillimage = Imager->new; + $fillimage->read(file=>$somefile) or die; + $image->flood_fill(..., fill=>{ image=>$fillimage }); + +Currently you can create opaque or transparent plain color fills, +hatched fills, image based fills and fountain fills. See +L<Imager::Fill> for more information. + +=head2 List of primitives + +=over + +=item line + + $img->line(color=>$green, x1=>10, x2=>100, + y1=>20, y2=>50, aa=>1, endp=>1 ); + +X<line method>Draws a line from (x1,y1) to (x2,y2). The endpoint +(x2,y2) is drawn by default. If endp of 0 is specified then the +endpoint will not be drawn. If C<aa> is set then the line will be +drawn antialiased. The I<antialias> parameter is still available for +backwards compatibility. + +Parameters: + +=over + +=item * + +x1, y1 - starting point of the line. Required. + +=item * + +x2, y2 - end point of the line. Required. + +=item * + +color - the color of the line. See L<"Color Parameters">. Default: +black. + +=item * + +endp - if zero the end point of the line is not drawn. Default: 1 - +the end point is drawn. This is useful to set to 0 when drawning a +series of connected lines. + +=item * + +aa - if true the line is drawn anti-aliased. Default: 0. + +=back + +=item polyline + + $img->polyline(points=>[[$x0,$y0],[$x1,$y1],[$x2,$y2]],color=>$red); + $img->polyline(x=>[$x0,$x1,$x2], y=>[$y0,$y1,$y2], aa=>1); + +X<polyline method>Polyline is used to draw multilple lines between a +series of points. The point set can either be specified as an +arrayref to an array of array references (where each such array +represents a point). The other way is to specify two array +references. + +The I<antialias> parameter is still available for backwards compatibility. + +=over + +=item * + +points - a reference to an array of references to arrays containing +the co-ordinates of the points in the line, for example: + + my @points = ( [ 0, 0 ], [ 100, 0 ], [ 100, 100 ], [ 0, 100 ] ); + $img->polyline(points => \@points); + +=item * + +x, y - each is an array of x or y ordinates. This is an alternative +to supplying the C<points> parameter. + + # same as the above points example + my @x = ( 0, 100, 100, 0 ); + my @y = ( 0, 0, 100, 100 ); + $img->polyline(x => \@x, y => \@y); + +=item * + +color - the color of the line. See L<"Color Parameters">. Default: +black. + +=item * + +aa - if true the line is drawn anti-aliased. Default: 0. Can also be +supplied as C<antialias> for backward compatibility. + +=back + +=item box + + $blue = Imager::Color->new( 0, 0, 255 ); + $img->box(color => $blue, xmin=>10, ymin=>30, xmax=>200, ymax=>300, + filled=>1); + +X<box method>If any of the edges of the box are ommited it will snap +to the outer edge of the image in that direction. If C<filled> is +ommited the box is drawn as an outline. Instead of a color it is +possible to use a C<fill> pattern: + + $fill = Imager::Fill->new(hatch=>'stipple'); + $img->box(fill=>$fill); # fill entire image with a given fill pattern + + $img->box(xmin=>10, ymin=>30, xmax=>150, ymax=>60, + fill => { hatch=>'cross2' }); + +Also if a color is omitted a color with (255,255,255,255) is used +instead. [NOTE: This may change to use C<$img-E<gt>fgcolor()> in the future]. + +Box does not support fractional coordinates yet. + +Parameters: + +=over + +=item * + +xmin - left side of the box. Default: 0 (left edge of the image) + +=item * + +ymin - top side of the box. Default: 0 (top edge of the image) + +=item * + +xmax - right side of the box. Default: $img->getwidth-1. (right edge +of the image) + +=item * + +ymax - bottom side of the box. Default: $img->getheight-1. (bottom +edge of the image) + +Note: xmax and ymax are I<inclusive> - the number of pixels drawn for +a filled box is (xmax-xmin+1) * (ymax-ymin+1). + +=item * + +box - a reference to an array of (left, top, right, bottom) +co-ordinates. This is an alternative to supplying xmin, ymin, xmax, +ymax and overrides their values. + +=item * + +color - the color of the line. See L<"Color Parameters">. Default: +white. This is ignored if the filled parameter + +=item * + +filled - if non-zero the box is filled with I<color> instead of +outlined. Default: an outline is drawn. + +=item * + +fill - the fill for the box. If this is supplied then the box will be +filled. See L<"Fill Parameters">. + +=back + +=item arc + + $img->arc(color=>$red, r=>20, x=>200, y=>100, d1=>10, d2=>20 ); + +This creates a filled red arc with a 'center' at (200, 100) and spans +10 degrees and the slice has a radius of 20. [NOTE: arc has a BUG in +it right now for large differences in angles.] +It's also possible to supply a C<fill> parameter. + +Parameters: + +=over + +=item * + +x, y - center of the filled arc. Default: center of the image. + +=item * + +r - radius of the arc. Default: 1/3 of min(image height, image width). + +=item * + +d1 - starting angle of the arc, in degrees. Default: 0 + +=item * + +d2 - ending angle of the arc, in degrees. Default: 361. + +=item * + +color - the color of the filled arc. See L<"Color Parameters">. +Default: white. Overridden by C<fill>. + +=item * + +fill - the fill for the filled arc. See L<"Fill Parameters"> + +=item * + +aa - if true the filled arc is drawn anti-aliased. Default: false. + +Anti-aliased arc() is experimental for now, I'm not entirely happy +with the results in some cases. + +=back + + # arc going through angle zero: + $img->arc(d1=>320, d2=>40, x=>100, y=>100, r=>50, color=>'blue'); + + # complex fill arc + $img->arc(d1=>135, d2=>45, x=>100, y=>150, r=>50, + fill=>{ solid=>'red', combine=>'diff' }); + +=item circle + + $img->circle(color=>$green, r=>50, x=>200, y=>100, aa=>1, filled=>1); + +This creates an antialiased green circle with its center at (200, 100) +and has a radius of 50. It's also possible to supply a C<fill> parameter +instead of a color parameter. + + $img->circle(r => 50, x=> 150, y => 150, fill=>{ hatch => 'stipple' }); + +The circle is always filled but that might change, so always pass a +filled=>1 parameter if you want it to be filled. + +=over + +=item * + +x, y - center of the filled circle. Default: center of the image. + +=item * + +r - radius of the circle. Default: 1/3 of min(image height, image width). + +=item * + +color - the color of the filled circle. See L<"Color Parameters">. +Default: white. Overridden by C<fill>. + +=item * + +fill - the fill for the filled circle. See L<"Fill Parameters"> + +=item * + +aa - if true the filled circle is drawn anti-aliased. Default: false. + +=back + +=item polygon + + $img->polygon(points=>[[$x0,$y0],[$x1,$y1],[$x2,$y2]],color=>$red); + $img->polygon(x=>[$x0,$x1,$x2], y=>[$y0,$y1,$y2], fill=>$fill); + +Polygon is used to draw a filled polygon. Currently the polygon is +always drawn antialiased, although that will change in the future. +Like other antialiased drawing functions its coordinates can be +specified with floating point values. As with other filled shapes +it's possible to use a C<fill> instead of a color. + +=over + +=item * + +points - a reference to an array of references to arrays containing +the co-ordinates of the points in the line, for example: + + my @points = ( [ 0, 0 ], [ 100, 0 ], [ 100, 100 ], [ 0, 100 ] ); + $img->polygon(points => \@points); + +=item * + +x, y - each is an array of x or y ordinates. This is an alternative +to supplying the C<points> parameter. + + # same as the above points example + my @x = ( 0, 100, 100, 0 ); + my @y = ( 0, 0, 100, 100 ); + $img->polygon(x => \@x, y => \@y); + +=item * + +color - the color of the filled polygon. See L<"Color Parameters">. +Default: black. Overridden by C<fill>. + +=item * + +fill - the fill for the filled circle. See L<"Fill Parameters"> + +=back + +=item flood_fill + +X<flood_fill>You can fill a region that all has the same color using +the flood_fill() method, for example: + + $img->flood_fill(x=>50, y=>50, color=>$color); + +will fill all regions the same color connected to the point (50, 50). + +Alternatively you can fill a region limited by a given border color: + + # stop at the red border + $im->flood_fill(x=>50, y=>50, color=>$color, border=>"red"); + +You can also fill with a complex fill: + + $img->flood_fill(x=>50, y=>50, fill=>{ hatch=>'cross1x1' }); + +Parameters: + +=over + +=item * + +x, y - the start point of the fill. + +=item * + +color - the color of the filled area. See L<"Color Parameters">. +Default: white. Overridden by C<fill>. + +=item * + +fill - the fill for the filled area. See L<"Fill Parameters"> + +=item * + +border - the border color of the region to be filled. If this +parameter is supplied flood_fill() will stop when it finds this color. +If this is not supplied then a normal fill is done. C<border> can be +supplied as a L<"Color Parameter">. + +=back + +=item setpixel + + $img->setpixel(x=>50, y=>70, color=>$color); + $img->setpixel(x=>[ 50, 60, 70 ], y=>[20, 30, 40], color=>$color); + +setpixel() is used to set one or more individual pixels. + +Parameters: + +=over + +=item * + +x, y - either integers giving the co-ordinates of the pixel to set or +array references containing a set of pixels to be set. + +=item * + +color - the color of the pixels drawn. See L<"Color Parameters">. +Default: white. + +=back + +When called with array parameters, returns the number of pixels +successfully set, or false if none. + +When called with scalars for x and y, return $img on success, false on +failure. + +=item getpixel + + my $color = $img->getpixel(x=>50, y=>70); + my @colors = $img->getpixel(x=>[ 50, 60, 70 ], y=>[20, 30, 40]); + my $colors_ref = $img->getpixel(x=>[ 50, 60, 70 ], y=>[20, 30, 40]); + +getpixel() is used to retrieve one or more individual pixels. + +For either method you can supply a single set of co-ordinates as +scalar x and y parameters, or set each to an arrayref of ordinates. + +When called with arrays, getpixel() will return a list of colors in +list context, and an arrayref in scalar context. + +To receive floating point colors from getpixel, set the C<type> +parameter to 'float'. + +Parameters: + +=over + +=item * + +x, y - either integers giving the co-ordinates of the pixel to set or +array references containing a set of pixels to be set. + +=item * + +type - the type of color object to return, either C<'8bit'> for +Imager::Color objects or C<'float'> for Imager::Color::Float objects. +Default: C<'8bit'>. + +=back + +=item string + + my $font = Imager::Font->new(file=>"foo.ttf"); + $img->string(x => 50, y => 70, + string => "Hello, World!", + font => $font, + size => 30, + aa => 1, + color => 'white'); + +Draws text on the image. + +Parameters: + +=over + +=item * + +x, y - the point to draw the text from. If C<align> is 0 this is the +top left of the string. If C<align> is 1 (the default) then this is +the left of the string on the baseline. Required. + +=item * + +string - the text to draw. Required unless you supply the C<text> +parameter. + +=item * + +font - an L<Imager::Font> object representing the font to draw the +text with. Required. + +=item * + +aa - if non-zero the output will be anti-aliased. Default: the value +set in Imager::Font->new() or 0 if not set. + +=item * + +align - if non-zero the point supplied in (x,y) will be on the +base-line, if zero then (x,y) will be at the top-left of the string. + +ie. if drawing the string "yA" and align is 0 the point (x,y) will +aligned with the top of the A. If align is 1 (the default) it will be +aligned with the baseline of the font, typically bottom of the A, +depending on the font used. + +Default: the value set in Imager::Font->new, or 1 if not set. + +=item * + +channel - if present, the text will be written to the specified +channel of the image and the color parameter will be ignore. + +=item * + +color - the color to draw the text in. Default: the color supplied to +Imager::Font->new, or red if none. + +=item * + +size - the point size to draw the text at. Default: the size supplied +to Imager::Font->new, or 15. + +=item * + +sizew - the width scaling to draw the text at. Default: the value of +C<size>. + +=item * + +utf8 - for drivers that support it, treat the string as UTF8 encoded. +For versions of perl that support Unicode (5.6 and later), this will +be enabled automatically if the C<string> parameter is already a UTF8 +string. See L<Imager::Font/"UTF8"> for more information. + +=item * + +vlayout - for drivers that support it, draw the text vertically. +Note: I haven't found a font that has the appropriate metrics yet. + +=item * + +text - alias for the C<string> parameter. + +=back + +On error, string() returns false and you can use $img->errstr to get +the reason for the error. + +=item align_string + +Draws text aligned around a point on the image. + + # "Hello" centered at 100, 100 in the image. + my ($left, $top, $right, $bottom) = + $img->align_string(string=>"Hello", + x=>100, y=>100, + halign=>'center', valign=>'center', + font=>$font); + +Parameters: + +=over + +=item * + +x, y - the point to draw the text from. If C<align> is 0 this is the +top left of the string. If C<align> is 1 (the default) then this is +the left of the string on the baseline. Required. + +=item * + +string - the text to draw. Required unless you supply the C<text> parameter. + +=item * + +font - an L<Imager::Font> object representing the font to draw the +text with. Required. + +=item * + +aa - if non-zero the output will be anti-aliased + +=item * + +valign - vertical alignment of the text against (x,y) + +=over + +=item * + +top - Point is at the top of the text. + +=item * + +bottom - Point is at the bottom of the text. + +=item * + +baseline - Point is on the baseline of the text. This is the default. + +=item * + +center - Point is vertically centered within the text. + +=back + +=item * + +halign - horizontal alignment of the text against (x,y) + +=over + +=item * + +left - The point is at the left of the text. This is the default. + +=item * + +start - The point is at the start point of the text. + +=item * + +center - The point is horizontally centered within the text. + +=item * + +right - The point is at the right end of the text. + +=item * + +end - The point is at the end point of the text. + +=back + +=item * + +channel - if present, the text will be written to the specified +channel of the image and the color parameter will be ignore. + +=item * + +color - the color to draw the text in. Default: the color supplied to +Imager::Font->new, or red if none. + +=item * + +size - the point size to draw the text at. Default: the size supplied +to Imager::Font->new, or 15. + +=item * + +sizew - the width scaling to draw the text at. Default: the value of +C<size>. + +=item * + +utf8 - for drivers that support it, treat the string as UTF8 encoded. +For versions of perl that support Unicode (5.6 and later), this will +be enabled automatically if the C<string> parameter is already a UTF8 +string. See L<Imager::Font/"UTF8"> for more information. + +=item * + +vlayout - for drivers that support it, draw the text vertically. +Note: I haven't found a font that has the appropriate metrics yet. + +=item * + +text - alias for the C<string> parameter. + +=back + +On success returns a list of bounds of the drawn text, in the order +left, top, right, bottom. + +On error, align_string() returns an empty list and you can use +$img->errstr to get the reason for the error. + +=item setscanline + +Set all or part of a horizontal line of pixels to an image. This +method is most useful in conjuction with L</getscanline>. + +The parameters you can pass are: + +=over + +=item * + +y - vertical position of the scanline. This parameter is required. + +=item * + +x - position to start on the scanline. Default: 0 + +=item * + +pixels - either a reference to an array containing Imager::Color +objects, an reference to an array containing Imager::Color::Float +objects or a scalar containing packed color data. + +If C<type> is C<index> then this can either be a reference to an array +of palette color indexes or a scalar containing packed indexes. + +See L</"Packed Color Data"> for information on the format of packed +color data. + +=item * + +type - the type of pixel data supplied. If you supply an array +reference of object then this is determined automatically. If you +supply packed color data this defaults to '8bit', if your data is +packed floating point color data then set this to 'float'. + +You can use float or 8bit samples with any image. + +If this is 'index' then pixels should be either an array of palette +color indexes or a packed string of color indexes. + +=back + +Returns the number of pixels set. + +Each of the following sets 5 pixels from (5, 10) through (9, 10) to +blue, red, blue, red, blue: + + my $red_color = Imager::Color->new(255, 0, 0); + my $blue_color = Imager::Color->new(0, 0, 255); + + $image->setscanline(y=>10, x=>5, pixels=> + [ ($blue_color, $red_color) x 2, $blue_color ]); + + # use floating point color instead, for 16-bit plus images + my $red_colorf = Imager::Color::Float->new(1.0, 0, 0); + my $blue_colorf = Imager::Color::Float->new(0, 0, 1.0); + + $image->setscanline(y=>10, x=>5, pixels=> + [ ($blue_colorf, $red_colorf) x 2, $blue_colorf ]); + + # packed 8-bit data + $image->setscanline(y=>10, x=>5, pixels=> + pack("C*", ((0, 0, 255, 255), (255, 0, 0, 255)) x 2, + (0, 0, 255, 255))); + + # packed floating point samples + $image->setscanline(y=>10, x=>5, type=>'float', pixels=> + pack("d*", ((0, 0, 1.0, 1.0), (1.0, 0, 0, 1.0)) x 2, + (0, 0, 1.0, 1.0))); + + +Copy even rows from one image to another: + + for (my $y = 0; $y < $im2->getheight; $y+=2) { + $im1->setscanline(y=>$y, + pixels=>scalar($im2->getscanline(y=>$y))); + } + + +Set the blue channel to 0 for all pixels in an image. This could be +done with convert too: + + for my $y (0..$im->getheight-1) { + my $row = $im->getscanline(y=>$y); + $row =~ s/(..).(.)/$1\0$2/gs; + $im->setscanline(y=>$y, pixels=>$row); + } + +=item getscanline + +Read all or part of a horizontal line of pixels from an image. This +method is most useful in conjunction with L</setscanline>. + +The parameters you can pass are: + +=over + +=item * + +y - vertical position of the scanline. This parameter is required. + +=item * + +x - position to start on the scanline. Default: 0 + +=item * + +width - number of pixels to read. Default: $img->getwidth - x + +=item * + +type - the type of pixel data to return. Default: C<8bit>. + +Permited values are C<8bit> and C<float> and C<index>. + +=back + +In list context this method will return a list of Imager::Color +objects when I<type> is C<8bit>, or a list of Imager::Color::Float +objects when I<type> if C<float>, or a list of integers when I<type> +is C<index>. + +In scalar context this returns a packed 8-bit pixels when I<type> is +C<8bit>, or a list of packed floating point pixels when I<type> is +C<float>, or packed palette color indexes when I<type> is C<index>. + +The values of samples for which the image does not have channels is +undefined. For example, for a single channel image the values of +channels 1 through 3 are undefined. + +Check image for a given color: + + my $found; + YLOOP: for my $y (0..$img->getheight-1) { + my @colors = $img->getscanline(y=>$y); + for my $color (@colors) { + my ($red, $green, $blue, $alpha) = $color->rgba; + if ($red == $test_red && $green == $test_green && $blue == $test_blue + && $alpha == $test_alpha) { + ++$found; + last YLOOP; + } + } + } + +Or do it using packed data: + + my $found; + my $test_packed = pack("CCCC", $test_red, $test_green, $test_blue, + $test_alpha); + YLOOP: for my $y (0..$img->getheight-1) { + my $colors = $img->getscanline(y=>$y); + while (length $colors) { + if (substr($colors, 0, 4, '') eq $test_packed) { + ++$found; + last YLOOP; + } + } + } + +Some of the examples for L</setscanline> for more examples. + +=item getsamples + +Read specified channels from all or part of a horizontal line of +pixels from an image. + +The parameters you can pass are: + +=over + +=item * + +y - vertical position of the scanline. This parameter is required. + +=item * + +x - position to start on the scanline. Default: 0 + +=item * + +width - number of pixels to read. Default: $img->getwidth - x + +=item * + +type - the type of sample data to return. Default: C<8bit>. + +Permited values are C<8bit> and C<float>. + +As of Imager 0.61 this can be C<16bit> only for 16 bit images. + +=item * + +channels - a reference to an array of channels to return, where 0 is +the first channel. Default: C<< [ 0 .. $self->getchannels()-1 ] >> + +=item * + +target - if an array reference is supplied in target then the samples +will be stored here instead of being returned. + +=item * + +offset - the offset within the array referenced by I<target> + +=back + +In list context this will return a list of integers between 0 and 255 +inclusive when I<type> is C<8bit>, or a list of floating point numbers +between 0.0 and 1.0 inclusive when I<type> is C<float>. + +In scalar context this will return a string of packed bytes, as with +C< pack("C*", ...) > when I<type> is C<8bit> or a string of packed +doubles as with C< pack("d*", ...) > when I<type> is C<float>. + +If the I<target> option is supplied then only a count of samples is +returned. + +Example: Check if any pixels in an image have a non-zero alpha +channel: + + my $has_coverage; + for my $y (0 .. $img->getheight()-1) { + my $alpha = $img->getsamples(y=>$y, channels=>[0]); + if ($alpha =~ /[^\0]/) { + ++$has_coverage; + last; + } + } + +Example: Convert a 2 channel grey image into a 4 channel RGBA image: + + # this could be done with convert() instead + my $out = Imager->new(xsize => $src->getwidth(), + ysize => $src->getheight(), + channels => 4); + for my $y ( 0 .. $src->getheight()-1 ) { + my $data = $src->getsamples(y=>$y, channels=>[ 0, 0, 0, 1 ]); + $out->setscanline(y=>$y, pixels=>$data); + } + +Retrieve 16-bit samples: + + if ($img->bits == 16) { + my @samples; + $img->getsamples(x => 0, y => $y, target => \@samples, type => '16bit'); + } + +=item setsamples + +This allows writing of samples back to some images. Currently this is +only supported for 16-bit/sample images. + +Parameters: + +=over + +=item * + +y - vertical position of the scanline. This parameter is required. + +=item * + +x - position to start on the scanline. Default: 0 + +=item * + +width - number of pixels to write. Default: $img->getwidth - x. The +minimum of this and the number of pixels represented by the samples +provided will be written. + +=item * + +type - the type of sample data to write. This parameter is required. + +As of Imager 0.61 this can only be C<16bit> only for 16 bit images. + +=item * + +channels - a reference to an array of channels to return, where 0 is +the first channel. Default: C<< [ 0 .. $self->getchannels()-1 ] >> + +=item * + +data - a reference to an array of samples to write. Required. + +=item * + +offset - the starting offset within the array referenced by I<data> + +=back + +Returns the number of samples written. + +=back + +=head1 Packed Color Data + +The getscanline() and setscanline() functions can work with pixels +packed into scalars. This is useful to remove the cost of creating +color objects, but should only be used when performance is an issue. + +Packed data can either be 1 byte per sample or 1 double per sample. + +Each pixel returned by getscanline() or supplied to setscanline() +contains 4 samples, even if the image has fewer then 4 channels. The +values of the extra samples as returned by getscanline() is not +specified. The extra samples passed to setscanline() are ignored. + +To produce packed 1 byte/sample pixels, use the pack C<C> template: + + my $packed_8bit_pixel = pack("CCCC", $red, $blue, $green, $alpha); + +To produce packed double/sample pixels, use the pack C<d> template: + + my $packed_float_pixel = pack("dddd", $red, $blue, $green, $alpha); + +If you use a I<type> parameter of C<index> then the values are palette +color indexes, not sample values: + + my $im = Imager->new(xsize => 100, ysize => 100, type => 'paletted'); + my $black_index = $im->addcolors(colors => [ 'black' ]); + my $red_index = $im->addcolors(colors => [ 'red' ]); + # 2 pixels + my $packed_index_data = pack("C*", $black_index, $red_index); + $im->setscanline(y => $y, pixels => $packed_index_data, type => 'index'); + +=head1 Combine Types + +Some methods accept a C<combine> parameter, this can be any of the +following: + +=over + +=item none + +The fill pixel replaces the target pixel. + +=item normal + +The fill pixels alpha value is used to combine it with the target pixel. + +=item multiply + +=item mult + +Each channel of fill and target is multiplied, and the result is +combined using the alpha channel of the fill pixel. + +=item dissolve + +If the alpha of the fill pixel is greater than a random number, the +fill pixel is alpha combined with the target pixel. + +=item add + +The channels of the fill and target are added together, clamped to the range of the samples and alpha combined with the target. + +=item subtract + +The channels of the fill are subtracted from the target, clamped to be +>= 0, and alpha combined with the target. + +=item diff + +The channels of the fill are subtracted from the target and the +absolute value taken this is alpha combined with the target. + +=item lighten + +The higher value is taken from each channel of the fill and target +pixels, which is then alpha combined with the target. + +=item darken + +The higher value is taken from each channel of the fill and target +pixels, which is then alpha combined with the target. + +=item hue + +The combination of the saturation and value of the target is combined +with the hue of the fill pixel, and is then alpha combined with the +target. + +=item sat + +The combination of the hue and value of the target is combined +with the saturation of the fill pixel, and is then alpha combined with the +target. + +=item value + +The combination of the hue and value of the target is combined +with the value of the fill pixel, and is then alpha combined with the +target. + +=item color + +The combination of the value of the target is combined with the hue +and saturation of the fill pixel, and is then alpha combined with the +target. + +=back + +=over + +=item combines + +Returns a list of possible combine types. + +=back + +=head1 BUGS + +box() does not support antialiasing yet. Arc, is only filled as of +yet. Default color is not unified yet. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org>, Arnar M. Hrafnkelsson. + +=head1 SEE ALSO + +L<Imager>(3), L<Imager::Cookbook>(3) + +=head1 REVISION + +$Revision: 1667 $ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Engines.pod b/Master/tlpkg/tlperl0/lib/Imager/Engines.pod new file mode 100755 index 00000000000..42784712e67 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Engines.pod @@ -0,0 +1,558 @@ +=head1 NAME + +Imager::Engines - Programmable transformation operations + +=head1 SYNOPSIS + + use Imager; + + my %opts; + my @imgs; + my $img; + ... + + my $newimg = $img->transform( + xexpr=>'x', + yexpr=>'y+10*sin((x+y)/10)') + or die $img->errstr; + + my $newimg = Imager::transform2(\%opts, @imgs) + or die "transform2 failed: $Imager::ERRSTR"; + + my $newimg = $img->matrix_transform( + matrix=>[ -1, 0, $img->getwidth-1, + 0, 1, 0, + 0, 0, 1 ]); + + +=head1 DESCRIPTION + +=head2 transform + +The C<transform()> function can be used to generate spatial warps and +rotations and such effects. It only operates on a single image and +its only function is to displace pixels. + +It can be given the operations in postfix notation or the module +Affix::Infix2Postfix can be used to generate postfix code from infix +code. Look in the test case t/t55trans.t for an example. + +C<transform()> needs expressions (or opcodes) that determine the +source pixel for each target pixel. Source expressions are infix +expressions using any of the +, -, *, / or ** binary operators, the - +unary operator, ( and ) for grouping and the sin() and cos() +functions. The target pixel is input as the variables x and y. + +You specify the x and y expressions as xexpr and yexpr respectively. +You can also specify opcodes directly, but that's magic deep enough +that you can look at the source code. + +Note: You can still use the transform() function, but the transform2() +function is just as fast and is more likely to be enhanced and +maintained. + + $new_img=$img->transform(xexpr=>'x',yexpr=>'y+10*sin((x+y)/10)') + + $new_img=$img->transform(xexpr=>'x+0.1*y+5*sin(y/10.0+1.57)', + yexpr=>'y+10*sin((x+y-0.785)/10)') + +=head2 transform2 + +Imager also supports a C<transform2()> class method which allows you +perform a more general set of operations, rather than just specifying +a spatial transformation as with the transform() method, you can also +perform colour transformations, image synthesis and image +combinations from multiple source images. + +C<transform2()> takes an reference to an options hash, and a list of +images to operate one (this list may be empty): + + my %opts; + my @imgs; + ... + my $img = Imager::transform2(\%opts, @imgs) + or die "transform2 failed: $Imager::ERRSTR"; + +The options hash may define a transformation function, and optionally: + +=over + +=item * + +width - the width of the image in pixels. If this isn't supplied the +width of the first input image is used. If there are no input images +an error occurs. + +=item * + +height - the height of the image in pixels. If this isn't supplied +the height of the first input image is used. If there are no input +images an error occurs. + +=item * + +constants - a reference to hash of constants to define for the +expression engine. Some extra constants are defined by Imager + +=item * + +channels - the number of channels in the output image. If this isn't +supplied a 3 channel image will be created. + +=back + +The tranformation function is specified using either the expr or +rpnexpr member of the options. + +=head3 Infix expressions + +You can supply infix expressions to transform 2 with the expr keyword. + + $opts{expr} = 'return getp1(w-x, h-y)' + +The 'expression' supplied follows this general grammar: + + ( identifier '=' expr ';' )* 'return' expr + +This allows you to simplify your expressions using variables. + +A more complex example might be: + + $opts{expr} = 'pix = getp1(x,y); return if(value(pix)>0.8,pix*0.8,pix)' + +Currently to use infix expressions you must have the L<Parse::RecDescent> +module installed (available from CPAN). There is also what might be a +significant delay the first time you run the infix expression parser +due to the compilation of the expression grammar. + +=head3 Postfix expressions + +You can supply postfix or reverse-polish notation expressions to +transform2() through the rpnexpr keyword. + +The parser for rpnexpr emulates a stack machine, so operators will +expect to see their parameters on top of the stack. A stack machine +isn't actually used during the image transformation itself. + +You can store the value at the top of the stack in a variable called +foo using !foo and retrieve that value again using @foo. The !foo +notation will pop the value from the stack. + +An example equivalent to the infix expression above: + + $opts{rpnexpr} = 'x y getp1 !pix @pix value 0.8 gt @pix 0.8 * @pix ifp' + +At the end of the expression there should be a single pixel value left +on the stack, which is used as the output pixel. + +=head3 Operators + +transform2() has a fairly rich range of operators. + +Each entry below includes the usage with rpnexpr, formatted as: + +=over + +I<operand> I<operand> ... B<I<operator>> -- I<result> + +=back + +If the operand or result begins with "N" it is a numeric value, if it +begins with "C" it is a color or pixel value. + +=over + +=item +, *, -, /, %, ** + +multiplication, addition, subtraction, division, remainder and +exponentiation. Multiplication, addition and subtraction can be used +on colour values too - though you need to be careful - adding 2 white +values together and multiplying by 0.5 will give you grey, not white. + +Division by zero (or a small number) just results in a large number. +Modulo zero (or a small number) results in zero. % is implemented +using fmod() so you can use this to take a value mod a floating point +value. + +rpnexpr usage: + +=over + +I<N1> I<N2> B<+> -- I<N> + +I<N1> I<N2> B<*> -- I<N> + +I<N1> I<N2> B<-> -- I<N> + +I<N1> I<N2> B</> -- I<N> + +I<N1> I<N2> B<**> -- I<N> + +I<N1> B<uminus> -- I<N> + +=back + +=item sin(N), cos(N), atan2(y,x) + +Some basic trig functions. They work in radians, so you can't just +use the hue values. + +rpnexpr usage: + +=over + +I<N> B<sin> -- I<N> + +I<N> B<cos> -- I<N> + +I<Ny> I<Nx> B<atan2> -- I<N> + +=back + +=item distance(x1, y1, x2, y2) + +Find the distance between two points. This is handy (along with +atan2()) for producing circular effects. + +rpnexpr usage: + +=over + +I<Nx1> I<Ny1> I<Nx2> I<Ny2> B<distance> -- I<N> + +=back + +=item sqrt(n) + +Find the square root. I haven't had much use for this since adding +the distance() function. + +rpnexpr usage: + +=over + +I<N> B<sqrt> -- I<N> + +=back + +=item abs(n) + +Find the absolute value. + +rpnexpr usage: + +=over + +I<N> B<abs> -- I<N> + +=back + +=item getp1(x,y), getp2(x,y), getp3(x, y) + +Get the pixel at position (x,y) from the first, second or third image +respectively. I may add a getpn() function at some point, but this +prevents static checking of the instructions against the number of +images actually passed in. + +rpnexpr usage: + +=over + +I<Nx> I<Ny> B<getp1> -- I<C> + +I<Nx> I<Ny> B<getp2> -- I<C> + +I<Nx> I<Ny> B<getp3> -- I<C> + +=back + +=item value(c), hue(c), sat(c), hsv(h,s,v), hsva(h,s,v,alpha) + +Separates a colour value into it's value (brightness), hue (colour) +and saturation elements. Use hsv() to put them back together (after +suitable manipulation), or hsva() to include a tranparency value. + +rpnexpr usage: + +=over + +I<C> B<value> -- I<N> + +I<C> B<hue> -- I<N> + +I<C> B<sat> -- I<N> + +I<Nh> I<Ns> I<Nv> B<hsv> -- I<C> + +I<Nh> I<Ns> I<Nv> I<Na> B<hsva> -- I<C> + +=back + +=item red(c), green(c), blue(c), rgb(r,g,b), rgba(r,g,b,a) + +Separates a colour value into it's red, green and blue colours. Use +rgb(r,g,b) to put it back together, or rgba() to include a +transparency value. + +rpnexpr usage: + +=over + +I<C> B<red> -- I<N> + +I<C> B<green> -- I<N> + +I<C> B<blue> -- I<N> + +I<Nr> I<Ng> I<Nb> B<rgb> -- I<C> + +I<Nr> I<Ng> I<Nb> I<Na> B<rgba> -- I<C> + +=back + +=item alpha(c) + +Retrieve the alpha value from a colour. + +rpnexpr usage: + +=over + +I<C> B<alpha> -- I<N> + +=back + +=item int(n) + +Convert a value to an integer. Uses a C int cast, so it may break on +large values. + +rpnexpr usage: + +=over + +I<N> B<int> -- I<N> + +=back + +=item if(cond,ntrue,nfalse), if(cond,ctrue,cfalse) + +A simple (and inefficient) if function. + +rpnexpr usage: + +=over + +I<Ncond> I<N-true-result> I<N-false-result> B<if> -- I<N> + +I<Ncond> I<C-true-result> I<C-false-result> B<if> -- I<C> + +I<Ncond> I<C-true-result> I<C-false-result> B<ifp> -- I<C> + +=back + +=item <=,<,==,>=,>,!= + +Relational operators (typically used with if()). Since we're working +with floating point values the equalities are 'near equalities' - an +epsilon value is used. + +=over + +I<N1> I<N2> B<< <= >> -- I<N> + +I<N1> I<N2> B<< < >> -- I<N> + +I<N1> I<N2> B<< >= >> -- I<N> + +I<N1> I<N2> B<< > >> -- I<N> + +I<N1> I<N2> B<< == >> -- I<N> + +I<N1> I<N2> B<< != >> -- I<N> + +=back + +=item &&, ||, not(n) + +Basic logical operators. + +rpnexpr usage: + +=over + +I<N1> I<N2> B<and> -- I<N> + +I<N1> I<N2> B<or> -- I<N> + +I<N> B<not> -- I<N> + +=back + +=item log(n), exp(n) + +Natural logarithm and exponential. + +rpnexpr usage: + +=over + +I<N> B<log> -- I<N> + +I<N> B<exp> -- I<N> + +=back + +=item det(a, b, c, d) + +Calculate the determinant of the 2 x 2 matrix; + + a b + c d + +rpnexpr usage: + +=over + +I<Na> I<Nb> I<Nc> I<Nd> B<det> -- I<N> + +=back + +=back + +=head3 Constants + +transform2() defines the following constants: + +=over + +=item pi + +The classical constant. + +=item w + +=item h + +The width and height of the output image. + +=item cx + +=item cy + +The center of the output image. + +=item wI<image number> + +=item hI<image number> + +The width and height of each of the input images, C<w1> is the width +of the first input image and so on. + +=item cxI<image number> + +=item cyI<image number> + +The center of each of the input images, (C<cx1>, C<cy1>) is the center +of the first input image and so on. + +=back + +A few examples: + +=over + +=item rpnexpr=>'x 25 % 15 * y 35 % 10 * getp1 !pat x y getp1 !pix @pix sat 0.7 gt @pat @pix ifp' + +tiles a smaller version of the input image over itself where the +colour has a saturation over 0.7. + +=item rpnexpr=>'x 25 % 15 * y 35 % 10 * getp1 !pat y 360 / !rat x y getp1 1 @rat - pmult @pat @rat pmult padd' + +tiles the input image over itself so that at the top of the image the +full-size image is at full strength and at the bottom the tiling is +most visible. + +=item rpnexpr=>'x y getp1 !pix @pix value 0.96 gt @pix sat 0.1 lt and 128 128 255 rgb @pix ifp' + +replace pixels that are white or almost white with a palish blue + +=item rpnexpr=>'x 35 % 10 * y 45 % 8 * getp1 !pat x y getp1 !pix @pix sat 0.2 lt @pix value 0.9 gt and @pix @pat @pix value 2 / 0.5 + pmult ifp' + +Tiles the input image overitself where the image isn't white or almost +white. + +=item rpnexpr=>'x y 160 180 distance !d y 180 - x 160 - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a2 180 * 3.1416 / 1 @a2 sin 1 + 2 / hsv' + +Produces a spiral. + +=item rpnexpr=>'x y 160 180 distance !d y 180 - x 160 - atan2 !a @d 10 / @a + 3.1416 2 * % !a2 @a 180 * 3.1416 / 1 @a2 sin 1 + 2 / hsv' + +A spiral built on top of a colour wheel. + +=back + +For details on expression parsing see L<Imager::Expr>. For details on +the virtual machine used to transform the images, see +L<Imager::regmach.pod>. + + # generate a colorful spiral + # requires that Parse::RecDescent be installed + my $newimg = Imager::transform2({ + width => 160, height=>160, + expr => <<EOS + dist = distance(x, y, w/2, h/2); + angle = atan2(y-h/2, x-w/2); + angle2 = (dist / 10 + angle) % ( 2 * pi ); + return hsv(angle*180/pi, 1, (sin(angle2)+1)/2); + EOS + }); + + # replace green portions of an image with another image + my $newimg = Imager::transform2({ + rpnexpr => <<EOS + x y getp2 !pat # used to replace green portions + x y getp1 !pix # source with "green screen" + @pix red 10 lt @pix blue 10 lt && # low blue and red + @pix green 254 gt && # and high green + @pat @pix ifp + EOS + }, $source, $background); + +=head2 Matrix Transformations + +=over + +=item matrix_transform + +Rather than having to write code in a little language, you can use a +matrix to perform affine transformations, using the matrix_transform() +method: + + my $newimg = $img->matrix_transform(matrix=>[ -1, 0, $img->getwidth-1, + 0, 1, 0, + 0, 0, 1 ]); + +By default the output image will be the same size as the input image, +but you can supply the xsize and ysize parameters to change the size. + +Rather than building matrices by hand you can use the Imager::Matrix2d +module to build the matrices. This class has methods to allow you to +scale, shear, rotate, translate and reflect, and you can combine these +with an overloaded multiplication operator. + +WARNING: the matrix you provide in the matrix operator transforms the +co-ordinates within the B<destination> image to the co-ordinates +within the I<source> image. This can be confusing. + +You can also supply a C<back> argument which acts as a background +color for the areas of the image with no samples available (outside +the rectangle of the source image.) This can be either an +Imager::Color or Imager::Color::Float object. This is B<not> mixed +transparent pixels in the middle of the source image, it is B<only> +used for pixels where there is no corresponding pixel in the source +image. + +=back + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Expr.pm b/Master/tlpkg/tlperl0/lib/Imager/Expr.pm new file mode 100755 index 00000000000..8730570f6ab --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Expr.pm @@ -0,0 +1,695 @@ +package Imager::Expr; + +use Imager::Regops; +use strict; +use vars qw($VERSION); + +$VERSION = "1.004"; + +my %expr_types; + +my $error; + +sub error { + shift if UNIVERSAL::isa($_[0], 'Imager::Expr'); + if (@_) { + $error = "@_"; + } + else { + return $error; + } +} + +# what else? +my %default_constants = + ( + # too many digits, better than too few + pi=>3.14159265358979323846264338327950288419716939937510582097494 + ); + +sub new { + my ($class, $opts) = @_; + + # possibly this is a very bad idea + my ($type) = grep exists $expr_types{$_}, keys %$opts; + die "Imager::Expr: No known expression type" + if !defined $type; + my $self = bless {}, $expr_types{$type}; + $self->{variables} = [ @{$opts->{variables}} ]; + $self->{constants} = { %default_constants, %{$opts->{constants} || {}} }; + $self->{ops} = $self->compile($opts->{$type}, $opts) + or return; + $self->optimize() + or return; + $self->{code} = $self->assemble() + or return; + $self; +} + +sub register_type { + my ($pack, $name) = @_; + $expr_types{$name} = $pack; +} + +sub type_registered { + my ($class, $name) = @_; + + $expr_types{$name}; +} + +sub _variables { + return @{$_[0]->{variables}}; +} + +sub code { + return $_[0]->{code}; +} + +sub nregs { + return $_[0]->{nregs}; +} + +sub cregs { + return $_[0]->{cregs}; +} + +my $numre = '[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?'; + +sub numre { + $numre; +} + +# optimize the code +sub optimize { + my ($self) = @_; + + my @ops = @{$self->{ops}}; + + # this function cannot current handle code with jumps + return 1 if grep $_->[0] =~ /^jump/, @ops; + + # optimization - common sub-expression elimination + # it's possible to fold this into the code generation - but it will wait + + my $max_opr = $Imager::Regops::MaxOperands; + my $attr = \%Imager::Regops::Attr; + my $foundops = 1; + while ($foundops) { + $foundops = 0; + my %seen; + my $index; + my @out; + while (@ops) { + my $op = shift @ops; + my $desc = join(",", @{$op}[0..$max_opr]); + if ($seen{$desc}) { + push(@out, @ops); + my $old = $op->[-1]; + my $new = $seen{$desc}; + for $op (@out) { + for my $reg (@{$op}[1..$max_opr]) { + $reg = $new if $reg eq $old; + } + } + $foundops=1; + last; + } + $seen{$desc} = $op->[-1]; + push(@out, $op); + } + @ops = @out; + } + # strength reduction + for my $op (@ops) { + # reduce division by a constant to multiplication by a constant + if ($op->[0] eq 'div' && $op->[2] =~ /^r(\d+)/ + && defined($self->{"nregs"}[$1])) { + my $newreg = @{$self->{"nregs"}}; + push(@{$self->{"nregs"}}, 1.0/$self->{"nregs"}[$1]); + $op->[0] = 'mult'; + $op->[2] = 'r'.$newreg; + } + } + $self->{ops} = \@ops; + 1; +} + +sub assemble { + my ($self) = @_; + my $attr = \%Imager::Regops::Attr; + my $max_opr = $Imager::Regops::MaxOperands; + my @ops = @{$self->{ops}}; + for my $op (@ops) { + $op->[0] = $attr->{$op->[0]}{opcode}; + for (@{$op}[1..$max_opr+1]) { s/^[rpj]// } + } + my $pack = $Imager::Regops::PackCode x (2+$Imager::Regops::MaxOperands); + + return join("", ,map { pack($pack, @$_, ) } @ops); +} + +# converts stack code to register code +sub stack_to_reg { + my ($self, @st_ops) = @_; + my @regstack; + my %nregs; + my @vars = $self->_variables(); + my @nregs = (0) x scalar(@vars); + my @cregs; + my $attr = \%Imager::Regops::Attr; + my %vars; + my %names; + my $max_opr = $Imager::Regops::MaxOperands; + @vars{@vars} = map { "r$_" } 0..$#vars; + + my @ops; + for (@st_ops) { + if (/^$numre$/) { + # combining constants makes the optimization below work + if (exists $nregs{$_}) { + push(@regstack, $nregs{$_}); + } + else { + $nregs{$_} = "r".@nregs; + push(@regstack,"r".@nregs); + push(@nregs, $_); + } + } + elsif (exists $vars{$_}) { + push(@regstack, $vars{$_}); + } + elsif (exists $attr->{$_} && length $attr->{$_}{types}) { + if (@regstack < $attr->{$_}{parms}) { + error("Imager::transform2: stack underflow on $_"); + return; + } + my @parms = splice(@regstack, -$attr->{$_}{parms}); + my $types = join("", map {substr($_,0,1)} @parms); + if ($types ne $attr->{$_}{types}) { + if (exists $attr->{$_.'p'} && $types eq $attr->{$_.'p'}{types}) { + $_ .= 'p'; + } + else { + error("Imager::transform2: Call to $_ with incorrect types"); + return; + } + } + my $result; + if ($attr->{$_}{result} eq 'r') { + $result = "r".@nregs; + push(@nregs, undef); + } + else { + $result = "p".@cregs; + push(@cregs, -1); + } + push(@regstack, $result); + push(@parms, "0") while @parms < $max_opr; + push(@ops, [ $_, @parms, $result ]); + #print "$result <- $_ @parms\n"; + } + elsif (/^!(\w+)$/) { + if (!@regstack) { + error("Imager::transform2: stack underflow with $_"); + return; + } + $names{$1} = pop(@regstack); + } + elsif (/^\@(\w+)$/) { + if (exists $names{$1}) { + push(@regstack, $names{$1}); + } + else { + error("Imager::Expr: unknown storage \@$1"); + return; + } + } + else { + error("Imager::Expr: unknown operator $_"); + return; + } + } + if (@regstack != 1) { + error("stack must have only one item at end"); + return; + } + if ($regstack[0] !~ /^p/) { + error("you must have a color value at the top of the stack at end"); + return; + } + push(@ops, [ "ret", $regstack[0], (-1) x $max_opr ]); + + $self->{"nregs"} = \@nregs; + $self->{"cregs"} = \@cregs; + + return \@ops; +} + +sub dumpops { + my $result = ''; + for my $op (@{$_[0]->{ops}}) { + $result .= "@{$op}\n"; + } + $result; +} + +# unassembles the compiled code +sub dumpcode { + my ($self) = @_; + my $code = $self->{"code"}; + my $attr = \%Imager::Regops::Attr; + my @code = unpack("${Imager::Regops::PackCode}*", $code); + my %names = map { $attr->{$_}{opcode}, $_ } keys %Imager::Regops::Attr; + my @vars = $self->_variables(); + my $result = ''; + my $index = 0; + while (my @op = splice(@code, 0, 2+$Imager::Regops::MaxOperands)) { + my $opcode = shift @op; + my $name = $names{$opcode}; + if ($name) { + $result .= "j$index: $name($opcode)"; + my @types = split //, $attr->{$name}{types}; + for my $parm (@types) { + my $reg = shift @op; + $result .= " $parm$reg"; + if ($parm eq 'r') { + if ($reg < @vars) { + $result.= "($vars[$reg])"; + } + elsif (defined $self->{"nregs"}[$reg]) { + $result .= "($self->{\"nregs\"}[$reg])"; + } + } + } + + $result .= " -> $attr->{$name}{result}$op[-1]" + if $attr->{$name}{result}; + $result .= "\n"; + } + else { + $result .= "unknown($opcode) @op\n"; + } + ++$index; + } + + $result; +} + +package Imager::Expr::Postfix; +use vars qw(@ISA); +@ISA = qw(Imager::Expr); + +Imager::Expr::Postfix->register_type('rpnexpr'); + +my %op_names = ( '+'=>'add', '-'=>'subtract', '*'=>'mult', '/' => 'div', + '%'=>'mod', '**'=>'pow' ); + +sub compile { + my ($self, $expr, $opts) = @_; + + $expr =~ s/#.*//; # remove comments + my @st_ops = split ' ', $expr; + + for (@st_ops) { + $_ = $op_names{$_} if exists $op_names{$_}; + $_ = $self->{constants}{$_} if exists $self->{constants}{$_}; + } + return $self->stack_to_reg(@st_ops); +} + +package Imager::Expr::Infix; + +use vars qw(@ISA); +@ISA = qw(Imager::Expr); +use Imager::Regops qw(%Attr $MaxOperands); + + +eval "use Parse::RecDescent;"; +__PACKAGE__->register_type('expr') if !$@; + +# I really prefer bottom-up parsers +my $grammar = <<'GRAMMAR'; + +code : assigns 'return' expr +{ $return = [ @item[1,3] ] } + +assigns : assign(s?) { $return = [ @{$item[1]} ] } + +assign : identifier '=' expr ';' +{ $return = [ @item[1,3] ] } + +expr : relation + +relation : addition (relstuff)(s?) +{ + $return = $item[1]; + for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] } + 1; +} + +relstuff : relop addition { $return = [ @item[1,2] ] } + +relop : '<=' { $return = 'le' } + | '<' { $return = 'lt' } + | '==' { $return = 'eq' } + | '>=' { $return = 'ge' } + | '>' { $return = 'gt' } + | '!=' { $return = 'ne' } + +addition : multiply (addstuff)(s?) +{ + $return = $item[1]; +# for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; } + for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] } + 1; +} +addstuff : addop multiply { $return = [ @item[1,2] ] } +addop : '+' { $return = 'add' } + | '-' { $return = 'subtract' } + +multiply : power mulstuff(s?) +{ $return = $item[1]; +# for my $op(@{$item[2]}) { $return .= " @{$op}[1,0]"; } + for my $op(@{$item[2]}) { $return = [ $op->[0], $return, $op->[1] ] } + 1; +} + +mulstuff : mulop power { $return = [ @item[1,2] ] } +mulop : '*' { $return = 'mult' } + | '/' { $return = 'div' } + | '%' { $return = 'mod' } + +power : powstuff(s?) atom +{ + $return = $item[2]; + for my $op(reverse @{$item[1]}) { $return = [ @{$op}[1,0], $return ] } + 1; +} + | atom +powstuff : atom powop { $return = [ @item[1,2] ] } +powop : '**' { $return = 'pow' } + +atom: '(' expr ')' { $return = $item[2] } + | '-' atom { $return = [ uminus=>$item[2] ] } + | number + | funccall + | identifier + +number : /[+-]?(?:\d+\.?\d*|\.\d+)(?:[eE][+-]?\d+)?/ + +exprlist : expr ',' exprlist { $return = [ $item[1], @{$item[3]} ] } + | expr { $return = [ $item[1] ] } + +funccall : identifier '(' exprlist ')' +{ $return = [ $item[1], @{$item[3]} ] } + +identifier : /[^\W\d]\w*/ { $return = $item[1] } + +GRAMMAR + +my $parser; + +sub init_parser { + if (!$parser) { + $parser = Parse::RecDescent->new($grammar); + } +} + +sub compile { + my ($self, $expr, $opts) = @_; + if (!$parser) { + $parser = Parse::RecDescent->new($grammar); + } + my $optree = $parser->code($expr); + if (!$optree) { + $self->error("Error in $expr\n"); + return; + } + + @{$self->{inputs}}{$self->_variables} = (); + $self->{varregs} = {}; + @{$self->{varregs}}{$self->_variables} = map { "r$_" } 0..$self->_variables-1; + $self->{"nregs"} = [ (undef) x $self->_variables ]; + $self->{"cregs"} = []; + $self->{"lits"} = {}; + + eval { + # generate code for the assignments + for my $assign (@{$optree->[0]}) { + my ($varname, $tree) = @$assign; + if (exists $self->{inputs}{$varname}) { + $self->error("$varname is an input - you can't assign to it"); + return; + } + $self->{varregs}{$varname} = $self->gencode($tree); + } + + # generate the final result + my $result = $self->gencode($optree->[1]); + if ($result !~ /^p\d+$/) { + $self->error("You must return a colour value"); + return; + } + push(@{$self->{genops}}, [ 'ret', $result, (0) x $MaxOperands ]) + }; + if ($@) { + $self->error($@); + return; + } + + return $self->{genops}; +} + +sub gencode { + my ($self, $tree) = @_; + + if (ref $tree) { + my ($op, @parms) = @$tree; + + if (!exists $Attr{$op}) { + die "Unknown operator or function $op"; + } + + for my $subtree (@parms) { + $subtree = $self->gencode($subtree); + } + my $types = join("", map {substr($_,0,1)} @parms); + + if (length($types) < length($Attr{$op}{types})) { + die "Too few parameters in call to $op"; + } + if ($types ne $Attr{$op}{types}) { + # some alternate operators have the same name followed by p + my $opp = $op."p"; + if (exists $Attr{$opp} && + $types eq $Attr{$opp}{types}) { + $op = $opp; + } + else { + die "Call to $_ with incorrect types"; + } + } + my $result; + if ($Attr{$op}{result} eq 'r') { + $result = "r".@{$self->{nregs}}; + push(@{$self->{nregs}}, undef); + } + else { + $result = "p".@{$self->{cregs}}; + push(@{$self->{cregs}}, undef); + } + push(@parms, "0") while @parms < $MaxOperands; + push(@{$self->{genops}}, [ $op, @parms, $result]); + return $result; + } + elsif (exists $self->{varregs}{$tree}) { + return $self->{varregs}{$tree}; + } + elsif ($tree =~ /^$numre$/ || exists $self->{constants}{$tree}) { + $tree = $self->{constants}{$tree} if exists $self->{constants}{$tree}; + + if (exists $self->{lits}{$tree}) { + return $self->{lits}{$tree}; + } + my $reg = "r".@{$self->{nregs}}; + push(@{$self->{nregs}}, $tree); + $self->{lits}{$tree} = $reg; + + return $reg; + } +} + +1; + +__END__ + +=head1 NAME + +Imager::Expr - implements expression parsing and compilation for the +expression evaluation engine used by Imager::transform2() + +=head1 SYNOPSIS + +my $code = Imager::Expr->new({rpnexpr=>$someexpr}) + or die "Cannot compile $someexpr: ",Imager::Expr::error(); + +=head1 DESCRIPTION + +This module is used internally by the Imager::transform2() function. +You shouldn't have much need to use it directly, but you may want to +extend it. + +To create a new Imager::Expr object, call: + + my %options; + my $expr = Imager::Expr->new(\%options) + or die Imager::Expr::error(); + +You will need to set an expression value and you may set any of the +following: + +=over + +=item * + +constants + +A hashref defining extra constants for expression parsing. The names +of the constants must be valid identifiers (/[^\W\d]\w*/) and the +values must be valid numeric constants (that Perl recognizes in +scalars). + +Imager::Expr may define it's own constants (currently just pi.) + +=item * + +variables + +A reference to an array of variable names. These are allocated +numeric registers starting from register zero. + +=back + +By default you can define a 'rpnexpr' key (which emulates RPN) or +'expr' (an infix expression). It's also possible to write other +expression parsers that will use other keys. Only one expression key +should be defined. + +=head2 Instance methods + +The Imager::Expr::error() method is used to retrieve the error if the +expression object cannot be created. + +=head2 Methods + +Imager::Expr provides only a few simple methods meant for external use: + +=over + +=item Imager::Expr->type_registered($keyword) + +Returns true if the given expression type is available. The parameter +is the key supplied to the new() method. + + if (Imager::Expr->type_registered('expr')) { + # use infix expressions + } + +=item $expr->code() + +Returns the compiled code. + +=item $expr->nregs() + +Returns a reference to the array of numeric registers. + +=item $expr->cregs() + +Returns a reference to the array of colour registers. + +=item $expr->dumpops() + +Returns a string with the generated VM "machine code". + +=item $expr->dumpcode() + +Returns a string with the unassembled VM "machine code". + +=back + +=head2 Creating a new parser + +I'll write this one day. + +Methods used by parsers: + +=over + +=item compile + +This is the main method you'll need to implement in a parser. See the +existing parsers for a guide. + +It's supplied the following parameters: + +=over + +=item * + +$expr - the expression to be parsed + +=item * + +$options - the options hash supplied to transform2. + +=back + +Return an array ref of array refs containing opcodes and operands. + +=item @vars = $self->_variables() + +A list (not a reference) of the input variables. This should be used +to allocate as many registers as there are variable as input +registers. + +=item $self->error($message) + +Set the return value of Imager::Expr::error() + +=item @ops = $self->stack_to_reg(@stack_ops) + +Converts marginally parsed RPN to register code. + +=item assemble + +Called to convert op codes into byte code. + +=item numre + +Returns a regular expression that matches floating point numbers. + +=item optimize + +Optimizes the assembly code, including attempting common subexpression +elimination and strength reducing division by a constant into +multiplication by a constant. + +=item register_type + +Called by a new expression parser implementation to register itself, +call as: + + YourClassName->register_type('type code'); + +where type code is the parameter that will accept the expression. + +=back + +=head2 Future compatibility + +Try to avoid doing your own optimization beyond literal folding - if +we add some sort of jump, the existing optimizer will need to be +rewritten, and any optimization you perform may well be broken too +(well, your code generation will probably be broken anyway <sigh>). + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Expr/Assem.pm b/Master/tlpkg/tlperl0/lib/Imager/Expr/Assem.pm new file mode 100755 index 00000000000..a9496f74fd3 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Expr/Assem.pm @@ -0,0 +1,280 @@ +package Imager::Expr::Assem; +use strict; +use Imager::Expr; +use Imager::Regops; +use vars qw($VERSION); + +$VERSION = "1.002"; + +use vars qw(@ISA); +@ISA = qw(Imager::Expr); + +__PACKAGE__->register_type('assem'); + +sub compile { + my ($self, $expr, $opts) = @_; + my %nregs; + my @vars = $self->_variables(); + my @nregs = (0) x @vars; + my @cregs; + my %vars; + @vars{@vars} = map { "r$_" } 0..$#vars; + my %labels; + my @ops; + my @msgs; + my $attr = \%Imager::Regops::Attr; + + # initially produce [ $linenum, $result, $opcode, @parms ] + my $lineno = 0; + while ($expr =~ s/^([^\n]+)(?:\n|$)//) { + ++$lineno; + my $line = $1; + $line =~ s/#.*//; + next if $line =~ /^\s*$/; + for my $op (split /;/, $line) { + if (my ($name, $type) = $op =~ /^\s*var\s+([^:]+):(\S+)\s*$/) { + if (exists $vars{$name}) { + push(@msgs, "$lineno: duplicate variable name '$name'"); + next; + } + if ($type eq 'num' || $type eq 'n') { + $vars{$name} = 'r'.@nregs; + push(@nregs, undef); + next; + } + elsif ($type eq 'pixel' || $type eq 'p' || $type eq 'c') { + $vars{$name} = 'p'.@cregs; + push(@cregs, undef); + next; + } + push(@msgs, "$lineno: unknown variable type $type"); + next; + } + # any statement can have a label + if ($op =~ s/^\s*(\w+):\s*//) { + if ($labels{$1}) { + push(@msgs, + "$lineno: duplicate label $1 (previous on $labels{$1}[1])"); + next; + } + $labels{$1} = [ scalar @ops, $lineno ]; + } + next if $op =~ /^\s*$/; + # jumps have special operand handling + if ($op =~ /^\s*jump\s+(\w+)\s*$/) { + push(@ops, [$lineno, "", "jump", $1]); + } + elsif (my ($code, $reg, $targ) = + ($op =~ /^\s*(jumpz|jumpnz)\s+(\S+)\s+(\S+)\s*$/)) { + push(@ops, [$lineno, "", $code, $reg, $targ]); + } + elsif ($op =~ /^\s*print\s+(\S+)\s*/) { + push(@ops, [$lineno, "", 'print', $1 ]); + } + elsif ($op =~ /^\s*ret\s+(\S+)\s*/) { + push(@ops, [$lineno, "", 'ret', $1]); + } + elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*$//) { + # simple assignment + push(@ops, [$lineno, $1, "set", $2]); + } + elsif ($op =~ s/\s*(\S+)\s*=\s*(\S+)\s*//) { + # some normal ops finally + my ($result, $opcode) = ($1, $2); + unless ($attr->{$opcode}) { + push(@msgs, "$lineno: unknown operator $opcode"); + next; + } + my @oper; + while ($op =~ s/(\S+)\s*//) { + push(@oper, $1); + } + push(@ops, [$lineno, $result, $opcode, @oper]); + } + else { + push(@msgs, "$lineno: invalid statement '$op'"); + } + } + } + + my $max_opr = $Imager::Regops::MaxOperands; + my $numre = $self->numre; + my $trans = + sub { + # translate a name/number to a <type><digits> + my ($name) = @_; + $name = $self->{constants}{$name} + if exists $self->{constants}{$name}; + if ($vars{$name}) { + return $vars{$name}; + } + elsif ($name =~ /^$numre$/) { + $vars{$name} = 'r'.@nregs; + push(@nregs, $name); + return $vars{$name}; + } + else { + push(@msgs, "$lineno: undefined variable $name"); + return ''; + } + }; + # now to translate symbols and so on + OP: for my $op (@ops) { + $lineno = shift @$op; + if ($op->[1] eq 'jump') { + unless (exists $labels{$op->[2]}) { + push(@msgs, "$lineno: unknown label $op->[2]"); + next; + } + $op = [ 'jump', "j$labels{$op->[2]}[0]", (0) x $max_opr ]; + } + elsif ($op->[1] =~ /^jump/) { + unless (exists $labels{$op->[3]}) { + push(@msgs, "$lineno: unknown label $op->[2]"); + next; + } + $op = [ $op->[1], $trans->($op->[2]), "j$labels{$op->[3]}[0]", + (0) x ($max_opr-1) ]; + } + elsif ($op->[1] eq 'print') { + $op = [ $op->[1], $trans->($op->[2]), (0) x $max_opr ]; + } + elsif ($op->[1] eq 'ret') { + $op = [ 'ret', $trans->($op->[2]), (0) x $max_opr ]; + } + else { + # a normal operator + my ($result, $name, @parms) = @$op; + + if ($result =~ /^$numre$/) { + push(@msgs, "$lineno: target of operator cannot be a constant"); + next; + } + $result = $trans->($result); + for my $parm (@parms) { + $parm = $trans->($parm); + } + push(@parms, (0) x ($max_opr-@parms)); + $op = [ $op->[1], @parms, $result ]; + } + } + + # more validation than a real assembler + # not trying to solve the halting problem... + if (@ops && $ops[-1][0] ne 'ret' && $ops[-1][0] ne 'jump') { + push(@msgs, ": the last instruction must be ret or jump"); + } + + $self->{nregs} = \@nregs; + $self->{cregs} = \@cregs; + + if (@msgs) { + $self->error(join("\n", @msgs)); + return 0; + } + + return \@ops; +} + +1; + +__END__ + +=head1 NAME + + Imager::Expr::Assem - an assembler for producing code for the Imager + register machine + +=head1 SYNOPSIS + + use Imager::Expr::Assem; + my $expr = Imager::Expr->new(assem=>'...', ...) + +=head1 DESCRIPTION + +This module is a simple Imager::Expr compiler that compiles a +low-level language that has a nearly 1-to-1 relationship to the +internal representation used for compiled regmach code. + +=head2 Syntax + +Each line can contain multiple statements separated by semi-colons. + +Anything after '#' in a line is ignored. + +Types of statements: + +=over 4 + +=item variable definition + +=over 4 + +C<var> I<name>:I<type> + +=back + +defines variable I<name> to have I<type>, which can be any of 'n' or +'num' for a numeric type or 'pixel', 'p' or 'c' for a pixel or color +type. + +Variable names cannot include whitespace. + +=item operators + +Operators can be split into 3 basic types, those that have a result +value, those that don't and the null operator, eg. jump has no value. + +The format for operators that return a value is typically: + +=over 4 + +I<result> = I<operator> I<operand> ... + +=back + +and for those that don't return a value: + +=over 4 + +I<operator> I<operand> + +=back + +where operator is any valid regmach operator, result is any variable +defined with C<var>, and operands are variables, constants or +literals, or for jump operators, labels. + +The set operator can be simplified to: + +=over 4 + +I<result> = I<operator> + +=back + +All operators maybe preceded by a label, which is any non-whitespace +text immediately followed by a colon (':'). + +=back + +=head1 BUGS + +Note that the current optimizer may produce incorrect optimization for +your code, fortunately the optimizer will disable itself if you +include any jump operator in your code. A single jump to anywhere +after your final ret operator can be used to disable the optimizer +without slowing down your code. + +There's currently no high-level code generation that can generate code +with loops or real conditions. + +=head1 SEE ALSO + +Imager(3), transform.perl, regmach.c + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/ExtUtils.pm b/Master/tlpkg/tlperl0/lib/Imager/ExtUtils.pm new file mode 100755 index 00000000000..a43a7bc418d --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/ExtUtils.pm @@ -0,0 +1,135 @@ +package Imager::ExtUtils; +use strict; +use File::Spec; + +use vars qw($VERSION); + +$VERSION = "1.002"; + +=head1 NAME + +Imager::ExtUtils - functions handy in writing Imager extensions + +=head1 SYNOPSIS + + # make Imager easier to use with Inline + # perldoc Imager::Inline + use Inline with => 'Imager'; + +=head1 DESCRIPTION + +=over + +=item base_dir + +Returns the base directory where Imager is installed. + +=cut + +# figure out where Imager is installed +sub base_dir { + for my $inc_dir (@INC) { + if (-e "$inc_dir/Imager.pm") { + my $base_dir = $inc_dir; + unless (File::Spec->file_name_is_absolute($base_dir)) { + $base_dir = File::Spec->rel2abs($base_dir); + } + return $base_dir; + } + } + + die "Cannot locate an installed Imager!"; +} + +=item inline_config + +Implements Imager's Inline::C C<with> hook. + +=cut + +sub inline_config { + my ($class) = @_; + my $base = base_dir(); + + return + { + INC => $class->includes, + TYPEMAPS => $class->typemap, + AUTO_INCLUDE => <<CODE, +/* Inserted by Imager $Imager::VERSION */ +#include "imext.h" +#include "imperl.h" +DEFINE_IMAGER_CALLBACKS; +CODE + BOOT => 'PERL_INITIALIZE_IMAGER_CALLBACKS;', + FILTERS => \&_inline_filter, + }; +} + +my @inline_replace = + qw( + Imager::ImgRaw + Imager::Color::Float + Imager::Color + Imager::IO + ); + +my %inline_replace = + map { (my $tmp = $_) =~ s/::/__/g; $_ => $tmp } @inline_replace; + +my $inline_replace_re = "\\b(" . join('|', @inline_replace) . ")\\b"; + +sub _inline_filter { + my $code = shift; + + $code =~ s/$inline_replace_re/$inline_replace{$1}/g; + + $code; +} + +=item includes + +Returns -I options suitable for use with ExtUtils::MakeMaker's INC +option. + +=cut + +sub includes { + my $class = shift; + my $base = $class->base_dir(); + + "-I" . $base . '/Imager/include', +} + +=item typemap + +Returns the full path to Imager's installed typemap. + +=cut + +sub typemap { + my $class = shift; + my $base = $class->base_dir(); + + $base . '/Imager/typemap'; +} + +1; + +__END__ + +=back + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 REVISION + +$Revision$ + +=head1 SEE ALSO + +Imager, Imager::API, Imager::Inline, Imager::APIRef. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/File/CUR.pm b/Master/tlpkg/tlperl0/lib/Imager/File/CUR.pm new file mode 100755 index 00000000000..7c3570c729f --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/File/CUR.pm @@ -0,0 +1,7 @@ +package Imager::File::CUR; +use strict; + +# all the work is done by Imager::File::ICO +use Imager::File::ICO; + +1; diff --git a/Master/tlpkg/tlperl0/lib/Imager/File/ICO.pm b/Master/tlpkg/tlperl0/lib/Imager/File/ICO.pm new file mode 100755 index 00000000000..56ee231a016 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/File/ICO.pm @@ -0,0 +1,176 @@ +package Imager::File::ICO; +use strict; +use Imager; +use vars qw($VERSION @ISA); + +BEGIN { + $VERSION = "0.01"; + + eval { + require XSLoader; + XSLoader::load('Imager::File::ICO', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::File::ICO $VERSION; + }; +} + +Imager->register_reader + ( + type=>'ico', + single => + sub { + my ($im, $io, %hsh) = @_; + my $masked = + exists $hsh{ico_masked} ? $hsh{ico_masked} : 1; + $im->{IMG} = i_readico_single($io, $hsh{page} || 0, $masked); + + unless ($im->{IMG}) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + multiple => + sub { + my ($io, %hsh) = @_; + + my $masked = + exists $hsh{ico_masked} ? $hsh{ico_masked} : 1; + my @imgs = i_readico_multi($io, $masked); + unless (@imgs) { + Imager->_set_error(Imager->_error_as_msg); + return; + } + return map { + bless { IMG => $_, DEBUG => $Imager::DEBUG, ERRSTR => undef }, 'Imager' + } @imgs; + }, + ); + +# the readers can read CUR files too +Imager->register_reader + ( + type=>'cur', + single => + sub { + my ($im, $io, %hsh) = @_; + my $masked = + exists $hsh{ico_masked} ? $hsh{ico_masked} : 1; + $im->{IMG} = i_readico_single($io, $hsh{page} || 0, $masked); + + unless ($im->{IMG}) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + multiple => + sub { + my ($io, %hsh) = @_; + + my $masked = + exists $hsh{ico_masked} ? $hsh{ico_masked} : 1; + my @imgs = i_readico_multi($io, $masked); + unless (@imgs) { + Imager->_set_error(Imager->_error_as_msg); + return; + } + return map { + bless { IMG => $_, DEBUG => $Imager::DEBUG, ERRSTR => undef }, 'Imager' + } @imgs; + }, + ); + +Imager->register_writer + ( + type=>'ico', + single => + sub { + my ($im, $io, %hsh) = @_; + + unless (i_writeico_wiol($io, $im->{IMG})) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + multiple => + sub { + my ($class, $io, $opts, @images) = @_; + + if (!i_writeico_multi_wiol($io, map $_->{IMG}, @images)) { + Imager->_set_error(Imager->_error_as_msg); + return; + } + + return 1; + }, + ); + +Imager->register_writer + ( + type=>'cur', + single => + sub { + my ($im, $io, %hsh) = @_; + + unless (i_writecur_wiol($io, $im->{IMG})) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + multiple => + sub { + my ($class, $io, $opts, @images) = @_; + + if (!i_writecur_multi_wiol($io, map $_->{IMG}, @images)) { + Imager->_set_error(Imager->_error_as_msg); + return; + } + + return 1; + }, + ); + +1; + +__END__ + +=head1 NAME + +Imager::File::ICO - read MS Icon files + +=head1 SYNOPSIS + + use Imager; + + my $img = Imager->new; + $img->read(file=>"foo.ico") + or die $img->errstr; + + my @imgs = Imager->read_multi(file => "foo.ico") + or die Imager->errstr; + + $img->write(file => "foo.ico") + or die $img->errstr; + + Imager->write_multi({ file => "foo.ico" }, @imgs) + or die Imager->errstr; + +=head1 DESCRIPTION + +Imager's MS Icon support is documented in L<Imager::Files>. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::Files. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/File/SGI.pm b/Master/tlpkg/tlperl0/lib/Imager/File/SGI.pm new file mode 100755 index 00000000000..67cc6a9babb --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/File/SGI.pm @@ -0,0 +1,89 @@ +package Imager::File::SGI; +use strict; +use Imager; +use vars qw($VERSION @ISA); + +BEGIN { + $VERSION = "0.01"; + + eval { + require XSLoader; + XSLoader::load('Imager::File::SGI', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::File::SGI $VERSION; + }; +} + +Imager->register_reader + ( + type=>'sgi', + single => + sub { + my ($im, $io, %hsh) = @_; + $im->{IMG} = i_readsgi_wiol($io, $hsh{page} || 0); + + unless ($im->{IMG}) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + ); + +Imager->register_writer + ( + type=>'sgi', + single => + sub { + my ($im, $io, %hsh) = @_; + + $im->_set_opts(\%hsh, "i_", $im); + $im->_set_opts(\%hsh, "sgi_", $im); + + unless (i_writesgi_wiol($io, $im->{IMG})) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + ); + +__END__ + +=head1 NAME + +Imager::File::ICO - read MS Icon files + +=head1 SYNOPSIS + + use Imager; + + my $img = Imager->new; + $img->read(file=>"foo.ico") + or die $img->errstr; + + my @imgs = Imager->read_multi(file => "foo.ico") + or die Imager->errstr; + + $img->write(file => "foo.ico") + or die $img->errstr; + + Imager->write_multi({ file => "foo.ico" }, @imgs) + or die Imager->errstr; + +=head1 DESCRIPTION + +Imager's MS Icon support is documented in L<Imager::Files>. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::Files. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Files.pod b/Master/tlpkg/tlperl0/lib/Imager/Files.pod new file mode 100755 index 00000000000..b7d612bf4d4 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Files.pod @@ -0,0 +1,1608 @@ +=head1 NAME + +Imager::Files - working with image files + +=head1 SYNOPSIS + + use Imager; + my $img = ...; + $img->write(file=>$filename, type=>$type) + or die "Cannot write: ",$img->errstr; + + # type is optional if we can guess the format from the filename + $img->write(file => "foo.png") + or die "Cannot write: ",$img->errstr; + + $img = Imager->new; + $img->read(file=>$filename, type=>$type) + or die "Cannot read: ", $img->errstr; + + # type is optional if we can guess the type from the file data + # and we normally can guess + $img->read(file => $filename) + or die "Cannot read: ", $img->errstr; + + Imager->write_multi({ file=> $filename, ... }, @images) + or die "Cannot write: ", Imager->errstr; + + my @imgs = Imager->read_multi(file=>$filename) + or die "Cannot read: ", Imager->errstr; + + Imager->set_file_limits(width=>$max_width, height=>$max_height) + + my @read_types = Imager->read_types; + my @write_types = Imager->write_types; + + # we can write/write_multi to things other than filenames + my $data; + $img->write(data => \$data, type => $type) or die; + + my $fh = ... ; # eg. IO::File + $img->write(fh => $fh, type => $type) or die; + + $img->write(fd => fileno($fh), type => $type) or die; + + # some file types need seek callbacks too + $img->write(callback => \&write_callback, type => $type) or die; + + # and similarly for read/read_multi + $img->read(data => $data) or die; + $img->read(fh => $fh) or die; + $img->read(fd => fileno($fh)) or die; + $img->read(callback => \&read_callback) or die; + + use Imager 0.68; + my $img = Imager->new(file => $filename) + or die Imager->errstr; + +=head1 DESCRIPTION + +You can read and write a variety of images formats, assuming you have +the appropriate libraries, and images can be read or written to/from +files, file handles, file descriptors, scalars, or through callbacks. + +To see which image formats Imager is compiled to support the following +code snippet is sufficient: + + use Imager; + print join " ", keys %Imager::formats; + +This will include some other information identifying libraries rather +than file formats. For new code you might find the L</read_types> or +L</write_types> methods useful. + +=over + +=item read + +Reading writing to and from files is simple, use the C<read()> +method to read an image: + + my $img = Imager->new; + $img->read(file=>$filename, type=>$type) + or die "Cannot read $filename: ", $img->errstr; + +In most cases Imager can auto-detect the file type, so you can just +supply the filename: + + $img->read(file => $filename) + or die "Cannot read $filename: ", $img->errstr; + +The read() method accepts the C<allow_partial> parameter. If this is +non-zero then read() can return true on an incomplete image and set +the C<i_incomplete> tag. + +From Imager 0.68 you can supply most read() parameters to the new() +method to read the image file on creation. If the read fails, check +Imager->errstr() for the cause: + + use Imager 0.68; + my $img = Imager->new(file => $filename) + or die "Cannot read $filename: ", Imager->errstr; + +=item write + +and the C<write()> method to write an image: + + $img->write(file=>$filename, type=>$type) + or die "Cannot write $filename: ", $img->errstr; + +=item read_multi + +If you're reading from a format that supports multiple images per +file, use the C<read_multi()> method: + + my @imgs = Imager->read_multi(file=>$filename, type=>$type) + or die "Cannot read $filename: ", Imager->errstr; + +As with the read() method, Imager will normally detect the C<type> +automatically. + +=item write_multi + +and if you want to write multiple images to a single file use the +C<write_multi()> method: + + Imager->write_multi({ file=> $filename, type=>$type }, @images) + or die "Cannot write $filename: ", Imager->errstr; + +=item read_types + +This is a class method that returns a list of the image file types +that Imager can read. + + my @types = Imager->read_types; + +These types are the possible values for the C<type> parameter, not +necessarily the extension of the files you're reading. + +It is possible for extra file read handlers to be loaded when +attempting to read a file, which may modify the list of available read +types. + +=item write_types + +This is a class method that returns a list of the image file types +that Imager can write. + + my @types = Imager->write_types; + +Note that these are the possible values for the C<type> parameter, not +necessarily the extension of the files you're writing. + +It is possible for extra file write handlers to be loaded when +attempting to write a file, which may modify the list of available +write types. + +=back + +When writing, if the I<filename> includes an extension that Imager +recognizes, then you don't need the I<type>, but you may want to +provide one anyway. See L</Guessing types> for information on +controlling this recognition. + +The C<type> parameter is a lowercase representation of the file type, +and can be any of the following: + + bmp Windows BitMaP (BMP) + gif Graphics Interchange Format (GIF) + jpeg JPEG/JFIF + png Portable Network Graphics (PNG) + pnm Portable aNyMap (PNM) + raw Raw + sgi SGI .rgb files + tga TARGA + tiff Tagged Image File Format (TIFF) + +When you read an image, Imager may set some tags, possibly including +information about the spatial resolution, textual information, and +animation information. See L<Imager::ImageTypes/Tags> for specifics. + +The open() method is a historical alias for the read() method. + +=head2 Input and output + +When reading or writing you can specify one of a variety of sources or +targets: + +=over + +=item * + +file - The C<file> parameter is the name of the image file to be +written to or read from. If Imager recognizes the extension of the +file you do not need to supply a C<type>. + + # write in tiff format + $image->write(file => "example.tif") + or die $image->errstr; + + $image->write(file => 'foo.tmp', type => 'tiff') + or die $image->errstr; + + my $image = Imager->new; + $image->read(file => 'example.tif') + or die $image->errstr; + +=item * + +fh - C<fh> is a file handle, typically either returned from +C<<IO::File->new()>>, or a glob from an C<open> call. You should call +C<binmode> on the handle before passing it to Imager. + +Imager will set the handle to autoflush to make sure any buffered data +is flushed , since Imager will write to the file descriptor (from +fileno()) rather than writing at the perl level. + + $image->write(fh => \*STDOUT, type => 'gif') + or die $image->errstr; + + # for example, a file uploaded via CGI.pm + $image->read(fd => $cgi->param('file')) + or die $image->errstr; + +=item * + +fd - C<fd> is a file descriptor. You can get this by calling the +C<fileno()> function on a file handle, or by using one of the standard +file descriptor numbers. + +If you get this from a perl file handle, you may need to flush any +buffered output, otherwise it may appear in the output stream after +the image. + + $image->write(fd => file(STDOUT), type => 'gif') + or die $image->errstr; + +=item * + +data - When reading data, C<data> is a scalar containing the image +file data, when writing, C<data> is a reference to the scalar to save +the image file data too. For GIF images you will need giflib 4 or +higher, and you may need to patch giflib to use this option for +writing. + + my $data; + $image->write(data => \$data, type => 'tiff') + or die $image->errstr; + + my $data = $row->{someblob}; # eg. from a database + my @images = Imager->read_multi(data => $data) + or die Imager->errstr; + +=item * + +callback - Imager will make calls back to your supplied coderefs to +read, write and seek from/to/through the image file. + +When reading from a file you can use either C<callback> or C<readcb> +to supply the read callback, and when writing C<callback> or +C<writecb> to supply the write callback. + +When writing you can also supply the C<maxbuffer> option to set the +maximum amount of data that will be buffered before your write +callback is called. Note: the amount of data supplied to your +callback can be smaller or larger than this size. + +The read callback is called with 2 parameters, the minimum amount of +data required, and the maximum amount that Imager will store in it's C +level buffer. You may want to return the minimum if you have a slow +data source, or the maximum if you have a fast source and want to +prevent many calls to your perl callback. The read data should be +returned as a scalar. + +Your write callback takes exactly one parameter, a scalar containing +the data to be written. Return true for success. + +The seek callback takes 2 parameters, a I<POSITION>, and a I<WHENCE>, +defined in the same way as perl's seek function. + +You can also supply a C<closecb> which is called with no parameters +when there is no more data to be written. This could be used to flush +buffered data. + + # contrived + my $data; + sub mywrite { + $data .= unpack("H*", shift); + 1; + } + Imager->write_multi({ callback => \&mywrite, type => 'gif'}, @images) + or die Imager->errstr; + +Note that for reading you'll almost always need to provide a +C<seekcb>. + +=back + +=head2 Guessing types + +When writing to a file, if you don't supply a C<type> parameter Imager +will attempt to guess it from the filename. This is done by calling +the code reference stored in C<$Imager::FORMATGUESS>. This is only +done when write() or write_multi() is called with a C<file> parameter. + +The default function value of C<$Imager::FORMATGUESS> is +C<\&Imager::def_guess_type>. + +=over + +=item def_guess_type + +This is the default function Imager uses to derive a file type from a +file name. This is a function, not a method. + +Accepts a single parameter, the filename and returns the type or +undef. + +=back + +You can replace function with your own implementation if you have some +specialized need. The function takes a single parameter, the name of +the file, and should return either a file type or under. + + # I'm writing jpegs to weird filenames + local $Imager::FORMATGUESS = sub { 'jpeg' }; + +When reading a file Imager examines beginning of the file for +identifying information. The current implementation attempts to +detect the following image types beyond those supported by Imager: + +=over + +xpm, mng, jng, SGI RGB, ilbm, pcx, fits, psd (Photoshop), eps, Utah +RLE + +=back + +=head2 Limiting the sizes of images you read + +=over + +=item set_file_limits + +In some cases you will be receiving images from an untested source, +such as submissions via CGI. To prevent such images from consuming +large amounts of memory, you can set limits on the dimensions of +images you read from files: + +=over + +=item * + +width - limit the width in pixels of the image + +=item * + +height - limit the height in pixels of the image + +=item * + +bytes - limits the amount of storage used by the image. This depends +on the width, height, channels and sample size of the image. For +paletted images this is calculated as if the image was expanded to a +direct color image. + +=back + +To set the limits, call the class method set_file_limits: + + Imager->set_file_limits(width=>$max_width, height=>$max_height); + +You can pass any or all of the limits above, any limits you do not +pass are left as they were. + +Any limit of zero is treated as unlimited. + +By default, all of the limits are zero, or unlimited. + +You can reset all of the limited to their defaults by passing in the +reset parameter as a true value: + + # no limits + Imager->set_file_limits(reset=>1); + +This can be used with the other limits to reset all but the limit you +pass: + + # only width is limited + Imager->set_file_limits(reset=>1, width=>100); + + # only bytes is limited + Imager->set_file_limits(reset=>1, bytes=>10_000_000); + +=item get_file_limits + +You can get the current limits with the get_file_limits() method: + + my ($max_width, $max_height, $max_bytes) = + Imager->get_file_limits(); + +=back + +=head1 TYPE SPECIFIC INFORMATION + +The different image formats can write different image type, and some have +different options to control how the images are written. + +When you call C<write()> or C<write_multi()> with an option that has +the same name as a tag for the image format you're writing, then the +value supplied to that option will be used to set the corresponding +tag in the image. Depending on the image format, these values will be +used when writing the image. + +This replaces the previous options that were used when writing GIF +images. Currently if you use an obsolete option, it will be converted +to the equivalent tag and Imager will produced a warning. You can +suppress these warnings by calling the C<Imager::init()> function with +the C<warn_obsolete> option set to false: + + Imager::init(warn_obsolete=>0); + +At some point in the future these obsolete options will no longer be +supported. + +=head2 PNM (Portable aNy Map) + +Imager can write PGM (Portable Gray Map) and PPM (Portable PixMaps) +files, depending on the number of channels in the image. Currently +the images are written in binary formats. Only 1 and 3 channel images +can be written, including 1 and 3 channel paletted images. + + $img->write(file=>'foo.ppm') or die $img->errstr; + +Imager can read both the ASCII and binary versions of each of the PBM +(Portable BitMap), PGM and PPM formats. + + $img->read(file=>'foo.ppm') or die $img->errstr; + +PNM does not support the spatial resolution tags. + +The following tags are set when reading a PNM file: + +=over + +=item * + +X<pnm_maxval>pnm_maxval - the maxvals number from the PGM/PPM header. +Always set to 2 for a PBM file. + +=item * + +X<pnm_type>pnm_type - the type number from the PNM header, 1 for ASCII +PBM files, 2 for ASCII PGM files, 3 for ASCII PPM files, 4 for binary +PBM files, 5 for binary PGM files, 6 for binary PPM files. + +=back + +The following tag is checked when writing an image with more than +8-bits/sample: + +=over + +=item * + +X<pnm_write_wide_data>pnm_write_wide_data - if this is non-zero then +write() can write PGM/PPM files with 16-bits/sample. Some +applications, for example GIMP 2.2, and tools can only read +8-bit/sample binary PNM files, so Imager will only write a 16-bit +image when this tag is non-zero. + +=back + +=head2 JPEG + +You can supply a C<jpegquality> parameter (0-100) when writing a JPEG +file, which defaults to 75%. If you write an image with an alpha +channel to a jpeg file then it will be composited against the +background set by the C<i_background> parameter (or tag). + + $img->write(file=>'foo.jpg', jpegquality=>90) or die $img->errstr; + +Imager will read a grayscale JPEG as a 1 channel image and a color +JPEG as a 3 channel image. + + $img->read(file=>'foo.jpg') or die $img->errstr; + +The following tags are set in a JPEG image when read, and can be set +to control output: + +=over + +=item jpeg_density_unit + +The value of the density unit field in the JFIF header. This is +ignored on writing if the C<i_aspect_only> tag is non-zero. + +The C<i_xres> and C<i_yres> tags are expressed in pixels per inch no +matter the value of this tag, they will be converted to/from the value +stored in the JPEG file. + +=item jpeg_density_unit_name + +This is set when reading a JPEG file to the name of the unit given by +C<jpeg_density_unit>. Possible results include C<inch>, +C<centimeter>, C<none> (the C<i_aspect_only> tag is also set reading +these files). If the value of jpeg_density_unit is unknown then this +tag isn't set. + +=item jpeg_comment + +Text comment. + +=back + +JPEG supports the spatial resolution tags C<i_xres>, C<i_yres> and +C<i_aspect_only>. + +If an APP1 block containing EXIF information is found, then any of the +following tags can be set: + +=over + +exif_aperture exif_artist exif_brightness exif_color_space +exif_contrast exif_copyright exif_custom_rendered exif_date_time +exif_date_time_digitized exif_date_time_original +exif_digital_zoom_ratio exif_exposure_bias exif_exposure_index +exif_exposure_mode exif_exposure_program exif_exposure_time +exif_f_number exif_flash exif_flash_energy exif_flashpix_version +exif_focal_length exif_focal_length_in_35mm_film +exif_focal_plane_resolution_unit exif_focal_plane_x_resolution +exif_focal_plane_y_resolution exif_gain_control exif_image_description +exif_image_unique_id exif_iso_speed_rating exif_make exif_max_aperture +exif_metering_mode exif_model exif_orientation exif_related_sound_file +exif_resolution_unit exif_saturation exif_scene_capture_type +exif_sensing_method exif_sharpness exif_shutter_speed exif_software +exif_spectral_sensitivity exif_sub_sec_time +exif_sub_sec_time_digitized exif_sub_sec_time_original +exif_subject_distance exif_subject_distance_range +exif_subject_location exif_tag_light_source exif_user_comment +exif_version exif_white_balance exif_x_resolution exif_y_resolution + +=back + +The following derived tags can also be set: + +=over + +exif_color_space_name exif_contrast_name exif_custom_rendered_name +exif_exposure_mode_name exif_exposure_program_name exif_flash_name +exif_focal_plane_resolution_unit_name exif_gain_control_name +exif_light_source_name exif_metering_mode_name +exif_resolution_unit_name exif_saturation_name +exif_scene_capture_type_name exif_sensing_method_name +exif_sharpness_name exif_subject_distance_range_name +exif_white_balance_name + +=back + +The derived tags are for enumerated fields, when the value for the +base field is valid then the text that appears in the EXIF +specification for that value appears in the derived field. So for +example if C<exf_metering_mode> is C<5> then +C<exif_metering_mode_name> is set to C<Pattern>. + +eg. + + my $image = Imager->new; + $image->read(file => 'exiftest.jpg') + or die "Cannot load image: ", $image->errstr; + print $image->tags(name => "exif_image_description"), "\n"; + print $image->tags(name => "exif_exposure_mode"), "\n"; + print $image->tags(name => "exif_exposure_mode_name"), "\n"; + + # for the exiftest.jpg in the Imager distribution the output would be: + Imager Development Notes + 0 + Auto exposure + +=over + +=item parseiptc + +Historically, Imager saves IPTC data when reading a JPEG image, the +parseiptc() method returns a list of key/value pairs resulting from a +simple decoding of that data. + +Any future IPTC data decoding is likely to go into tags. + +=back + +=head2 GIF (Graphics Interchange Format) + +When writing one of more GIF images you can use the same +L<Quantization Options|Imager::ImageTypes> as you can when converting +an RGB image into a paletted image. + +When reading a GIF all of the sub-images are combined using the screen +size and image positions into one big image, producing an RGB image. +This may change in the future to produce a paletted image where possible. + +When you read a single GIF with C<$img-E<gt>read()> you can supply a +reference to a scalar in the C<colors> parameter, if the image is read +the scalar will be filled with a reference to an anonymous array of +L<Imager::Color> objects, representing the palette of the image. This +will be the first palette found in the image. If you want the +palettes for each of the images in the file, use C<read_multi()> and +use the C<getcolors()> method on each image. + +GIF does not support the spatial resolution tags. + +Imager will set the following tags in each image when reading, and can +use most of them when writing to GIF: + +=over + +=item * + +gif_left - the offset of the image from the left of the "screen" +("Image Left Position") + +=item * + +gif_top - the offset of the image from the top of the "screen" ("Image +Top Position") + +=item * + +gif_interlace - non-zero if the image was interlaced ("Interlace +Flag") + +=item * + +gif_screen_width, gif_screen_height - the size of the logical +screen. When writing this is used as the minimum. If any image being +written would extend beyond this then the screen size is extended. +("Logical Screen Width", "Logical Screen Height"). + +=item * + +gif_local_map - Non-zero if this image had a local color map. If set +for an image when writing the image is quantized separately from the +other images in the file. + +=item * + +gif_background - The index in the global colormap of the logical +screen's background color. This is only set if the current image uses +the global colormap. You can set this on write too, but for it to +choose the color you want, you will need to supply only paletted +images and set the C<gif_eliminate_unused> tag to 0. + +=item * + +gif_trans_index - The index of the color in the colormap used for +transparency. If the image has a transparency then it is returned as +a 4 channel image with the alpha set to zero in this palette entry. +This value is not used when writing. ("Transparent Color Index") + +=item * + +gif_trans_color - A reference to an Imager::Color object, which is the +colour to use for the palette entry used to represent transparency in +the palette. You need to set the transp option (see L<Quantization +options>) for this value to be used. + +=item * + +gif_delay - The delay until the next frame is displayed, in 1/100 of a +second. ("Delay Time"). + +=item * + +gif_user_input - whether or not a user input is expected before +continuing (view dependent) ("User Input Flag"). + +=item * + +gif_disposal - how the next frame is displayed ("Disposal Method") + +=item * + +gif_loop - the number of loops from the Netscape Loop extension. This +may be zero to loop forever. + +=item * + +gif_comment - the first block of the first gif comment before each +image. + +=item * + +gif_eliminate_unused - If this is true, when you write a paletted +image any unused colors will be eliminated from its palette. This is +set by default. + +=item * + +gif_colormap_size - the original size of the color map for the image. +The color map of the image may have been expanded to include out of +range color indexes. + +=back + +Where applicable, the ("name") is the name of that field from the GIF89 +standard. + +The following gif writing options are obsolete, you should set the +corresponding tag in the image, either by using the tags functions, or +by supplying the tag and value as options. + +=over + +=item * + +gif_each_palette - Each image in the gif file has it's own palette if +this is non-zero. All but the first image has a local colour table +(the first uses the global colour table. + +Use C<gif_local_map> in new code. + +=item * + +interlace - The images are written interlaced if this is non-zero. + +Use C<gif_interlace> in new code. + +=item * + +gif_delays - A reference to an array containing the delays between +images, in 1/100 seconds. + +Use C<gif_delay> in new code. + +=item * + +gif_positions - A reference to an array of references to arrays which +represent screen positions for each image. + +New code should use the C<gif_left> and C<gif_top> tags. + +=item * + +gif_loop_count - If this is non-zero the Netscape loop extension block +is generated, which makes the animation of the images repeat. + +This is currently unimplemented due to some limitations in giflib. + +=back + +You can supply a C<page> parameter to the C<read()> method to read +some page other than the first. The page is 0 based: + + # read the second image in the file + $image->read(file=>"example.gif", page=>1) + or die "Cannot read second page: ",$image->errstr,"\n"; + +Before release 0.46, Imager would read multi-image GIF image files +into a single image, overlaying each of the images onto the virtual +GIF screen. + +As of 0.46 the default is to read the first image from the file, as if +called with C<< page => 0 >>. + +You can return to the previous behaviour by calling read with the +C<gif_consolidate> parameter set to a true value: + + $img->read(file=>$some_gif_file, gif_consolidate=>1); + +As with the to_paletted() method, if you supply a colors parameter as +a reference to an array, this will be filled with Imager::Color +objects of the color table generated for the image file. + +=head2 TIFF (Tagged Image File Format) + +Imager can write images to either paletted or RGB TIFF images, +depending on the type of the source image. Currently if you write a +16-bit/sample or double/sample image it will be written as an +8-bit/sample image. Only 1 or 3 channel images can be written. + +If you are creating images for faxing you can set the I<class> +parameter set to C<fax>. By default the image is written in fine +mode, but this can be overridden by setting the I<fax_fine> parameter +to zero. Since a fax image is bi-level, Imager uses a threshold to +decide if a given pixel is black or white, based on a single channel. +For greyscale images channel 0 is used, for color images channel 1 +(green) is used. If you want more control over the conversion you can +use $img->to_paletted() to product a bi-level image. This way you can +use dithering: + + my $bilevel = $img->to_paletted(make_colors => 'mono', + translate => 'errdiff', + errdiff => 'stucki'); + +=over + +=item class + +If set to 'fax' the image will be written as a bi-level fax image. + +=item fax_fine + +By default when I<class> is set to 'fax' the image is written in fine +mode, you can select normal mode by setting I<fax_fine> to 0. + +=back + +Imager should be able to read any TIFF image you supply. Paletted +TIFF images are read as paletted Imager images, since paletted TIFF +images have 16-bits/sample (48-bits/color) this means the bottom +8-bits are lost, but this shouldn't be a big deal. Currently all +direct color images are read at 8-bits/sample. + +TIFF supports the spatial resolution tags. See the +C<tiff_resolutionunit> tag for some extra options. + +As of Imager 0.62 Imager reads: + +=over + +=item * + +16-bit grey, RGB, or CMYK image, including a possible alpha channel as +a 16-bit/sample image. + +=item * + +32-bit grey, RGB image, including a possible alpha channel as a +double/sample image. + +=item * + +bi-level images as paletted images containing only black and white, +which other formats will also write as bi-level. + +=item * + +tiled paletted images are now handled correctly + +=back + +The following tags are set in a TIFF image when read, and can be set +to control output: + +=over + +=item tiff_compression + +When reading an image this is set to the numeric value of the TIFF +compression tag. + +On writing you can set this to either a numeric compression tag value, +or one of the following values: + + Ident Number Description + none 1 No compression + packbits 32773 Macintosh RLE + ccittrle 2 CCITT RLE + fax3 3 CCITT Group 3 fax encoding (T.4) + t4 3 As above + fax4 4 CCITT Group 4 fax encoding (T.6) + t6 4 As above + lzw 5 LZW + jpeg 7 JPEG + zip 8 Deflate (GZIP) Non-standard + deflate 8 As above. + oldzip 32946 Deflate with an older code. + ccittrlew 32771 Word aligned CCITT RLE + +In general a compression setting will be ignored where it doesn't make +sense, eg. C<jpeg> will be ignored for compression if the image is +being written as bilevel. + +Imager attempts to check that your build of libtiff supports the given +compression, and will fallback to C<packbits> if it isn't enabled. +eg. older distributions didn't include LZW compression, and JPEG +compression is only available if libtiff is configured with libjpeg's +location. + + $im->write(file => 'foo.tif', tiff_compression => 'lzw') + or die $im->errstr; + +=item tiff_jpegquality + +If I<tiff_compression> if C<jpeg> then this can be a number from 1 to +100 giving the JPEG compression quality. High values are better +quality and larger files. + +=item tiff_resolutionunit + +The value of the ResolutionUnit tag. This is ignored on writing if +the i_aspect_only tag is non-zero. + +The C<i_xres> and C<i_yres> tags are expressed in pixels per inch no +matter the value of this tag, they will be converted to/from the value +stored in the TIFF file. + +=item tiff_resolutionunit_name + +This is set when reading a TIFF file to the name of the unit given by +C<tiff_resolutionunit>. Possible results include C<inch>, +C<centimeter>, C<none> (the C<i_aspect_only> tag is also set reading +these files) or C<unknown>. + +=item tiff_bitspersample + +Bits per sample from the image. This value is not used when writing +an image, it is only set on a read image. + +=item tiff_photometric + +Value of the PhotometricInterpretation tag from the image. This value +is not used when writing an image, it is only set on a read image. + +=item tiff_documentname + +=item tiff_imagedescription + +=item tiff_make + +=item tiff_model + +=item tiff_pagename + +=item tiff_software + +=item tiff_datetime + +=item tiff_artist + +=item tiff_hostcomputer + +Various strings describing the image. tiff_datetime must be formatted +as "YYYY:MM:DD HH:MM:SS". These correspond directly to the mixed case +names in the TIFF specification. These are set in images read from a +TIFF and saved when writing a TIFF image. + +=back + +You can supply a C<page> parameter to the C<read()> method to read +some page other than the first. The page is 0 based: + + # read the second image in the file + $image->read(file=>"example.tif", page=>1) + or die "Cannot read second page: ",$image->errstr,"\n"; + +Note: Imager uses the TIFF*RGBA* family of libtiff functions, +unfortunately these don't support alpha channels on CMYK images. This +will result in a full coverage alpha channel on CMYK images with an +alpha channel, until this is implemented in libtiff (or Imager's TIFF +implementation changes.) + +If you read an image with multiple alpha channels, then only the first +alpha channel will be read. + +Currently Imager's TIFF support reads all direct color images as 8-bit +RGB images, this may change in the future to reading 16-bit/sample +images. + +Currently tags that control the output color type and compression are +ignored when writing, this may change in the future. If you have +processes that rely upon Imager always producing packbits compressed +RGB images, you should strip any tags before writing. + +=head2 BMP (BitMaP) + +Imager can write 24-bit RGB, and 8, 4 and 1-bit per pixel paletted +Windows BMP files. Currently you cannot write compressed BMP files +with Imager. + +Imager can read 24-bit RGB, and 8, 4 and 1-bit perl pixel paletted +Windows BMP files. There is some support for reading 16-bit per pixel +images, but I haven't found any for testing. + +BMP has no support for multi-image files. + +BMP files support the spatial resolution tags, but since BMP has no +support for storing only an aspect ratio, if C<i_aspect_only> is set +when you write the C<i_xres> and C<i_yres> values are scaled so the +smaller is 72 DPI. + +The following tags are set when you read an image from a BMP file: + +=over + +=item bmp_compression + +The type of compression, if any. This can be any of the following +values: + +=over + +=item BI_RGB (0) + +Uncompressed. + +=item BI_RLE8 (1) + +8-bits/pixel paletted value RLE compression. + +=item BI_RLE4 (2) + +4-bits/pixel paletted value RLE compression. + +=item BI_BITFIELDS (3) + +Packed RGB values. + +=back + +=item bmp_compression_name + +The bmp_compression value as a BI_* string + +=item bmp_important_colors + +The number of important colors as defined by the writer of the image. + +=item bmp_used_colors + +Number of color used from the BMP header + +=item bmp_filesize + +The file size from the BMP header + +=item bmp_bit_count + +Number of bits stored per pixel. (24, 8, 4 or 1) + +=back + +=head2 TGA (TarGA) + +When storing targa images rle compression can be activated with the +'compress' parameter, the 'idstring' parameter can be used to set the +targa comment field and the 'wierdpack' option can be used to use the +15 and 16 bit targa formats for rgb and rgba data. The 15 bit format +has 5 of each red, green and blue. The 16 bit format in addition +allows 1 bit of alpha. The most significant bits are used for each +channel. + + +Tags: + +=over + +=item tga_idstring + +=item tga_bitspp + +=item compressed + +=back + +=head2 RAW + +When reading raw images you need to supply the width and height of the +image in the xsize and ysize options: + + $img->read(file=>'foo.raw', xsize=>100, ysize=>100) + or die "Cannot read raw image\n"; + +If your input file has more channels than you want, or (as is common), +junk in the fourth channel, you can use the datachannels and +storechannels options to control the number of channels in your input +file and the resulting channels in your image. For example, if your +input image uses 32-bits per pixel with red, green, blue and junk +values for each pixel you could do: + + $img->read(file=>'foo.raw', xsize=>100, ysize=>100, datachannels=>4, + storechannels=>3) + or die "Cannot read raw image\n"; + +Read parameters: + +=over + +=item * + +raw_interleave - controls the ordering of samples within the image. +Default: 1. Alternatively and historically spelled C<interleave>. +Possible values: + +=over + +=item * + +0 - samples are pixel by pixel, so all samples for the first pixel, +then all samples for the second pixel and so on. eg. for a four pixel +scanline the channels would be laid out as: + + 012012012012 + +=item * + +1 - samples are line by line, so channel 0 for the entire scanline is +followed by channel 1 for the entire scanline and so on. eg. for a +four pixel scanline the channels would be laid out as: + + 000011112222 + +This is the default. + +=back + +Unfortunately, historically, the default C<raw_interleave> for read +has been 1, while writing only supports the C<raw_interleave> = 0 +format. + +For future compatibility, you should always supply the +C<raw_interleave> (or C<interleave>) parameter. As of 0.68, Imager +will warn if you attempt to read a raw image without a +C<raw_interleave> parameter. + +=item * + +raw_storechannels - the number of channels to store in the image. +Range: 1 to 4. Default: 3. Alternatively and historically spelled +C<storechannels>. + +=item * + +raw_datachannels - the number of channels to read from the file. +Range: 1 or more. Default: 3. Alternatively and historically spelled +C<datachannels>. + +=back + + $img->read(file=>'foo.raw', xsize=100, ysize=>100, raw_interleave=>1) + or die "Cannot read raw image\n"; + +=head2 PNG + +There are no PNG specific tags. + +=head2 ICO (Microsoft Windows Icon) and CUR (Microsoft Windows Cursor) + +Icon and Cursor files are very similar, the only differences being a +number in the header and the storage of the cursor hotspot. I've +treated them separately so that you're not messing with tags to +distinguish between them. + +The following tags are set when reading an icon image and are used +when writing it: + +=over + +=item ico_mask + +This is the AND mask of the icon. When used as an icon in Windows 1 +bits in the mask correspond to pixels that are modified by the source +image rather than simply replaced by the source image. + +Rather than requiring a binary bitmap this is accepted in a specific format: + +=over + +=item * + +first line consisting of the 0 placeholder, the 1 placeholder and a +newline. + +=item * + +following lines which contain 0 and 1 placeholders for each scanline +of the image, starting from the top of the image. + +=back + +When reading an image, '.' is used as the 0 placeholder and '*' as the +1 placeholder. An example: + + .* + ..........................****** + ..........................****** + ..........................****** + ..........................****** + ...........................***** + ............................**** + ............................**** + .............................*** + .............................*** + .............................*** + .............................*** + ..............................** + ..............................** + ...............................* + ...............................* + ................................ + ................................ + ................................ + ................................ + ................................ + ................................ + *............................... + **.............................. + **.............................. + ***............................. + ***............................. + ****............................ + ****............................ + *****........................... + *****........................... + *****........................... + *****........................... + +=back + +The following tags are set when reading an icon: + +=over + +=item ico_bits + +The number of bits per pixel used to store the image. + +=back + +For cursor files the following tags are set and read when reading and +writing: + +=over + +=item cur_mask + +This is the same as the ico_mask above. + +=item cur_hotspotx + +=item cur_hotspoty + +The "hot" spot of the cursor image. This is the spot on the cursor +that you click with. If you set these to out of range values they are +clipped to the size of the image when written to the file. + +=back + +The following parameters can be supplied to read() or read_multi() to +control reading of ICO/CUR files: + +=over + +=item * + +ico_masked - if true, the default, then the icon/cursors mask is +applied as an alpha channel to the image. This may result in a +paletted image being returned as a direct color image. Default: 1 + + # retrieve the image as stored, without using the mask as an alpha + # channel + $img->read(file => 'foo.ico', ico_masked => 0) + or die $img->errstr; + +This was introduced in Imager 0.60. Previously reading ICO images +acted as if C<ico_masked =E<gt> 0>. + +=back + +C<cur_bits> is set when reading a cursor. + +Examples: + + my $img = Imager->new(xsize => 32, ysize => 32, channels => 4); + $im->box(color => 'FF0000'); + $im->write(file => 'box.ico'); + + $im->settag(name => 'cur_hotspotx', value => 16); + $im->settag(name => 'cur_hotspoty', value => 16); + $im->write(file => 'box.cur'); + +=head2 SGI (RGB, BW) + +SGI images, often called by the extensions, RGB or BW, can be stored +either uncompressed or compressed using an RLE compression. + +By default, when saving to an extension of C<rgb>, C<bw>, C<sgi>, +C<rgba> the file will be saved in SGI format. The file extension is +otherwise ignored, so saving a 3-channel image to a C<.bw> file will +result in a 3-channel image on disk. + +The following tags are set when reading a SGI image: + +=over + +=item * + +i_comment - the IMAGENAME field from the image. Also written to the +file when writing. + +=item * + +sgi_pixmin, sgi_pixmax - the PIXMIN and PIXMAX fields from the image. +On reading image data is expanded from this range to the full range of +samples in the image. + +=item * + +sgi_bpc - the number of bytes per sample for the image. Ignored when +writing. + +=item * + +sgi_rle - whether or not the image is compressed. If this is non-zero +when writing the image will be compressed. + +=back + +=head1 ADDING NEW FORMATS + +To support a new format for reading, call the register_reader() class +method: + +=over + +=item register_reader + +Registers single or multiple image read functions. + +Parameters: + +=over + +=item * + +type - the identifier of the file format, if Imager's +i_test_format_probe() can identify the format then this value should +match i_test_format_probe()'s result. + +This parameter is required. + +=item * + +single - a code ref to read a single image from a file. This is +supplied: + +=over + +=item * + +the object that read() was called on, + +=item * + +an Imager::IO object that should be used to read the file, and + +=item * + +all the parameters supplied to the read() method. + +=back + +The single parameter is required. + +=item * + +multiple - a code ref which is called to read multiple images from a +file. This is supplied: + +=over + +=item * + +an Imager::IO object that should be used to read the file, and + +=item * + +all the parameters supplied to the read_multi() method. + +=back + +=back + +Example: + + # from Imager::File::ICO + Imager->register_reader + ( + type=>'ico', + single => + sub { + my ($im, $io, %hsh) = @_; + $im->{IMG} = i_readico_single($io, $hsh{page} || 0); + + unless ($im->{IMG}) { + $im->_set_error(Imager->_error_as_msg); + return; + } + return $im; + }, + multiple => + sub { + my ($io, %hsh) = @_; + + my @imgs = i_readico_multi($io); + unless (@imgs) { + Imager->_set_error(Imager->_error_as_msg); + return; + } + return map { + bless { IMG => $_, DEBUG => $Imager::DEBUG, ERRSTR => undef }, 'Imager' + } @imgs; + }, + ); + +=item register_writer + +Registers single or multiple image write functions. + +Parameters: + +=over + +=item * + +type - the identifier of the file format. This is typically the +extension in lowercase. + +This parameter is required. + +=item * + +single - a code ref to write a single image to a file. This is +supplied: + +=over + +=item * + +the object that write() was called on, + +=item * + +an Imager::IO object that should be used to write the file, and + +=item * + +all the parameters supplied to the write() method. + +=back + +The single parameter is required. + +=item * + +multiple - a code ref which is called to write multiple images to a +file. This is supplied: + +=over + +=item * + +the class name write_multi() was called on, this is typically +C<Imager>. + +=item * + +an Imager::IO object that should be used to write the file, and + +=item * + +all the parameters supplied to the read_multi() method. + +=back + +=back + +=back + +If you name the reader module C<Imager::File::>I<your-format-name> +where I<your-format-name> is a fully upper case version of the type +value you would pass to read(), read_multi(), write() or write_multi() +then Imager will attempt to load that module if it has no other way to +read or write that format. + +For example, if you create a module Imager::File::GIF and the user has +built Imager without it's normal GIF support then an attempt to read a +GIF image will attempt to load Imager::File::GIF. + +If your module can only handle reading then you can name your module +C<Imager::File::>I<your-format-name>C<Reader> and Imager will attempt +to autoload it. + +If your module can only handle writing then you can name your module +C<Imager::File::>I<your-format-name>C<Writer> and Imager will attempt +to autoload it. + +=head1 EXAMPLES + +=head2 Producing an image from a CGI script + +Once you have an image the basic mechanism is: + +=over + +=item 1. + +set STDOUT to autoflush + +=item 2. + +output a content-type header, and optionally a content-length header + +=item 3. + +put STDOUT into binmode + +=item 4. + +call write() with the C<fd> or C<fh> parameter. You will need to +provide the C<type> parameter since Imager can't use the extension to +guess the file format you want. + +=back + + # write an image from a CGI script + # using CGI.pm + use CGI qw(:standard); + $| = 1; + binmode STDOUT; + print header(-type=>'image/gif'); + $img->write(type=>'gif', fd=>fileno(STDOUT)) + or die $img->errstr; + +If you want to send a content length you can send the output to a +scalar to get the length: + + my $data; + $img->write(type=>'gif', data=>\$data) + or die $img->errstr; + binmode STDOUT; + print header(-type=>'image/gif', -content_length=>length($data)); + print $data; + +=head2 Writing an animated GIF + +The basic idea is simple, just use write_multi(): + + my @imgs = ...; + Imager->write_multi({ file=>$filename, type=>'gif' }, @imgs); + +If your images are RGB images the default quantization mechanism will +produce a very good result, but can take a long time to execute. You +could either use the standard webmap: + + Imager->write_multi({ file=>$filename, + type=>'gif', + make_colors=>'webmap' }, + @imgs); + +or use a median cut algorithm to built a fairly optimal color map: + + Imager->write_multi({ file=>$filename, + type=>'gif', + make_colors=>'mediancut' }, + @imgs); + +By default all of the images will use the same global colormap, which +will produce a smaller image. If your images have significant color +differences, you may want to generate a new palette for each image: + + Imager->write_multi({ file=>$filename, + type=>'gif', + make_colors=>'mediancut', + gif_local_map => 1 }, + @imgs); + +which will set the C<gif_local_map> tag in each image to 1. +Alternatively, if you know only some images have different colors, you +can set the tag just for those images: + + $imgs[2]->settag(name=>'gif_local_map', value=>1); + $imgs[4]->settag(name=>'gif_local_map', value=>1); + +and call write_multi() without a C<gif_local_map> parameter, or supply +an arrayref of values for the tag: + + Imager->write_multi({ file=>$filename, + type=>'gif', + make_colors=>'mediancut', + gif_local_map => [ 0, 0, 1, 0, 1 ] }, + @imgs); + +Other useful parameters include C<gif_delay> to control the delay +between frames and C<transp> to control transparency. + +=head2 Reading tags after reading an image + +This is pretty simple: + + # print the author of a TIFF, if any + my $img = Imager->new; + $img->read(file=>$filename, type='tiff') or die $img->errstr; + my $author = $img->tags(name=>'tiff_author'); + if (defined $author) { + print "Author: $author\n"; + } + +=head1 BUGS + +When saving Gif images the program does NOT try to shave of extra +colors if it is possible. If you specify 128 colors and there are +only 2 colors used - it will have a 128 colortable anyway. + +=head1 SEE ALSO + +Imager(3) + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Fill.pm b/Master/tlpkg/tlperl0/lib/Imager/Fill.pm new file mode 100755 index 00000000000..34786eade76 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Fill.pm @@ -0,0 +1,447 @@ +package Imager::Fill; +use strict; +use vars qw($VERSION); + +$VERSION = "1.010"; + +# this needs to be kept in sync with the array of hatches in fills.c +my @hatch_types = + qw/check1x1 check2x2 check4x4 vline1 vline2 vline4 + hline1 hline2 hline4 slash1 slosh1 slash2 slosh2 + grid1 grid2 grid4 dots1 dots4 dots16 stipple weave cross1 cross2 + vlozenge hlozenge scalesdown scalesup scalesleft scalesright stipple2 + tile_L stipple3/; +my %hatch_types; +@hatch_types{@hatch_types} = 0..$#hatch_types; + +*_color = \&Imager::_color; + +sub new { + my ($class, %hsh) = @_; + + my $self = bless { }, $class; + $hsh{combine} = Imager->_combine($hsh{combine}, 0); + if ($hsh{solid}) { + my $solid = _color($hsh{solid}); + if (UNIVERSAL::isa($solid, 'Imager::Color')) { + $self->{fill} = + Imager::i_new_fill_solid($solid, $hsh{combine}); + } + elsif (UNIVERSAL::isa($solid, 'Imager::Color::Float')) { + $self->{fill} = + Imager::i_new_fill_solidf($solid, $hsh{combine}); + } + else { + $Imager::ERRSTR = "solid isn't a color"; + return undef; + } + } + elsif (defined $hsh{hatch}) { + $hsh{dx} ||= 0; + $hsh{dy} ||= 0; + $hsh{fg} ||= Imager::Color->new(0, 0, 0); + if (ref $hsh{hatch}) { + $hsh{cust_hatch} = pack("C8", @{$hsh{hatch}}); + $hsh{hatch} = 0; + } + elsif ($hsh{hatch} =~ /\D/) { + unless (exists($hatch_types{$hsh{hatch}})) { + $Imager::ERRSTR = "Unknown hatch type $hsh{hatch}"; + return undef; + } + $hsh{hatch} = $hatch_types{$hsh{hatch}}; + } + my $fg = _color($hsh{fg}); + if (UNIVERSAL::isa($fg, 'Imager::Color')) { + my $bg = _color($hsh{bg} || Imager::Color->new(255, 255, 255)); + $self->{fill} = + Imager::i_new_fill_hatch($fg, $bg, $hsh{combine}, + $hsh{hatch}, $hsh{cust_hatch}, + $hsh{dx}, $hsh{dy}); + } + elsif (UNIVERSAL::isa($fg, 'Imager::Color::Float')) { + my $bg = _color($hsh{bg} || Imager::Color::Float->new(1, 1, 1)); + $self->{fill} = + Imager::i_new_fill_hatchf($fg, $bg, $hsh{combine}, + $hsh{hatch}, $hsh{cust_hatch}, + $hsh{dx}, $hsh{dy}); + } + else { + $Imager::ERRSTR = "fg isn't a color"; + return undef; + } + } + elsif (defined $hsh{fountain}) { + # make sure we track the filter's defaults + my $fount = $Imager::filters{fountain}; + my $def = $fount->{defaults}; + my $names = $fount->{names}; + + $hsh{ftype} = $hsh{fountain}; + # process names of values + for my $name (keys %$names) { + if (defined $hsh{$name} && exists $names->{$name}{$hsh{$name}}) { + $hsh{$name} = $names->{$name}{$hsh{$name}}; + } + } + # process defaults + %hsh = (%$def, %hsh); + my @parms = @{$fount->{callseq}}; + shift @parms; + for my $name (@parms) { + unless (defined $hsh{$name}) { + $Imager::ERRSTR = + "required parameter '$name' not set for fountain fill"; + return undef; + } + } + + # check that the segments supplied is an array ref + unless (ref $hsh{segments} && $hsh{segments} =~ /ARRAY/) { + $Imager::ERRSTR = + "segments must be an array reference or Imager::Fountain object"; + return; + } + + # make sure the segments are specified with colors + my @segments; + for my $segment (@{$hsh{segments}}) { + my @new_segment = @$segment; + + $_ = _color($_) or return for @new_segment[3,4]; + push @segments, \@new_segment; + } + + $self->{fill} = + Imager::i_new_fill_fount($hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb}, + $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample}, + $hsh{ssample_param}, \@segments); + } + elsif (defined $hsh{image}) { + $hsh{xoff} ||= 0; + $hsh{yoff} ||= 0; + $self->{fill} = + Imager::i_new_fill_image($hsh{image}{IMG}, $hsh{matrix}, $hsh{xoff}, + $hsh{yoff}, $hsh{combine}); + $self->{DEPS} = [ $hsh{image}{IMG} ]; + } + elsif (defined $hsh{type} && $hsh{type} eq "opacity") { + my $other_fill = delete $hsh{other}; + unless (defined $other_fill) { + Imager->_set_error("'other' parameter required to create opacity fill"); + return; + } + unless (ref $other_fill && + eval { $other_fill->isa("Imager::Fill") }) { + # try to auto convert to a fill object + if (ref $other_fill && $other_fill =~ /HASH/) { + $other_fill = Imager::Fill->new(%$other_fill) + or return; + } + else { + undef $other_fill; + } + unless ($other_fill) { + Imager->_set_error("'other' parameter must be an Imager::Fill object to create an opacity fill"); + return; + } + } + + my $raw_fill = $other_fill->{fill}; + my $opacity = delete $hsh{opacity}; + defined $opacity or $opacity = 0.5; # some sort of default + $self->{fill} = + Imager::i_new_fill_opacity($raw_fill, $opacity); + $self->{DEPS} = [ $other_fill ]; # keep reference to old fill and its deps + } + else { + $Imager::ERRSTR = "No fill type specified"; + warn "No fill type!"; + return undef; + } + + $self; +} + +sub hatches { + return @hatch_types; +} + +sub combines { + return Imager->combines; +} + +1; + +=head1 NAME + + Imager::Fill - general fill types + +=head1 SYNOPSIS + + use Imager; + use Imager::Fill; + + my $fill1 = Imager::Fill->new(solid=>$color, combine=>$combine); + my $fill2 = Imager::Fill->new(hatch=>'vline2', fg=>$color1, bg=>$color2, + dx=>$dx, dy=>$dy); + my $fill3 = Imager::Fill->new(fountain=>$type, ...); + my $fill4 = Imager::Fill->new(image=>$img, ...); + my $fill5 = Imager::Fill->new(type => "opacity", other => $fill, + opacity => ...); + +=head1 DESCRIPTION + +Creates fill objects for use by most filled area drawing functions. + +All fills are created with the new method. + +=over + +=item new + + my $fill = Imager::Fill->new(...); + +The parameters depend on the type of fill being created. See below +for details. + +=back + +The currently available fills are: + +=over + +=item * + +solid + +=item * + +hatch + +=item * + +fountain (similar to gradients in paint software) + +=back + +=head1 Common options + +=over + +=item combine + +The way in which the fill data is combined with the underlying image. +See L<Imager::Draw/"Combine Types">. + +=back + +In general colors can be specified as Imager::Color or +Imager::Color::Float objects. The fill object will typically store +both types and convert from one to the other. If a fill takes 2 color +objects they should have the same type. + +=head2 Solid fills + + my $fill = Imager::Fill->new(solid=>$color, $combine =>$combine) + +Creates a solid fill, the only required parameter is C<solid> which +should be the color to fill with. + +=head2 Hatched fills + + my $fill = Imager::Fill->new(hatch=>$type, fg=>$fgcolor, bg=>$bgcolor, + dx=>$dx, $dy=>$dy); + +Creates a hatched fill. You can specify the following keywords: + +=over + +=item hatch + +The type of hatch to perform, this can either be the numeric index of +the hatch (not recommended), the symbolic name of the hatch, or an +array of 8 integers which specify the pattern of the hatch. + +Hatches are represented as cells 8x8 arrays of bits, which limits their +complexity. + +Current hatch names are: + +=over + +=item check1x1, check2x2, check4x4 + +checkerboards at varios sizes + +=item vline1, vline2, vline4 + +1, 2, or 4 vertical lines per cell + +=item hline1, hline2, hline4 + +1, 2, or 4 horizontal lines per cell + +=item slash1, slash2 + +1 or 2 / lines per cell. + +=item slosh1, slosh2 + +1 or 2 \ lines per cell + +=item grid1, grid2, grid4 + +1, 2, or 4 vertical and horizontal lines per cell + +=item dots1, dots4, dots16 + +1, 4 or 16 dots per cell + +=item stipple, stipple2 + +see the samples + +=item weave + +I hope this one is obvious. + +=item cross1, cross2 + +2 densities of crosshatch + +=item vlozenge, hlozenge + +something like lozenge tiles + +=item scalesdown, scalesup, scalesleft, scalesright + +Vaguely like fish scales in each direction. + +=item tile_L + +L-shaped tiles + +=back + +=item fg + +=item bg + +The fg color is rendered where bits are set in the hatch, and the bg +where they are clear. If you use a transparent fg or bg, and set +combine, you can overlay the hatch onto an existing image. + +fg defaults to black, bg to white. + +=item dx + +=item dy + +An offset into the hatch cell. Both default to zero. + +=back + +You can call Imager::Fill->hatches for a list of hatch names. + +=head2 Fountain fills + + my $fill = Imager::Fill->new(fountain=>$ftype, + xa=>$xa, ya=>$ya, xb=>$xb, yb=>$yb, + segments=>$segments, repeat=>$repeat, combine=>$combine, + super_sample=>$super_sample, ssample_param=>$ssample_param); + +This fills the given region with a fountain fill. This is exactly the +same fill as the C<fountain> filter, but is restricted to the shape +you are drawing, and the fountain parameter supplies the fill type, +and is required. + +=head2 Image Fills + + my $fill = Imager::Fill->new(image=>$src, xoff=>$xoff, yoff=>$yoff, + matrix=>$matrix, $combine); + +Fills the given image with a tiled version of the given image. The +first non-zero value of xoff or yoff will provide an offset along the +given axis between rows or columns of tiles respectively. + +The matrix parameter performs a co-ordinate transformation from the +co-ordinates in the target image to the fill image co-ordinates. +Linear interpolation is used to determine the fill pixel. You can use +the L<Imager::Matrix2d> class to create transformation matrices. + +The matrix parameter will significantly slow down the fill. + +=head2 Opacity modification fill + + my $fill = Imager::Fill->new(type => "opacity", + other => $fill, opacity => 0.25); + +This can be used to make a fill that is a more translucent or opaque +version of an existing fill. This is intended for use where you +receive a fill object as a parameter and need to change the opacity. + +Parameters: + +=over + +=item * + +type => "opacity" - Required + +=item * + +other - the fill to produce a modified version of. This must be an +Imager::Fill object. Required. + +=item * + +opacity - multiplier for the source fill opacity. Default: 0.5. + +=back + +The source fill's combine mode is used. + +=head1 OTHER METHODS + +=over + +=item Imager::Fill->hatches + +A list of all defined hatch names. + +=item Imager::Fill->combines + +A list of all combine types. + +=back + +=head1 FUTURE PLANS + +I'm planning on adding the following types of fills: + +=over + +=item checkerboard + +combines 2 other fills in a checkerboard + +=item combine + +combines 2 other fills using the levels of an image + +=item regmach + +uses the transform2() register machine to create fills + +=back + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 SEE ALSO + +Imager(3) + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Filter/DynTest.pm b/Master/tlpkg/tlperl0/lib/Imager/Filter/DynTest.pm new file mode 100755 index 00000000000..05f04a1f5c3 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Filter/DynTest.pm @@ -0,0 +1,32 @@ +package Imager::Filter::DynTest; +use strict; +use Imager; +use vars qw($VERSION @ISA); + +BEGIN { + $VERSION = "0.01"; + + eval { + require XSLoader; + XSLoader::load('Imager::Filter::DynTest', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::Filter::DynTest $VERSION; + }; +} + + +sub _lin_stretch { + my %hsh = @_; + + lin_stretch($hsh{image}, $hsh{a}, $hsh{b}); +} + +Imager->register_filter(type=>'lin_stretch', + callsub => \&_lin_stretch, + defaults => { a => 0, b => 255 }, + callseq => [ qw/image a b/ ]); + +1; diff --git a/Master/tlpkg/tlperl0/lib/Imager/Filter/Flines.pm b/Master/tlpkg/tlperl0/lib/Imager/Filter/Flines.pm new file mode 100755 index 00000000000..53905058d8a --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Filter/Flines.pm @@ -0,0 +1,57 @@ +package Imager::Filter::Flines; +use strict; +use Imager; +use vars qw($VERSION @ISA); + +BEGIN { + $VERSION = "0.01"; + + eval { + require XSLoader; + XSLoader::load('Imager::Filter::Flines', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::Filter::Flines $VERSION; + }; +} + +Imager->register_filter(type=>'flines', + callsub => sub { my %hsh = @_; flines($hsh{image}) }, + defaults => {}, + callseq => [ 'image' ] ); + +1; + +__END__ + +=head1 NAME + +Imager::Filter::Flines - dim alternate lines to emulate a video display + +=head1 SYNOPSIS + + use Imager; + use Imager::Filter::Flines; + + $img->filter(type=>'flines'); + +=head1 DESCRIPTION + +This is an adaption of the flines dynamically loadable filter +provided in dynfilt/ in previous releases of Imager. + +This filter has no parameters. + +=head1 AUTHOR + +Original by Arnar M. Hrafnkelsson. + +Adapted by Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::Filters. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Filter/Mandelbrot.pm b/Master/tlpkg/tlperl0/lib/Imager/Filter/Mandelbrot.pm new file mode 100755 index 00000000000..f762fa1d85b --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Filter/Mandelbrot.pm @@ -0,0 +1,91 @@ +package Imager::Filter::Mandelbrot; +use strict; +use Imager; +use vars qw($VERSION @ISA); + +BEGIN { + $VERSION = "0.01"; + + eval { + require XSLoader; + XSLoader::load('Imager::Filter::Mandelbrot', $VERSION); + 1; + } or do { + require DynaLoader; + push @ISA, 'DynaLoader'; + bootstrap Imager::Filter::Mandelbrot $VERSION; + }; +} + +sub _mandelbrot { + my %hsh = @_; + + mandelbrot($hsh{image}, $hsh{minx}, $hsh{miny}, $hsh{maxx}, $hsh{maxy}, $hsh{maxiter}); +} + +my %defaults = + ( + minx => -2.5, + maxx => 1.5, + miny => -1.5, + maxy => 1.5, + maxiter => 256, + ); + +my @callseq = qw/image minx miny maxx maxy maxiter/; + +Imager->register_filter(type=>'mandelbrot', + callsub => \&_mandelbrot, + defaults => \%defaults, + callseq => \@callseq); + +1; + +__END__ + +=head1 NAME + +Imager::Filter::Mandelbrot - filter that renders the Mandelbrot set. + +=head1 SYNOPSIS + + use Imager; + use Imager::Filter::Mandelbrot; + + $img->filter(type=>'mandelbrot', ...); + +=head1 DESCRIPTION + +This is a expansion of the mandelbrot dynamically loadable filter +provided in dynfilt in previous releases of Imager. + +Valid filter parameters are: + +=over + +=item * + +minx, maxx - the range of x values to render. Defaults: -2.5, 1.5. + +=item * + +miny, maxy - the range of y values to render. Defaults: -1.5, 1.5 + +=item * + +maxiter - the maximum number of iterations to perform when checking if +the sequence tend towards infinity. + +=back + +=head1 AUTHOR + +Original by Arnar M. Hrafnkelsson. + +Adapted and expanded by Tony Cook <tony@imager.perl.org> + +=head1 SEE ALSO + +Imager, Imager::Filters. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Filters.pod b/Master/tlpkg/tlperl0/lib/Imager/Filters.pod new file mode 100755 index 00000000000..3ee181af101 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Filters.pod @@ -0,0 +1,703 @@ +=head1 NAME + +Imager::Filters - Entire Image Filtering Operations + +=head1 SYNOPSIS + + use Imager; + + $img = ...; + + $img->filter(type=>'autolevels'); + $img->filter(type=>'autolevels', lsat=>0.2); + $img->filter(type=>'turbnoise') + + # and lots of others + + load_plugin("dynfilt/dyntest.so") + or die "unable to load plugin\n"; + + $img->filter(type=>'lin_stretch', a=>35, b=>200); + + unload_plugin("dynfilt/dyntest.so") + or die "unable to load plugin\n"; + + $out = $img->difference(other=>$other_img); + +=head1 DESCRIPTION + +Filters are operations that have similar calling interface. + +=over + +=item filter + +Parameters: + +=over + +=item * + +type - the type of filter, see L</Types of Filters>. + +=item * + +many other possible parameters, see L</Types of Filters> below. + +=back + +=back + +=head2 Types of Filters + +Here is a list of the filters that are always avaliable in Imager. +This list can be obtained by running the C<filterlist.perl> script +that comes with the module source. + + Filter Arguments Default value + autolevels lsat 0.1 + usat 0.1 + skew 0 + + bumpmap bump lightx lighty + elevation 0 + st 2 + + bumpmap_complex bump + channel 0 + tx 0 + ty 0 + Lx 0.2 + Ly 0.4 + Lz -1 + cd 1.0 + cs 40.0 + n 1.3 + Ia (0 0 0) + Il (255 255 255) + Is (255 255 255) + + contrast intensity + + conv coef + + fountain xa ya xb yb + ftype linear + repeat none + combine none + super_sample none + ssample_param 4 + segments(see below) + + gaussian stddev + + gradgen xo yo colors + dist 0 + + hardinvert + + mosaic size 20 + + noise amount 3 + subtype 0 + + postlevels levels 10 + + radnoise xo 100 + yo 100 + ascale 17.0 + rscale 0.02 + + turbnoise xo 0.0 + yo 0.0 + scale 10.0 + + unsharpmask stddev 2.0 + scale 1.0 + + watermark wmark + pixdiff 10 + tx 0 + ty 0 + +All parameters must have some value but if a parameter has a default +value it may be omitted when calling the filter function. + +Every one of these filters modifies the image in place. + +If none of the filters here do what you need, the +L<Imager::Engines/tranform> or L<Imager::Engines/transform2> function +may be useful. + +A reference of the filters follows: + +=over + +=item autolevels + +scales the value of each channel so that the values in the image will +cover the whole possible range for the channel. I<lsat> and I<usat> +truncate the range by the specified fraction at the top and bottom of +the range respectivly. + + # increase contrast per channel, losing little detail + $img->filter(type=>"autolevels") + or die $img->errstr; + + # increase contrast, losing 20% of highlight at top and bottom range + $img->filter(type=>"autolevels", lsat=>0.2, usat=>0.2) + or die $img->errstr; + +=item bumpmap + +uses the channel I<elevation> image I<bump> as a bumpmap on your +image, with the light at (I<lightx>, I<lightty>), with a shadow length +of I<st>. + + $img->filter(type=>"bumpmap", bump=>$bumpmap_img, + lightx=>10, lighty=>10, st=>5) + or die $img->errstr; + +=item bumpmap_complex + +uses the channel I<channel> image I<bump> as a bumpmap on your image. +If Lz<0 the three L parameters are considered to be the direction of +the light. If Lz>0 the L parameters are considered to be the light +position. I<Ia> is the ambient colour, I<Il> is the light colour, +I<Is> is the color of specular highlights. I<cd> is the diffuse +coefficient and I<cs> is the specular coefficient. I<n> is the +shininess of the surface. + + $img->filter(type=>"bumpmap_complex", bump=>$bumpmap_img) + or die $img->errstr; + +=item contrast + +scales each channel by I<intensity>. Values of I<intensity> < 1.0 +will reduce the contrast. + + # higher contrast + $img->filter(type=>"contrast", intensity=>1.3) + or die $img->errstr; + + # lower contrast + $img->filter(type=>"contrast", intensity=>0.8) + or die $img->errstr; + +=item conv + +performs 2 1-dimensional convolutions on the image using the values +from I<coef>. I<coef> should be have an odd length and the sum of the +coefficients must be non-zero. + + # sharper + $img->filter(type=>"conv", coef=>[-0.5, 2, -0.5 ]) + or die $img->errstr; + + # blur + $img->filter(type=>"conv", coef=>[ 1, 2, 1 ]) + or die $img->errstr; + + # error + $img->filter(type=>"conv", coef=>[ -0.5, 1, -0.5 ]) + or die $img->errstr; + +=item fountain + +renders a fountain fill, similar to the gradient tool in most paint +software. The default fill is a linear fill from opaque black to +opaque white. The points A(xa, ya) and B(xb, yb) control the way the +fill is performed, depending on the ftype parameter: + +=over + +=item linear + +the fill ramps from A through to B. + +=item bilinear + +the fill ramps in both directions from A, where AB defines the length +of the gradient. + +=item radial + +A is the center of a circle, and B is a point on it's circumference. +The fill ramps from the center out to the circumference. + +=item radial_square + +A is the center of a square and B is the center of one of it's sides. +This can be used to rotate the square. The fill ramps out to the +edges of the square. + +=item revolution + +A is the centre of a circle and B is a point on it's circumference. B +marks the 0 and 360 point on the circle, with the fill ramping +clockwise. + +=item conical + +A is the center of a circle and B is a point on it's circumference. B +marks the 0 and point on the circle, with the fill ramping in both +directions to meet opposite. + +=back + +The I<repeat> option controls how the fill is repeated for some +I<ftype>s after it leaves the AB range: + +=over + +=item none + +no repeats, points outside of each range are treated as if they were +on the extreme end of that range. + +=item sawtooth + +the fill simply repeats in the positive direction + +=item triangle + +the fill repeats in reverse and then forward and so on, in the +positive direction + +=item saw_both + +the fill repeats in both the positive and negative directions (only +meaningful for a linear fill). + +=item tri_both + +as for triangle, but in the negative direction too (only meaningful +for a linear fill). + +=back + +By default the fill simply overwrites the whole image (unless you have +parts of the range 0 through 1 that aren't covered by a segment), if +any segments of your fill have any transparency, you can set the +I<combine> option to 'normal' to have the fill combined with the +existing pixels. See the description of I<combine> in L<Imager::Fill>. + +If your fill has sharp edges, for example between steps if you use +repeat set to 'triangle', you may see some aliased or ragged edges. +You can enable super-sampling which will take extra samples within the +pixel in an attempt anti-alias the fill. + +The possible values for the super_sample option are: + +=over + +=item none + +no super-sampling is done + +=item grid + +a square grid of points are sampled. The number of points sampled is +the square of ceil(0.5 + sqrt(ssample_param)). + +=item random + +a random set of points within the pixel are sampled. This looks +pretty bad for low ssample_param values. + +=item circle + +the points on the radius of a circle within the pixel are sampled. +This seems to produce the best results, but is fairly slow (for now). + +=back + +You can control the level of sampling by setting the ssample_param +option. This is roughly the number of points sampled, but depends on +the type of sampling. + +The segments option is an arrayref of segments. You really should use +the L<Imager::Fountain> class to build your fountain fill. Each +segment is an array ref containing: + +=over + +=item start + +a floating point number between 0 and 1, the start of the range of +fill parameters covered by this segment. + +=item middle + +a floating point number between start and end which can be used to +push the color range towards one end of the segment. + +=item end + +a floating point number between 0 and 1, the end of the range of fill +parameters covered by this segment. This should be greater than +start. + +=item c0 + +=item c1 + +The colors at each end of the segment. These can be either +Imager::Color or Imager::Color::Float objects. + +=item segment type + +The type of segment, this controls the way the fill parameter varies +over the segment. 0 for linear, 1 for curved (unimplemented), 2 for +sine, 3 for sphere increasing, 4 for sphere decreasing. + +=item color type + +The way the color varies within the segment, 0 for simple RGB, 1 for +hue increasing and 2 for hue decreasing. + +=back + +Don't forget to use Imager::Fountain instead of building your own. +Really. It even loads GIMP gradient files. + + # build the gradient the hard way - linear from black to white, + # then back again + my @simple = + ( + [ 0, 0.25, 0.5, 'black', 'white', 0, 0 ], + [ 0.5. 0.75, 1.0, 'white', 'black', 0, 0 ], + ); + # across + my $linear = $img->copy; + $linear->filter(type => "fountain", + ftype => 'linear', + repeat => 'sawtooth', + segments => \@simple, + xa => 0, + ya => $linear->getheight / 2, + xb => $linear->getwidth - 1, + yb => $linear->getheight / 2) + or die $linear->errstr; + # around + my $revolution = $img->copy; + $revolution->filter(type => "fountain", + ftype => 'revolution', + segments => \@simple, + xa => $revolution->getwidth / 2, + ya => $revolution->getheight / 2, + xb => $revolution->getwidth / 2, + yb => 0) + or die $revolution->errstr; + # out from the middle + my $radial = $img->copy; + $radial->filter(type => "fountain", + ftype => 'radial', + segments => \@simple, + xa => $im->getwidth / 2, + ya => $im->getheight / 2, + xb => $im->getwidth / 2, + yb => 0) + or die $radial->errstr; + +=item gaussian + +performs a gaussian blur of the image, using I<stddev> as the standard +deviation of the curve used to combine pixels, larger values give +bigger blurs. For a definition of Gaussian Blur, see: + + http://www.maths.abdn.ac.uk/~igc/tch/mx4002/notes/node99.html + +Values of C<stddev> around 0.5 provide a barely noticable blur, values +around 5 provide a very strong blur. + + # only slightly blurred + $img->filter(type=>"gaussian", stddev=>0.5) + or die $img->errstr; + + # more strongly blurred + $img->filter(type=>"gaussian", stddev=>5) + or die $img->errstr; + +=item gradgen + +renders a gradient, with the given I<colors> at the corresponding +points (x,y) in I<xo> and I<yo>. You can specify the way distance is +measured for color blending by setting I<dist> to 0 for Euclidean, 1 +for Euclidean squared, and 2 for Manhattan distance. + + $img->filter(type="gradgen", + xo=>[ 10, 50, 10 ], + yo=>[ 10, 50, 50 ], + colors=>[ qw(red blue green) ]); + +=item hardinvert + +inverts the image, black to white, white to black. All channels are +inverted, including the alpha channel if any. + + $img->filter(type=>"hardinvert") + or die $img->errstr; + +=item mosaic + +produces averaged tiles of the given I<size>. + + $img->filter(type=>"mosaic", size=>5) + or die $img->errstr; + +=item noise + +adds noise of the given I<amount> to the image. If I<subtype> is +zero, the noise is even to each channel, otherwise noise is added to +each channel independently. + + # monochrome noise + $img->filter(type=>"noise", amount=>20, subtype=>0) + or die $img->errstr; + + # color noise + $img->filter(type=>"noise", amount=>20, subtype=>1) + or die $img->errstr; + +=item radnoise + +renders radiant Perlin turbulent noise. The centre of the noise is at +(I<xo>, I<yo>), I<ascale> controls the angular scale of the noise , +and I<rscale> the radial scale, higher numbers give more detail. + + $img->filter(type=>"radnoise", xo=>50, yo=>50, + ascale=>1, rscale=>0.02) + or die $img->errstr; + +=item postlevels + +alters the image to have only I<levels> distinct level in each +channel. + + $img->filter(type=>"postlevels", levels=>10) + or die $img->errstr; + +=item turbnoise + +renders Perlin turbulent noise. (I<xo>, I<yo>) controls the origin of +the noise, and I<scale> the scale of the noise, with lower numbers +giving more detail. + + $img->filter(type=>"turbnoise", xo=>10, yo=>10, scale=>10) + or die $img->errstr; + +=item unsharpmask + +performs an unsharp mask on the image. This increases the contrast of +edges in the image. + +This is the result of subtracting a gaussian blurred version of the +image from the original. I<stddev> controls the stddev parameter of +the gaussian blur. Each output pixel is: in + I<scale> * (in - +blurred). + + $img->filter(type=>"unsharpmask", stddev=>1, scale=>0.5) + or die $img->errstr; + +unsharpmark has the following parameters: + +=over + +=item * + +stddev - this is equivalent to the C<Radius> value in the GIMP's +unsharpmask filter. This controls the size of the contrast increase +around edges, larger values will remove fine detail. You should +probably experiement on the types of images you plan to work with. +Default: 2.0. + +=item * + +scale - controls the strength of the edge enhancement, equivalent to +I<Amount> in the GIMP's unsharp mask filter. Default: 1.0. + +=back + +=item watermark + +applies I<wmark> as a watermark on the image with strength I<pixdiff>, +with an origin at (I<tx>, I<ty>) + + $img->filter(type=>"watermark", tx=>10, ty=>50, + wmark=>$wmark_image, pixdiff=>50) + or die $img->errstr; + +=back + +A demonstration of most of the filters can be found at: + + http://www.develop-help.com/imager/filters.html + +=head2 External Filters + +As of Imager 0.48 you can create perl or XS based filters and hook +them into Imager's filter() method: + +=over + +=item register_filter + +Registers a filter so it is visible via Imager's filter() method. + + Imager->register_filter(type => 'your_filter', + defaults => { parm1 => 'default1' }, + callseq => [ qw/image parm1/ ], + callsub => \&your_filter); + $img->filter(type=>'your_filter', parm1 => 'something'); + +The following parameters are needed: + +=over + +=item * + +type - the type value that will be supplied to filter() to use your +filter. + +=item * + +defaults - a hash of defaults for the filter's parameters + +=item * + +callseq - a reference to an array of required parameter names. + +=item * + +callsub - a code reference called to execute your filter. The +parameters passed to filter() are supplied as a list of parameter +name, value ... which can be assigned to a hash. + +The special parameters C<image> and C<imager> are supplied as the low +level image object from $self and $self itself respectively. + +The function you supply must modify the image in place. + +=back + +See Imager::Filter::Mandelbrot for an example. + +=back + +=head2 Plugins + +The plugin interface is deprecated. Please use the Imager API, see +L</Imager::API> and L<External Filters> for details + +It is possible to add filters to the module without recompiling the +module itself. This is done by using DSOs (Dynamic shared object) +avaliable on most systems. This way you can maintain our own filters +and not have to get me to add it, or worse patch every new version of +the Module. Modules can be loaded AND UNLOADED at runtime. This +means that you can have a server/daemon thingy that can do something +like: + + load_plugin("dynfilt/dyntest.so") + or die "unable to load plugin\n"; + + $img->filter(type=>'lin_stretch', a=>35, b=>200); + + unload_plugin("dynfilt/dyntest.so") + or die "unable to load plugin\n"; + +Someone decides that the filter is not working as it should - +dyntest.c modified and recompiled. + + load_plugin("dynfilt/dyntest.so") + or die "unable to load plugin\n"; + + $img->filter(%hsh); + +An example plugin comes with the module - Please send feedback to +addi@umich.edu if you test this. + +Note: This seems to test ok on the following systems: +Linux, Solaris, HPUX, OpenBSD, FreeBSD, TRU64/OSF1, AIX. +If you test this on other systems please let me know. + +=over + +=item load_plugin + +This is a function, not a method, exported by default. You should +import this function explicitly for future compatibility if you need +it. + +Accepts a single parameter, the name of a shared library file to load. + +Returns true on success. Check Imager->errstr on failure. + +=item unload_plugin + +This is a function, not a method, which is exported by default. You +should import this function explicitly for future compatibility if you +need it. + +Accepts a single parameter, the name of a shared library to unload. +This library must have been previously loaded by load_plugin(). + +Returns true on success. Check Imager->errstr on failure. + +=back + +=head2 Image Difference + +=over + +=item difference + +You can create a new image that is the difference between 2 other images. + + my $diff = $img->difference(other=>$other_img); + +For each pixel in $img that is different to the pixel in $other_img, +the pixel from $other_img is given, otherwise the pixel is transparent +black. + +This can be used for debugging image differences ("Where are they +different?"), and for optimizing animated GIFs. + +Note that $img and $other_img must have the same number of channels. +The width and height of $diff will be the minimum of each of the width +and height of $img and $other_img. + +Parameters: + +=over + +=item * + +other - the other image object to compare against + +=item * + +mindist - the difference between corresponding samples must be greater +than I<mindist> for the pixel to be considered different. So a value +of zero returns all different pixels, not all pixels. Range: 0 to 255 +inclusive. Default: 0. + +For large sample images this is scaled down to the range 0 .. 1. + +=back + +=back + +=head1 AUTHOR + +Arnar M. Hrafnkelsson, Tony Cook <tony@imager.perl.org>. + +=head1 SEE ALSO + +Imager, Imager::Filter::Flines, Imager::Filter::Mandelbrot + +=head1 REVISION + +$Revision: 1643 $ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font.pm b/Master/tlpkg/tlperl0/lib/Imager/Font.pm new file mode 100755 index 00000000000..0662421e1b8 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font.pm @@ -0,0 +1,1001 @@ +package Imager::Font; + +use Imager::Color; +use strict; +use vars qw($VERSION); + +$VERSION = "1.033"; + +# the aim here is that we can: +# - add file based types in one place: here +# - make sure we only attempt to create types that exist +# - give reasonable defaults +# - give the user some control over which types get used +my %drivers = + ( + tt=>{ + class=>'Imager::Font::Truetype', + module=>'Imager/Font/Truetype.pm', + files=>'.*\.ttf$', + description => 'FreeType 1.x', + }, + t1=>{ + class=>'Imager::Font::Type1', + module=>'Imager/Font/Type1.pm', + files=>'.*\.pfb$', + description => 'T1Lib', + }, + ft2=>{ + class=>'Imager::Font::FreeType2', + module=>'Imager/Font/FreeType2.pm', + files=>'.*\.(pfa|pfb|otf|ttf|fon|fnt|dfont|pcf(\.gz)?)$', + description => 'FreeType 2.x', + }, + ifs=>{ + class=>'Imager::Font::Image', + module=>'Imager/Font/Image.pm', + files=>'.*\.ifs$', + }, + w32=>{ + class=>'Imager::Font::Win32', + module=>'Imager/Font/Win32.pm', + description => 'Win32 GDI Fonts', + }, + ); + +# this currently should only contain file based types, don't add w32 +my @priority = qw(t1 tt ft2 ifs); + +# when Imager::Font is loaded, Imager.xs has not been bootstrapped yet +# this function is called from Imager.pm to finish initialization +sub __init { + @priority = grep Imager::i_has_format($_), @priority; + for my $driver_name (grep Imager::i_has_format($_), keys %drivers) { + $drivers{$driver_name}{enabled} = 1; + } +} + +# search method +# 1. start by checking if file is the parameter +# 1a. if so qualify path and compare to the cache. +# 2a. if in cache - take it's id from there and increment count. +# + +sub new { + my $class = shift; + my $self = {}; + my ($file, $type, $id); + my %hsh=(color => Imager::Color->new(255,0,0,0), + size => 15, + @_); + + bless $self,$class; + + if ($hsh{'file'}) { + $file = $hsh{'file'}; + if ( $file !~ m/^\// ) { + $file = './'.$file; + if (! -e $file) { + $Imager::ERRSTR = "Font $file not found"; + return(); + } + } + + $type = $hsh{'type'}; + if (!defined($type) or !$drivers{$type} or !$drivers{$type}{enabled}) { + for my $drv (@priority) { + undef $type; + my $re = $drivers{$drv}{files} or next; + if ($file =~ /$re/i) { + $type = $drv; + last; + } + } + } + if (!defined($type)) { + # some types we can support, but the driver isn't available + # work out which drivers support it, so we can provide the user + # some useful information on how to get it working + my @not_here; + for my $driver_name (keys %drivers) { + my $driver = $drivers{$driver_name}; + push @not_here, "$driver_name ($driver->{description})" + if $driver->{files} && $file =~ /$driver->{files}/i; + } + if (@not_here) { + $Imager::ERRSTR = "No font drivers enabled that can support this file, rebuild Imager with any of ".join(", ", @not_here)." to use this font file"; + } + else { + $Imager::ERRSTR = "No font type found for $hsh{'file'}"; + } + return; + } + } elsif ($hsh{face}) { + $type = "w32"; + } else { + $Imager::ERRSTR="No font file specified"; + return; + } + + if (!$Imager::formats{$type}) { + $Imager::ERRSTR = "`$type' not enabled"; + return; + } + + # here we should have the font type or be dead already. + + require $drivers{$type}{module}; + return $drivers{$type}{class}->new(%hsh); +} + +# returns first defined parameter +sub _first { + for (@_) { + return $_ if defined $_; + } + return undef; +} + +sub draw { + my $self = shift; + my %input = ('x' => 0, 'y' => 0, @_); + unless ($input{image}) { + $Imager::ERRSTR = 'No image supplied to $font->draw()'; + return; + } + my $image = $input{image}; + $input{string} = _first($input{string}, $input{text}); + unless (defined $input{string}) { + $image->_set_error("Missing required parameter 'string'"); + return; + } + $input{aa} = _first($input{aa}, $input{antialias}, $self->{aa}, 1); + # the original draw code worked this out but didn't use it + $input{align} = _first($input{align}, $self->{align}); + $input{color} = _first($input{color}, $self->{color}); + $input{color} = Imager::_color($input{'color'}); + + $input{size} = _first($input{size}, $self->{size}); + unless (defined $input{size}) { + $image->_set_error("No font size provided"); + return undef; + } + $input{align} = _first($input{align}, 1); + $input{utf8} = _first($input{utf8}, $self->{utf8}, 0); + $input{vlayout} = _first($input{vlayout}, $self->{vlayout}, 0); + + my $result = $self->_draw(%input); + unless ($result) { + $image->_set_error($image->_error_as_msg()); + } + + return $result; +} + +sub align { + my $self = shift; + my %input = ( halign => 'left', valign => 'baseline', + 'x' => 0, 'y' => 0, @_ ); + + # image needs to be supplied, but can be supplied as undef + unless (exists $input{image}) { + Imager->_set_error("Missing required parameter 'image'"); + return; + } + + my $errors_to = $input{image} || 'Imager'; + + my $text = _first($input{string}, $input{text}); + unless (defined $text) { + $errors_to->_set_error("Missing required parameter 'string'"); + return; + } + + my $size = _first($input{size}, $self->{size}); + my $utf8 = _first($input{utf8}, 0); + + my $bbox = $self->bounding_box(string=>$text, size=>$size, utf8=>$utf8); + my $valign = $input{valign}; + $valign = 'baseline' + unless $valign && $valign =~ /^(?:top|center|bottom|baseline)$/; + + my $halign = $input{halign}; + $halign = 'start' + unless $halign && $halign =~ /^(?:left|start|center|end|right)$/; + + my $x = $input{'x'}; + my $y = $input{'y'}; + + if ($valign eq 'top') { + $y += $bbox->ascent; + } + elsif ($valign eq 'center') { + $y += $bbox->ascent - $bbox->text_height / 2; + } + elsif ($valign eq 'bottom') { + $y += $bbox->descent; + } + # else baseline is the default + + if ($halign eq 'left') { + $x -= $bbox->start_offset; + } + elsif ($halign eq 'start') { + # nothing to do + } + elsif ($halign eq 'center') { + $x -= $bbox->start_offset + $bbox->total_width / 2; + } + elsif ($halign eq 'end') { + $x -= $bbox->advance_width; + } + elsif ($halign eq 'right') { + $x -= $bbox->advance_width - $bbox->right_bearing; + } + $x = int($x); + $y = int($y); + + if ($input{image}) { + delete @input{qw/x y/}; + $self->draw(%input, 'x' => $x, 'y' => $y, align=>1) + or return; + } + + return ($x+$bbox->start_offset, $y-$bbox->ascent, + $x+$bbox->end_offset, $y-$bbox->descent+1); +} + +sub bounding_box { + my $self=shift; + my %input=@_; + + if (!exists $input{'string'}) { + $Imager::ERRSTR='string parameter missing'; + return; + } + $input{size} ||= $self->{size}; + $input{sizew} = _first($input{sizew}, $self->{sizew}, 0); + $input{utf8} = _first($input{utf8}, $self->{utf8}, 0); + + my @box = $self->_bounding_box(%input); + + if (wantarray) { + if(@box && exists $input{'x'} and exists $input{'y'}) { + my($gdescent, $gascent)=@box[1,3]; + $box[1]=$input{'y'}-$gascent; # top = base - ascent (Y is down) + $box[3]=$input{'y'}-$gdescent; # bottom = base - descent (Y is down, descent is negative) + $box[0]+=$input{'x'}; + $box[2]+=$input{'x'}; + } elsif (@box && $input{'canon'}) { + $box[3]-=$box[1]; # make it cannoical (ie (0,0) - (width, height)) + $box[2]-=$box[0]; + } + return @box; + } + else { + require Imager::Font::BBox; + + return Imager::Font::BBox->new(@box); + } +} + +sub dpi { + my $self = shift; + + # I'm assuming a default of 72 dpi + my @old = (72, 72); + if (@_) { + $Imager::ERRSTR = "Setting dpi not implemented for this font type"; + return; + } + + return @old; +} + +sub transform { + my $self = shift; + + my %hsh = @_; + + # this is split into transform() and _transform() so we can + # implement other tags like: degrees=>12, which would build a + # 12 degree rotation matrix + # but I'll do that later + unless ($hsh{matrix}) { + $Imager::ERRSTR = "You need to supply a matrix"; + return; + } + + return $self->_transform(%hsh); +} + +sub _transform { + $Imager::ERRSTR = "This type of font cannot be transformed"; + return; +} + +sub utf8 { + return 0; +} + +sub priorities { + my $self = shift; + my @old = @priority; + + if (@_) { + @priority = grep Imager::i_has_format($_), @_; + } + return @old; +} + +1; + +__END__ + +=head1 NAME + +Imager::Font - Font handling for Imager. + +=head1 SYNOPSIS + + use Imager; + + $t1font = Imager::Font->new(file => 'pathtofont.pfb'); + $ttfont = Imager::Font->new(file => 'pathtofont.ttf'); + $w32font = Imager::Font->new(face => 'Times New Roman'); + + $blue = Imager::Color->new("#0000FF"); + $font = Imager::Font->new(file => 'pathtofont.ttf', + color => $blue, + size => 30); + + ($neg_width, + $global_descent, + $pos_width, + $global_ascent, + $descent, + $ascent, + $advance_width, + $right_bearing) = $font->bounding_box(string=>"Foo"); + + my $bbox_object = $font->bounding_box(string=>"Foo"); + + # documented in Imager::Draw + $img->string(font => $font, + text => "Model-XYZ", + x => 15, + y => 40, + size => 40, + color => $red, + aa => 1); + +=head1 DESCRIPTION + +This module handles creating Font objects used by imager. The module +also handles querying fonts for sizes and such. If both T1lib and +freetype were avaliable at the time of compilation then Imager should +be able to work with both truetype fonts and t1 postscript fonts. To +check if Imager is t1 or truetype capable you can use something like +this: + + use Imager; + print "Has truetype" if $Imager::formats{tt}; + print "Has t1 postscript" if $Imager::formats{t1}; + print "Has Win32 fonts" if $Imager::formats{w32}; + print "Has Freetype2" if $Imager::formats{ft2}; + +=over 4 + +=item new + +This creates a font object to pass to functions that take a font argument. + + $font = Imager::Font->new(file => 'denmark.ttf', + index => 0, + color => $blue, + size => 30, + aa => 1); + +This creates a font which is the truetype font denmark.ttf. It's +default color is $blue, default size is 30 pixels and it's rendered +antialised by default. Imager can see which type of font a file is by +looking at the suffix of the filename for the font. A suffix of 'ttf' +is taken to mean a truetype font while a suffix of 'pfb' is taken to +mean a t1 postscript font. If Imager cannot tell which type a font is +you can tell it explicitly by using the C<type> parameter: + + $t1font = Imager::Font->new(file => 'fruitcase', type => 't1'); + $ttfont = Imager::Font->new(file => 'arglebarf', type => 'tt'); + +The C<index> parameter is used to select a single face from a font +file containing more than one face, for example, from a Macintosh font +suitcase or a .dfont file. + +If any of the C<color>, C<size> or C<aa> parameters are omitted when +calling C<< Imager::Font->new() >> the they take the following values: + + color => Imager::Color->new(255, 0, 0, 0); # this default should be changed + size => 15 + aa => 0 + index => 0 + +To use Win32 fonts supply the facename of the font: + + $font = Imager::Font->new(face=>'Arial Bold Italic'); + +There isn't any access to other logical font attributes, but this +typically isn't necessary for Win32 TrueType fonts, since you can +contruct the full name of the font as above. + +Other logical font attributes may be added if there is sufficient demand. + +Parameters: + +=over + +=item * + +file - name of the file to load the font from. + +=item * + +face - face name. This is used only under Win32 to create a GDI based +font. This is ignored if the C<file> parameter is supplied. + +=item * + +type - font driver to use. Currently the permitted values for this are: + +=over + +=item * + +tt - Freetype 1.x driver. Supports TTF fonts. + +=item * + +t1 - T1 Lib driver. Supports Postscript Type 1 fonts. Allows for +synthesis of underline, strikethrough and overline. + +=item * + +ft2 - Freetype 2.x driver. Supports many different font formats. +Also supports the transform() method. + +=back + +=item * + +color - the default color used with this font. Default: red. + +=item * + +size - the default size used with this font. Default: 15. + +=item * + +utf8 - if non-zero then text supplied to $img->string(...) and +$font->bounding_box(...) is assumed to be UTF 8 encoded by default. + +=item * + +align - the default value for the $img->string(...) C<align> +parameter. Default: 1. + +=item * + +vlayout - the default value for the $img->string(...) C<vlayout> +parameter. Default: 0. + +=item * + +aa - the default value for the $im->string(...) C<aa> parameter. +Default: 0. + +=item * + +index - for font file containing multiple fonts this selects which +font to use. This is useful for Macintosh DFON (.dfont) and suitcase +font files. + +If you want to use a suitcase font you will need to tell Imager to use +the FreeType 2.x driver by setting C<type> to C<'ft2'>: + + my $font = Imager::Font->new(file=>$file, index => 1, type=>'ft2') + or die Imager->errstr; + +=back + + + +=item bounding_box + +Returns the bounding box for the specified string. Example: + + my ($neg_width, + $global_descent, + $pos_width, + $global_ascent, + $descent, + $ascent, + $advance_width, + $right_bearing) = $font->bounding_box(string => "A Fool"); + + my $bbox_object = $font->bounding_box(string => "A Fool"); + +=over + +=item C<$neg_width> + +the relative start of a the string. In some +cases this can be a negative number, in that case the first letter +stretches to the left of the starting position that is specified in +the string method of the Imager class + +=item C<$global_descent> + +how far down the lowest letter of the entire font reaches below the +baseline (this is often j). + +=item C<$pos_width> + +how wide the string from +the starting position is. The total width of the string is +C<$pos_width-$neg_width>. + +=item C<$descent> + +=item C<$ascent> + +the same as <$global_descent> and <$global_ascent> except that they +are only for the characters that appear in the string. + +=item C<$advance_width> + +the distance from the start point that the next string output should +start at, this is often the same as C<$pos_width>, but can be +different if the final character overlaps the right side of its +character cell. + +=item C<$right_bearing> + +The distance from the right side of the final glyph to the end of the +advance width. If the final glyph overflows the advance width this +value is negative. + +=back + +Obviously we can stuff all the results into an array just as well: + + @metrics = $font->bounding_box(string => "testing 123"); + +Note that extra values may be added, so $metrics[-1] isn't supported. +It's possible to translate the output by a passing coordinate to the +bounding box method: + + @metrics = $font->bounding_box(string => "testing 123", x=>45, y=>34); + +This gives the bounding box as if the string had been put down at C<(x,y)> +By giving bounding_box 'canon' as a true value it's possible to measure +the space needed for the string: + + @metrics = $font->bounding_box(string=>"testing",size=>15,canon=>1); + +This returns tha same values in $metrics[0] and $metrics[1], +but: + + $bbox[2] - horizontal space taken by glyphs + $bbox[3] - vertical space taken by glyphs + +Returns an L<Imager::Font::BBox> object in scalar context, so you can +avoid all those confusing indices. This has methods as named above, +with some extra convenience methods. + +Parameters are: + +=over + +=item * + +string - the string to calculate the bounding box for. Required. + +=item * + +size - the font size to use. Default: value set in +Imager::Font->new(), or 15. + +=item * + +sizew - the font width to use. Default to the value of the C<size> +parameter. + +=item * + +utf8 - For drivers that support it, treat the string as UTF8 encoded. +For versions of perl that support Unicode (5.6 and later), this will +be enabled automatically if the 'string' parameter is already a UTF8 +string. See L<UTF8> for more information. Default: the C<utf8> value +passed to Imager::Font->new(...) or 0. + +=item * + +x, y - offsets applied to @box[0..3] to give you a adjusted bounding +box. Ignored in scalar context. + +=item * + +canon - if non-zero and the C<x>, C<y> parameters are not supplied, +then $pos_width and $global_ascent values will returned as the width +and height of the text instead. + +=back + +=item string + +The $img->string(...) method is now documented in +L<Imager::Draw/string> + +=item align(string=>$text, size=>$size, x=>..., y=>..., valign => ..., halign=>...) + +Higher level text output - outputs the text aligned as specified +around the given point (x,y). + + # "Hello" centered at 100, 100 in the image. + my ($left, $top, $right, $bottom) = + $font->align(string=>"Hello", + x=>100, y=>100, + halign=>'center', valign=>'center', + image=>$image); + +Takes the same parameters as $font->draw(), and the following extra +parameters: + +=over + +=item valign + +Possible values are: + +=over + +=item top + +Point is at the top of the text. + +=item bottom + +Point is at the bottom of the text. + +=item baseline + +Point is on the baseline of the text (default.) + +=item center + +Point is vertically centered within the text. + +=back + +=item halign + +=over + +=item left + +The point is at the left of the text. + +=item start + +The point is at the start point of the text. + +=item center + +The point is horizontally centered within the text. + +=item right + +The point is at the right end of the text. + +=item end + +The point is at the end point of the text. + +=back + +=item image + +The image to draw to. Set to C<undef> to avoid drawing but still +calculate the bounding box. + +=back + +Returns a list specifying the bounds of the drawn text. + +=item dpi() + +=item dpi(xdpi=>$xdpi, ydpi=>$ydpi) + +=item dpi(dpi=>$dpi) + +Set or retrieve the spatial resolution of the image in dots per inch. +The default is 72 dpi. + +This isn't implemented for all font types yet. + +Possible parameters are: + +=over + +=item * + +xdpi, ydpi - set the horizontal and vertical resolution in dots per +inch. + +=item * + +dpi - set both horizontal and vertical resolution to this value. + +=back + +Returns a list containing the previous xdpi, ydpi values. + +=item transform(matrix=>$matrix) + +Applies a transformation to the font, where matrix is an array ref of +numbers representing a 2 x 3 matrix: + + [ $matrix->[0], $matrix->[1], $matrix->[2], + $matrix->[3], $matrix->[4], $matrix->[5] ] + +Not all font types support transformations, these will return false. + +It's possible that a driver will disable hinting if you use a +transformation, to prevent discontinuities in the transformations. +See the end of the test script t/t38ft2font.t for an example. + +Currently only the ft2 (Freetype 2.x) driver supports the transform() +method. + +See samples/slant_text.pl for a sample using this function. + +Note that the transformation is done in font co-ordinates where y +increases as you move up, not image co-ordinates where y decreases as +you move up. + +=item has_chars(string=>$text) + +Checks if the characters in $text are defined by the font. + +In a list context returns a list of true or false value corresponding +to the characters in $text, true if the character is defined, false if +not. In scalar context returns a string of NUL or non-NUL +characters. Supports UTF8 where the font driver supports UTF8. + +Not all fonts support this method (use $font->can("has_chars") to +check.) + +=over + +=item * + +string - string of characters to check for. Required. Must contain +at least one character. + +=item * + +utf8 - For drivers that support it, treat the string as UTF8 encoded. +For versions of perl that support Unicode (5.6 and later), this will +be enabled automatically if the 'string' parameter is already a UTF8 +string. See L<UTF8> for more information. Default: the C<utf8> value +passed to Imager::Font->new(...) or 0. + +=back + +=item face_name() + +Returns the internal name of the face. Not all font types support +this method yet. + +=item glyph_names(string=>$string [, utf8=>$utf8 ][, reliable_only=>0 ] ); + +Returns a list of glyph names for each of the characters in the +string. If the character has no name then C<undef> is returned for +the character. + +Some font files do not include glyph names, in this case Freetype 2 +will not return any names. Freetype 1 can return standard names even +if there are no glyph names in the font. + +Freetype 2 has an API function that returns true only if the font has +"reliable glyph names", unfortunately this always returns false for +TTF fonts. This can avoid the check of this API by supplying +C<reliable_only> as 0. The consequences of using this on an unknown +font may be unpredictable, since the Freetype documentation doesn't +say how those name tables are unreliable, or how FT2 handles them. + +Both Freetype 1.x and 2.x allow support for glyph names to not be +included. + +=item draw + +This is used by Imager's string() method to implement drawing text. +See L<Imager::Draw/string>. + +=back + +=head1 MULTIPLE MASTER FONTS + +The Freetype 2 driver supports multiple master fonts: + +=over + +=item is_mm() + +Test if the font is a multiple master font. + +=item mm_axes() + +Returns a list of the axes that can be changes in the font. Each +entry is an array reference which contains: + +=over + +=item 1. + +Name of the axis. + +=item 2. + +minimum value for this axis. + +=item 3. + +maximum value for this axis + +=back + +=item set_mm_coords(coords=>\@values) + +Blends an interpolated design from the master fonts. @values must +contain as many values as there are axes in the font. + +=back + +For example, to select the minimum value in each axis: + + my @axes = $font->mm_axes; + my @coords = map $_->[1], @axes; + $font->set_mm_coords(coords=>\@coords); + +It's possible other drivers will support multiple master fonts in the +future, check if your selected font object supports the is_mm() method +using the can() method. + +=head1 UTF8 + +There are 2 ways of rendering Unicode characters with Imager: + +=over + +=item * + +For versions of perl that support it, use perl's native UTF8 strings. +This is the simplest method. + +=item * + +Hand build your own UTF8 encoded strings. Only recommended if your +version of perl has no UTF8 support. + +=back + +Imager won't construct characters for you, so if want to output +unicode character 00C3 "LATIN CAPITAL LETTER A WITH DIAERESIS", and +your font doesn't support it, Imager will I<not> build it from 0041 +"LATIN CAPITAL LETTER A" and 0308 "COMBINING DIAERESIS". + +To check if a driver supports UTF8 call the utf8 method: + +=over + +=item utf8 + +Return true if the font supports UTF8. + +=back + +=head2 Native UTF8 Support + +If your version of perl supports UTF8 and the driver supports UTF8, +just use the $im->string() method, and it should do the right thing. + +=head2 Build your own + +In this case you need to build your own UTF8 encoded characters. + +For example: + + $x = pack("C*", 0xE2, 0x80, 0x90); # character code 0x2010 HYPHEN + +You need to be be careful with versions of perl that have UTF8 +support, since your string may end up doubly UTF8 encoded. + +For example: + + $x = "A\xE2\x80\x90\x41\x{2010}"; + substr($x, -1, 0) = ""; + # at this point $x is has the UTF8 flag set, but has 5 characters, + # none, of which is the constructed UTF8 character + +The test script t/t38ft2font.t has a small example of this after the +comment: + + # an attempt using emulation of UTF8 + +=head1 DRIVER CONTROL + +If you don't supply a 'type' parameter to Imager::Font->new(), but you +do supply a 'file' parameter, Imager will attempt to guess which font +driver to used based on the extension of the font file. + +Since some formats can be handled by more than one driver, a priority +list is used to choose which one should be used, if a given format can +be handled by more than one driver. + +=over + +=item priorities + +The current priorities can be retrieved with: + + @drivers = Imager::Font->priorities(); + +You can set new priorities and save the old priorities with: + + @old = Imager::Font->priorities(@drivers); + +=back + +If you supply driver names that are not currently supported, they will +be ignored. + +Imager supports both T1Lib and Freetype2 for working with Type 1 +fonts, but currently only T1Lib does any caching, so by default T1Lib +is given a higher priority. Since Imager's Freetype2 support can also +do font transformations, you may want to give that a higher priority: + + my @old = Imager::Font->priorities(qw(tt ft2 t1)); + +=head1 AUTHOR + +Arnar M. Hrafnkelsson, addi@umich.edu +And a great deal of help from others - see the README for a complete +list. + +=head1 BUGS + +You need to modify this class to add new font types. + +The $pos_width member returned by the bounding_box() method has +historically returned different values from different drivers. The +Freetype 1.x and 2.x, and the Win32 drivers return the max of the +advance width and the right edge of the right-most glyph. The Type 1 +driver always returns the right edge of the right-most glyph. + +The newer advance_width and right_bearing values allow access to any +of the above. + +=head1 REVISION + +$Revision: 1667 $ + +=head1 SEE ALSO + +Imager(3), Imager::Font::FreeType2(3), Imager::Font::Type1(3), +Imager::Font::Win32(3), Imager::Font::Truetype(3), Imager::Font::BBox(3) + + http://imager.perl.org/ + +=cut + + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/BBox.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/BBox.pm new file mode 100755 index 00000000000..3af88568f89 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/BBox.pm @@ -0,0 +1,282 @@ +package Imager::Font::BBox; +use strict; +use vars qw($VERSION); + +$VERSION = "1.005"; + +=head1 NAME + +Imager::Font::BBox - objects representing the bounding box of a string. + +=head1 SYNOPSIS + + use Imager::Font; + + # get the object + my $font = Imager::Font->new(...); + my $bbox = $font->bounding_box(string=>$text, size=>$size); + + # methods + my $start = $bbox->start_offset; + my $left_bearing = $bbox->left_bearing; + my $right_bearing = $bbox->right_bearing; + my $end = $bbox->end_offset; + my $gdescent = $box->global_descent; + my $gascent = $bbox->global_ascent; + my $ascent = $bbox->ascent; + my $decent = $bbox->descent; + my $total_width = $bbox->total_width; + my $fheight = $bbox->font_height; + my $theight = $bbox->text_height; + my $display_width = $bbox->display_width; + +=head1 DESCRIPTION + +Objects of this class are returned by the Imager::Font bounding_box() +method when it is called in scalar context. + +This will hopefully make the information from this method more +accessible. + +=head1 METHODS + +=over + +=item start_offset() + +=item neg_width + +=item left_bearing + +Returns the horizonatal offset from the selected drawing location to +the left edge of the first character drawn. If this is positive, the +first glyph is to the right of the drawing location. + +The alias neg_width() is present to match the bounding_box() +documentation for list context. + +The alias left_bearing() is present to match font terminology. + +=cut + +sub start_offset { + return $_[0][0]; +} + +sub neg_width { + return $_[0][0]; +} + +sub left_bearing { + return $_[0][0]; +} + +=item advance_width() + +The advance width of the string, if the driver supports that, +otherwise the same as end_offset. + +=cut + +sub advance_width { + my $self = shift; + + @$self > 6 ? $self->[6] : $self->[2]; +} + +=item right_bearing + +The distance from the right of the last glyph to the end of the advance +point. + +If the glyph overflows the right side of the advance width this value +is negative. + +=cut + +sub right_bearing { + my $self = shift; + + @$self >= 8 && return $self->[7]; # driver gives it to us + + # otherwise the closest we have is the difference between the + # end_pos and advance_width + return $self->advance_width - $self->pos_width; +} + +=item display_width + +The distance from the left-most pixel of the left-most glyph to the +right-most pixel of the right-most glyph. + +Equals advance_width - left_bearing - right_bearing (and implemented +that way.) + +=cut + +sub display_width { + my ($self) = @_; + + $self->advance_width - $self->left_bearing - $self->right_bearing; +} + +=item global_descent() + +The lowest position relative to the font baseline that any character +in the font reaches in the character cell. Normally negative. + +At least one font we've seen has reported a positive number for this. + +=cut + +sub global_descent { + return $_[0][1]; +} + +=item global_ascent() + +The highest position relative to the font baseline that any character +in the font reaches in the character cell. Normally positive. + +=cut + +sub global_ascent { + return $_[0][3]; +} + +=item descent() + +The lowest position relative to the font baseline that any character +in the supplied string reaches. Negative when any character's glyph +reaches below the baseline. + +=cut + +sub descent { + return $_[0][4]; +} + +=item ascent() + +The highest position relative to the font baseline that any character +in the supplied string reaches. Positive if any character's glyph +reaches above the baseline. + +=cut + +sub ascent { + return $_[0][5]; +} + +=item font_height() + +The maximum displayed height of any string using this font. + +=cut + +sub font_height { + my $self = shift; + $self->global_ascent - $self->global_descent; +} + +=item text_height() + +The displayed height of the supplied string. + +=cut + +sub text_height { + my $self = shift; + + $self->ascent - $self->descent; +} + +=back + +=head1 OBSOLETE METHODS + +These methods include bugs kept for backwards compatibility and +shouldn't be used in new code. + +=over + +=item total_width() + +The total displayed width of the string. + +New code should use display_width(). + +This depends on end_offset(), and is limited by it's backward +compatibility. + +=cut + +sub total_width { + my $self = shift; + + $self->end_offset - $self->start_offset; +} + +=item end_offset + +=item pos_width + +The offset from the selected drawing location to the right edge of the +last character drawn. Should always be positive. + +You can use the alias pos_width() if you are used to the +bounding_box() documentation for list context. + +For backwards compatibility this method returns the maximum of the +advance width and the offset of the right edge of the last glyph. + +=cut + +sub end_offset { + return $_[0][2]; +} + +sub pos_width { + return $_[0][2]; +} + +=back + +=head1 INTERNAL FUNCTIONS + +=over + +=item new(...) + +Called by Imager::Font->bounding_box() to create the object. + +=cut + +sub new { + my $class = shift; + return bless [ @_ ], $class; +} + +=back + +=head1 BUGS + +Doesn't reproduce the functionality that you get using the x and y +parameters to Imager::Font->bounding_box(). I considered: + + my ($left, $top, $right, $bottom) = $box->offset(x=>$x, y=>$y) + +but this is about as clumsy as the original. + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 SEE ALSO + +Imager(3), Imager::Font(3) + +=cut + +1; + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/FreeType2.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/FreeType2.pm new file mode 100755 index 00000000000..4f0ac2e4358 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/FreeType2.pm @@ -0,0 +1,233 @@ +package Imager::Font::FreeType2; +use strict; +use Imager::Color; +use vars qw(@ISA $VERSION); +@ISA = qw(Imager::Font); + +$VERSION = "1.013"; + +*_first = \&Imager::Font::_first; + +sub new { + my $class = shift; + my %hsh=(color=>Imager::Color->new(255,0,0,0), + size=>15, + @_); + + unless ($hsh{file}) { + $Imager::ERRSTR = "No font file specified"; + return; + } + unless (-e $hsh{file}) { + $Imager::ERRSTR = "Font file $hsh{file} not found"; + return; + } + unless ($Imager::formats{ft2}) { + $Imager::ERRSTR = "Freetype2 not supported in this build"; + return; + } + my $id = i_ft2_new($hsh{file}, $hsh{'index'} || 0); + unless ($id) { # the low-level code may miss some error handling + $Imager::ERRSTR = Imager::_error_as_msg(); + return; + } + return bless { + id => $id, + aa => $hsh{aa} || 0, + file => $hsh{file}, + type => 't1', + size => $hsh{size}, + color => $hsh{color}, + utf8 => $hsh{utf8}, + vlayout => $hsh{vlayout}, + }, $class; +} + +sub _draw { + my $self = shift; + my %input = @_; + if (exists $input{channel}) { + i_ft2_cp($self->{id}, $input{image}{IMG}, $input{'x'}, $input{'y'}, + $input{channel}, $input{size}, $input{sizew} || 0, + $input{string}, , $input{align}, $input{aa}, $input{vlayout}, + $input{utf8}); + } else { + i_ft2_text($self->{id}, $input{image}{IMG}, + $input{'x'}, $input{'y'}, + $input{color}, $input{size}, $input{sizew} || 0, + $input{string}, $input{align}, $input{aa}, $input{vlayout}, + $input{utf8}); + } +} + +sub _bounding_box { + my $self = shift; + my %input = @_; + + return i_ft2_bbox($self->{id}, $input{size}, $input{sizew}, $input{string}, + $input{utf8}); +} + +sub dpi { + my $self = shift; + my @old = i_ft2_getdpi($self->{id}); + if (@_) { + my %hsh = @_; + my $result; + unless ($hsh{xdpi} && $hsh{ydpi}) { + if ($hsh{dpi}) { + $hsh{xdpi} = $hsh{ydpi} = $hsh{dpi}; + } + else { + $Imager::ERRSTR = "dpi method requires xdpi and ydpi or just dpi"; + return; + } + i_ft2_setdpi($self->{id}, $hsh{xdpi}, $hsh{ydpi}) or return; + } + } + + return @old; +} + +sub hinting { + my ($self, %opts) = @_; + + i_ft2_sethinting($self->{id}, $opts{hinting} || 0); +} + +sub _transform { + my $self = shift; + + my %hsh = @_; + my $matrix = $hsh{matrix} or return undef; + + return i_ft2_settransform($self->{id}, $matrix) +} + +sub utf8 { + return 1; +} + +# check if the font has the characters in the given string +sub has_chars { + my ($self, %hsh) = @_; + + unless (defined $hsh{string} && length $hsh{string}) { + $Imager::ERRSTR = "No string supplied to \$font->has_chars()"; + return; + } + return i_ft2_has_chars($self->{id}, $hsh{string}, + _first($hsh{'utf8'}, $self->{utf8}, 0)); +} + +sub face_name { + my ($self) = @_; + + i_ft2_face_name($self->{id}); +} + +sub can_glyph_names { + i_ft2_can_do_glyph_names(); +} + +sub glyph_names { + my ($self, %input) = @_; + + my $string = $input{string}; + defined $string + or return Imager->_set_error("no string parameter passed to glyph_names"); + my $utf8 = _first($input{utf8}, 0); + my $reliable_only = _first($input{reliable_only}, 1); + + my @names = i_ft2_glyph_name($self->{id}, $string, $utf8, $reliable_only); + @names or return Imager->_set_error(Imager->_error_as_msg); + + return @names if wantarray; + return pop @names; +} + +sub is_mm { + my ($self) = @_; + + i_ft2_is_multiple_master($self->{id}); +} + +sub mm_axes { + my ($self) = @_; + + my ($num_axis, $num_design, @axes) = + i_ft2_get_multiple_masters($self->{id}) + or return Imager->_set_error(Imager->_error_as_msg); + + return @axes; +} + +sub set_mm_coords { + my ($self, %opts) = @_; + + $opts{coords} + or return Imager->_set_error("Missing coords parameter"); + ref($opts{coords}) && $opts{coords} =~ /ARRAY\(0x[\da-f]+\)$/ + or return Imager->_set_error("coords parameter must be an ARRAY ref"); + + i_ft2_set_mm_coords($self->{id}, @{$opts{coords}}) + or return Imager->_set_error(Imager->_error_as_msg); + + return 1; +} + +1; + +__END__ + +=head1 NAME + + Imager::Font::FreeType2 - low-level functions for FreeType2 text output + +=head1 DESCRIPTION + +Imager::Font creates a Imager::Font::FreeType2 object when asked to. + +See Imager::Font to see how to use this type. + +This class provides low-level functions that require the caller to +perform data validation. + +This driver supports: + +=over + +=item transform() + +=item dpi() + +=item draw() + +The following parameters: + +=over + +=item utf8 + +=item vlayour + +=item sizew + +=back + +=back + +=head2 Special behaviors + +If you call transform() to set a transformation matrix, hinting will +be switched off. This prevents sudden jumps in the size of the text +caused by the hinting when the transformation is the identity matrix. +If for some reason you want hinting enabled, use +$font->hinting(hinting=>1) to re-enable hinting. This will need to be +called after I<each> call to transform(). + +=head1 AUTHOR + +Addi, Tony + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/Image.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/Image.pm new file mode 100755 index 00000000000..19f3920ffe4 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/Image.pm @@ -0,0 +1,167 @@ +package Imager::Font::Image; +use strict; +use Imager::Color; +use File::Basename; +use File::Spec; + +use vars qw(@ISA %REQUIRED_FIELDS); +@ISA = qw(Imager::Font); + +sub NWIDTH () { 0 } +sub PWIDTH () { 2 } +sub GDESCENT () { 1 } +sub GASCENT () { 3 } +sub DESCENT () { 4 } +sub ASCENT () { 5 } + + +%REQUIRED_FIELDS = ( + Image_spec => 1, + Font_size => 1, + Global_ascent => 1, + Global_descent => 1,); + +# Required fields +# Fontmetrics: +# Font global data: +# image name +# font size +# max glyph height +# max glyph width +# +# The per character data is: +# left edge (inclusive) +# right edge (exclusive) +# top edge (inclusive) +# bottom edge (exclusive) +# left adjustment +# forward shift +# baseline adjustment (from top) +# +# The left adjustment is the starting +# offset into the glyph, the forward shift +# is the actual forward movement of the +# imaginary cursor. + +# To calculate the size of a string use: +# sum (forward_shift_i) + left_adjustment_0 + width_last - left_adjustment_last - forward_shift_last + +# example font spec file: + +# IAGRFONT +# # This is an imager font definition file. This is a comment +# Image_spec = foo.png +# Font_size = 12 +# Global_ascent = 10 +# Global_descent = -2 +# # Per character data +# FM_65 = 20 40 30 50 3 15 +# # Code for 'A' left edge = 20, right = 40, top = 30, bottom 50, leading = 3, forward = 15. +# The left adjustment is the starting +# offset into the glyph, the forward shift +# is the actual forward movement of the +# imaginary cursor. + +# To calculate the size of a string use: +# sum (forward_shift_i) + left_adjustment_0 + width_last - left_adjustment_last - forward_shift_last + + + +sub parse_fontspec_file { + my ($self, $file) = @_; + local *FH; + return unless open(FH, "<$file"); + + my %req = %REQUIRED_FIELDS; + + while(<FH>) { + next if m/^\#/; + if (m/^\s*?(\S+?)\s*=\s*(.+?)\s*$/) { + # Check for a required field: + my $char = $1; + my $metric = $2; + if ($req{$char}) { + $self->{$char} = $metric; + delete $req{$1}; + } else { + next unless $char =~ s/^FM_(\d+)$/$1/; + next unless $metric =~ m/(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)$/; + $self->{fm}->{$char} = [$1, $2, $3, $4, $5, $6]; + } + } + } + close(FH); + return $self; +} + + + +sub new { + my $self = bless {}, shift; + my %opts = (color=>Imager::Color->new(255, 0, 0, 0), @_); + + unless ($opts{file}) { + $Imager::ERRSTR = "No font file specified"; + return; + } + unless ($self->parse_fontspec_file($opts{file})) { + $Imager::ERRSTR = "Font file $opts{file} not found or bad"; + return; + } + + my $img = Imager->new(); + my $img_filename = File::Spec->catfile( dirname($opts{'file'}), + $self->{Image_spec} ); + + unless ($img->open(%opts, file=>$img_filename)) { + $Imager::ERRSTR = "Font IMAGE file $img_filename not found or bad: ". + $img->errstr(); + return; + } + + $self->{image} = $img; + $self->{size} = $self->{Font_size}; + return $self; +} + +sub get_glyph_data { + my ($self, $glyph_code) = @_; + return unless exists $self->{fm}->{$glyph_code}; + return @{$self->{fm}->{$glyph_code}}; +} + +# copy_glyph +# +# $x, $y is left, baseline for glyphs. +# + +sub copy_glyph { + my ($self, $glyph_code, $target_img, $x, $y) = @_; + + my @gdata = $self->get_glyph_data($glyph_code) or return; + + $target_img->rubthrough(src=>$self->{image}, + tx => $x + $gdata[4], + ty => $y - $self->{Global_ascent},, + src_minx => $gdata[0], + src_maxx => $gdata[1], + src_miny => $gdata[2], + src_maxy => $gdata[3]); +} + +sub _draw { + my ($self, %opts) = @_; + + my $x = $opts{'x'}; + my $y = $opts{'y'}; + + my @glyphs = unpack("C*", $opts{string}); + my $img = $opts{image}; + + my $glyph; + for $glyph (@glyphs) { + my @gmetrics = $self->get_glyph_data($glyph) or next; + $self->copy_glyph($glyph, $img, $x, $y); + $x += $gmetrics[5]; + } +} diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/Truetype.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/Truetype.pm new file mode 100755 index 00000000000..24ffd098340 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/Truetype.pm @@ -0,0 +1,127 @@ +package Imager::Font::Truetype; +use strict; +use vars qw(@ISA $VERSION); +@ISA = qw(Imager::Font); + +$VERSION = "1.010"; + +*_first = \&Imager::Font::_first; + +sub new { + my $class = shift; + my %hsh=(color=>Imager::Color->new(255,0,0,0), + size=>15, + @_); + + unless ($hsh{file}) { + $Imager::ERRSTR = "No font file specified"; + return; + } + unless (-e $hsh{file}) { + $Imager::ERRSTR = "Font file $hsh{file} not found"; + return; + } + unless ($Imager::formats{tt}) { + $Imager::ERRSTR = "Type 1 fonts not supported in this build"; + return; + } + my $id = Imager::i_tt_new($hsh{file}); + unless ($id) { # the low-level code may miss some error handling + $Imager::ERRSTR = Imager::_error_as_msg(); + return; + } + return bless { + id => $id, + aa => $hsh{aa} || 0, + file => $hsh{file}, + type => 'tt', + size => $hsh{size}, + color => $hsh{color}, + }, $class; +} + +sub _draw { + my $self = shift; + my %input = @_; + + # note that the string length parameter is ignored and calculated in + # XS with SvPV(), since we want the number of bytes rather than the + # number of characters, which is what we'd get in perl for a UTF8 + # encoded string in 5.6 and later + + if ( exists $input{channel} ) { + Imager::i_tt_cp($self->{id},$input{image}{IMG}, + $input{'x'}, $input{'y'}, $input{channel}, $input{size}, + $input{string}, length($input{string}),$input{aa}, + $input{utf8}, $input{align}); + } else { + Imager::i_tt_text($self->{id}, $input{image}{IMG}, + $input{'x'}, $input{'y'}, $input{color}, + $input{size}, $input{string}, + length($input{string}), $input{aa}, $input{utf8}, + $input{align}); + } +} + +sub _bounding_box { + my $self = shift; + my %input = @_; + return Imager::i_tt_bbox($self->{id}, $input{size}, + $input{string}, length($input{string}), + $input{utf8}); +} + +sub utf8 { 1 } + +# check if the font has the characters in the given string +sub has_chars { + my ($self, %hsh) = @_; + + unless (defined $hsh{string} && length $hsh{string}) { + $Imager::ERRSTR = "No string supplied to \$font->has_chars()"; + return; + } + return Imager::i_tt_has_chars($self->{id}, $hsh{string}, + _first($hsh{'utf8'}, $self->{utf8}, 0)); +} + +sub face_name { + my ($self) = @_; + + Imager::i_tt_face_name($self->{id}); +} + +sub glyph_names { + my ($self, %input) = @_; + + my $string = $input{string}; + defined $string + or return Imager->_set_error("no string parameter passed to glyph_names"); + my $utf8 = _first($input{utf8} || 0); + + Imager::i_tt_glyph_name($self->{id}, $string, $utf8); +} + +1; + +__END__ + +=head1 NAME + + Imager::Font::Truetype - low-level functions for Truetype fonts + +=head1 DESCRIPTION + +Imager::Font creates a Imager::Font::Truetype object when asked to create +a font object based on a .ttf file. + +See Imager::Font to see how to use this type. + +This class provides low-level functions that require the caller to +perform data validation. + +=head1 AUTHOR + +Addi, Tony + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/Type1.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/Type1.pm new file mode 100755 index 00000000000..d9e15e7daaf --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/Type1.pm @@ -0,0 +1,191 @@ +package Imager::Font::Type1; +use strict; +use Imager::Color; +use vars qw(@ISA $VERSION); +@ISA = qw(Imager::Font); + +$VERSION = "1.010"; + +*_first = \&Imager::Font::_first; + +my $t1aa; + +# $T1AA is in there because for some reason (probably cache related) antialiasing +# is a system wide setting in t1 lib. + +sub t1_set_aa_level { + if (!defined $t1aa or $_[0] != $t1aa) { + Imager::i_t1_set_aa($_[0]); + $t1aa=$_[0]; + } +} + +sub new { + my $class = shift; + my %hsh=(color=>Imager::Color->new(255,0,0,0), + size=>15, + @_); + + unless ($hsh{file}) { + $Imager::ERRSTR = "No font file specified"; + return; + } + unless (-e $hsh{file}) { + $Imager::ERRSTR = "Font file $hsh{file} not found"; + return; + } + unless ($Imager::formats{t1}) { + $Imager::ERRSTR = "Type 1 fonts not supported in this build"; + return; + } + unless ($hsh{file} =~ m!^/! || $hsh{file} =~ m!^\./!) { + $hsh{file} = './' . $hsh{file}; + } + + if($hsh{afm}) { + unless (-e $hsh{afm}) { + $Imager::ERRSTR = "Afm file $hsh{afm} not found"; + return; + } + unless ($hsh{afm} =~ m!^/! || $hsh{afm} =~ m!^\./!) { + $hsh{file} = './' . $hsh{file}; + } + } else { + $hsh{afm} = 0; + } + + my $id = Imager::i_t1_new($hsh{file},$hsh{afm}); + unless ($id >= 0) { # the low-level code may miss some error handling + $Imager::ERRSTR = "Could not load font ($id)"; + return; + } + return bless { + id => $id, + aa => $hsh{aa} || 0, + file => $hsh{file}, + type => 't1', + size => $hsh{size}, + color => $hsh{color}, + }, $class; +} + +sub _draw { + my $self = shift; + my %input = @_; + t1_set_aa_level($input{aa}); + my $flags = ''; + $flags .= 'u' if $input{underline}; + $flags .= 's' if $input{strikethrough}; + $flags .= 'o' if $input{overline}; + if (exists $input{channel}) { + Imager::i_t1_cp($input{image}{IMG}, $input{'x'}, $input{'y'}, + $input{channel}, $self->{id}, $input{size}, + $input{string}, length($input{string}), $input{align}, + $input{utf8}, $flags); + } else { + Imager::i_t1_text($input{image}{IMG}, $input{'x'}, $input{'y'}, + $input{color}, $self->{id}, $input{size}, + $input{string}, length($input{string}), + $input{align}, $input{utf8}, $flags); + } + + return $self; +} + +sub _bounding_box { + my $self = shift; + my %input = @_; + my $flags = ''; + $flags .= 'u' if $input{underline}; + $flags .= 's' if $input{strikethrough}; + $flags .= 'o' if $input{overline}; + return Imager::i_t1_bbox($self->{id}, $input{size}, $input{string}, + length($input{string}), $input{utf8}, $flags); +} + +# check if the font has the characters in the given string +sub has_chars { + my ($self, %hsh) = @_; + + unless (defined $hsh{string} && length $hsh{string}) { + $Imager::ERRSTR = "No string supplied to \$font->has_chars()"; + return; + } + return Imager::i_t1_has_chars($self->{id}, $hsh{string}, + _first($hsh{'utf8'}, $self->{utf8}, 0)); +} + +sub utf8 { + 1; +} + +sub face_name { + my ($self) = @_; + + Imager::i_t1_face_name($self->{id}); +} + +sub glyph_names { + my ($self, %input) = @_; + + my $string = $input{string}; + defined $string + or return Imager->_set_error("no string parameter passed to glyph_names"); + my $utf8 = _first($input{utf8} || 0); + + Imager::i_t1_glyph_name($self->{id}, $string, $utf8); +} + + +1; + +__END__ + +=head1 NAME + + Imager::Font::Type1 - low-level functions for Type1 fonts + +=head1 DESCRIPTION + +Imager::Font creates a Imager::Font::Type1 object when asked to create +a font object based on a .pfb file. + +See Imager::Font to see how to use this type. + +This class provides low-level functions that require the caller to +perform data validation + +By default Imager no longer creates the F<t1lib.log> log file. You +can re-enable that by calling Imager::init() with the C<t1log> option: + + Imager::init(t1log=>1); + +This must be called before creating any fonts. + +Currently specific to Imager::Font::Type1, you can use the following +flags when drawing text or calculating a bounding box: + +=over + +=item underline + +Draw the text with an underline. + +=item overline + +Draw the text with an overline. + +=item strikethrough + +Draw the text with a strikethrough. + +=back + +Obviously, if you're calculating the bounding box the size of the line +is included in the box, and the line isn't drawn :) + +=head1 AUTHOR + +Addi, Tony + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/Win32.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/Win32.pm new file mode 100755 index 00000000000..790d9ae8b09 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/Win32.pm @@ -0,0 +1,61 @@ +package Imager::Font::Win32; +use strict; +use vars qw(@ISA $VERSION); +@ISA = qw(Imager::Font); + +$VERSION = "1.005"; + +# called by Imager::Font::new() +# since Win32's HFONTs include the size information this +# is just a stub +sub new { + my ($class, %opts) = @_; + + return bless \%opts, $class; +} + +sub _bounding_box { + my ($self, %opts) = @_; + + my @bbox = Imager::i_wf_bbox($self->{face}, $opts{size}, $opts{string}, $opts{utf8}); +} + +sub _draw { + my $self = shift; + + my %input = @_; + if (exists $input{channel}) { + Imager::i_wf_cp($self->{face}, $input{image}{IMG}, $input{x}, $input{'y'}, + $input{channel}, $input{size}, + $input{string}, $input{align}, $input{aa}, $input{utf8}); + } + else { + Imager::i_wf_text($self->{face}, $input{image}{IMG}, $input{x}, + $input{'y'}, $input{color}, $input{size}, + $input{string}, $input{align}, $input{aa}, $input{utf8}); + } +} + + +sub utf8 { + return 1; +} + +1; + +__END__ + +=head1 NAME + +Imager::Font::Win32 - uses Win32 GDI services for text output + +=head1 SYNOPSIS + + my $font = Imager::Font->new(face=>"Arial"); + +=head1 DESCRIPTION + +Implements font support using Win32 GDI calls. See Imager::Font for +usage information. + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Font/Wrap.pm b/Master/tlpkg/tlperl0/lib/Imager/Font/Wrap.pm new file mode 100755 index 00000000000..5e061d76eab --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Font/Wrap.pm @@ -0,0 +1,387 @@ +package Imager::Font::Wrap; +use strict; +use Imager; +use Imager::Font; +use vars qw($VERSION); + +$VERSION = "1.002"; + +*_first = \&Imager::Font::_first; + +# we can't accept the utf8 parameter, too hard at this level + +# the %state contains: +# font - the font +# im - the image +# x - the left position +# w - the width +# justify - fill, left, right or center + +sub _format_line { + my ($state, $spaces, $text, $fill) = @_; + + $text =~ s/ +$//; + my $box = $state->{font}->bounding_box(string=>$text, + size=>$state->{size}); + + my $y = $state->{linepos} + $box->global_ascent; + + if ($state->{bottom} + && $state->{linepos} + $box->font_height > $state->{bottom}) { + $state->{full} = 1; + return 0; + } + + if ($text =~ /\S/ && $state->{im}) { + my $justify = $fill ? $state->{justify} : + $state->{justify} eq 'fill' ? 'left' : $state->{justify}; + if ($justify ne 'fill') { + my $x = $state->{x}; + if ($justify eq 'right') { + $x += $state->{w} - $box->advance_width; + } + elsif ($justify eq 'center') { + $x += ($state->{w} - $box->advance_width) / 2; + } + $state->{font}->draw(image=>$state->{im}, string=>$text, + x=>$x, 'y'=>$y, + size=>$state->{size}, %{$state->{input}}); + } + else { + (my $nospaces = $text) =~ tr/ //d; + my $nospace_bbox = $state->{font}->bounding_box(string=>$nospaces, + size=>$state->{size}); + my $gap = $state->{w} - $nospace_bbox->advance_width; + my $x = $state->{x}; + $spaces = $text =~ tr/ / /; + while (length $text) { + if ($text =~ s/^(\S+)//) { + my $word = $1; + my $bbox = $state->{font}->bounding_box(string=>$word, + size=>$state->{size}); + $state->{font}->draw(image=>$state->{im}, string=>$1, + x=>$x, 'y'=>$y, + size=>$state->{size}, %{$state->{input}}); + $x += $bbox->advance_width; + } + elsif ($text =~ s/^( +)//) { + my $sep = $1; + my $advance = int($gap * length($sep) / $spaces); + $spaces -= length $sep; + $gap -= $advance; + $x += $advance; + } + else { + die "This shouldn't happen\n"; + } + } + } + } + $state->{linepos} += $box->font_height + $state->{linegap}; + + 1; +} + +sub wrap_text { + my $class = shift; + my %input = @_; + + # try to get something useful + my $x = _first(delete $input{'x'}, 0); + my $y = _first(delete $input{'y'}, 0); + exists $input{image} + or return Imager->_set_error('No image parameter supplied'); + my $im = delete $input{image}; + my $imerr = $im || 'Imager'; + my $width = delete $input{width}; + if (!defined $width) { + defined $im && $im->getwidth > $x + or return $imerr->_set_error("No width supplied and can't guess"); + $width = $im->getwidth - $x; + } + my $font = delete $input{font} + or return $imerr->_set_error("No font parameter supplied"); + my $size = _first(delete $input{size}, $font->{size}); + defined $size + or return $imerr->_set_error("No font size supplied"); + + 2 * $size < $width + or return $imerr->_set_error("Width too small for font size"); + + my $text = delete $input{string}; + defined $text + or return $imerr->_set_error("No string parameter supplied"); + + my $justify = _first($input{justify}, "left"); + + my %state = + ( + font => $font, + im => $im, + x => $x, + w => $width, + justify => $justify, + 'y' => $y, + linepos=>$y, + size=>$size, + input => \%input, + linegap => delete $input{linegap} || 0, + ); + $state{height} = delete $input{height}; + if ($state{height}) { + $state{bottom} = $y + $state{height}; + } + my $line = ''; + my $spaces = 0; + my $charpos = 0; + my $linepos = 0; + pos($text) = 0; # avoid a warning + while (pos($text) < length($text)) { + #print pos($text), "\n"; + if ($text =~ /\G( +)/gc) { + #print "spaces\n"; + $line .= $1; + $spaces += length($1); + } + elsif ($text =~ /\G(?:\x0D\x0A?|\x0A\x0D?)/gc) { + #print "newline\n"; + _format_line(\%state, $spaces, $line, 0) + or last; + $line = ''; + $spaces = 0; + $linepos = pos($text); + } + elsif ($text =~ /\G(\S+)/gc) { + #print "word\n"; + my $word = $1; + my $bbox = $font->bounding_box(string=>$line . $word, size=>$size); + if ($bbox->advance_width > $width) { + _format_line(\%state, $spaces, $line, 1) + or last; + $line = ''; + $spaces = 0; + $linepos = pos($text) - length($word); + } + $line .= $word; + # check for long words + $bbox = $font->bounding_box(string=>$line, size=>$size); + while ($bbox->advance_width > $width) { + my $len = length($line) - 1; + $bbox = $font->bounding_box(string=>substr($line, 0, $len), + size=>$size); + while ($bbox->advance_width > $width) { + --$len; + $bbox = $font->bounding_box(string=>substr($line, 0, $len), + size=>$size); + } + _format_line(\%state, 0, substr($line, 0, $len), 0) + or last; + $line = substr($line, $len); + $bbox = $font->bounding_box(string=>$line, size=>$size); + $linepos = pos($text) - length($line); + } + } + elsif ($text =~ /\G\s/gc) { + # skip a single unrecognized whitespace char + #print "skip\n"; + $linepos = pos($text); + } + } + + if (length $line && !$state{full}) { + $linepos += length $line + if _format_line(\%state, 0, $line, 0); + } + + if ($input{savepos}) { + ${$input{savepos}} = $linepos; + } + + return ($x, $y, $x+$width, $state{linepos}); +} + +1; + +__END__ + +=head1 NAME + + Imager::Font::Wrap - simple wrapped text output + +=head1 SYNOPSIS + + use Imager::Font::Wrap; + + my $img = Imager->new(xsize=>$xsize, ysize=>$ysize); + + my $font = Imager::Font->new(file=>$fontfile); + + my $string = "..."; # text with or without newlines + + Imager::Font::Wrap->wrap_text( image => $img, + font => $font, + string => $string, + x => $left, + y => $top, + width => $width, + .... ); + +=head1 DESCRIPTION + +This is a simple text wrapper with options to control the layout of +text within the line. + +You can control the position, width and height of the text with the +C<image>, C<x>, C<y>, C<width> and C<height> options. + +You can simply calculate space usage by setting C<image> to C<undef>, +or set C<savepos> to see how much text can fit within the given +C<height>. + +=over + +=item wrap_text + +Draw word-wrapped text. + +=over + +=item x + +=item y + +The top-left corner of the rectangle the text is formatted into. +Defaults to (0, 0). + +=item width + +The width of the formatted text in pixels. Defaults to the horizontal +gap between the top-left corner and the right edge of the image. If +no image is supplied then this is required. + +=item height + +The maximum height of the formated text in pixels. Not required. + +=item savepos + +The amount of text consumed (as a count of characters) will be stored +into the scalar this refers to. + + my $pagenum = 1; + my $string = "..."; + my $font = ...; + my $savepos; + + while (length $string) { + my $img = Imager->new(xsize=>$xsize, ysize=>$ysize); + Imager::Font::Wrap->wrap_text(string=>$string, font=>$font, + image=>$img, savepos => \$savepos) + or die $img->errstr; + $savepos > 0 + or die "Could not fit any text on page\n"; + $string = substr($string, $savepos); + $img->write(file=>"page$pagenum.ppm"); + } + +=item image + +The image to render the text to. Can be supplied as C<undef> to +simply calculate the bounding box. + +=item font + +The font used to render the text. Required. + +=item size + +The size to render the font in. Defaults to the size stored in the +font object. Required if it isn't stored in the font object. + +=item string + +The text to render. This can contain non-whitespace, blanks (ASCII +0x20), and newlines. + +Newlines must match /(?:\x0A\x0D?|\x0D\x0A?)/. Whitespace other than +blanks and newlines are completely ignored. + +=item justify + +The way text is formatted within each line. Possible values include: + +=over + +=item left + +Left aligned against the left edge of the text box. + +=item right + +Right aligned against the right edge of the text box. + +=item center + +Centered horizontally in the text box. + +=item fill + +All but the final line of the paragraph has spaces expanded so that +the line fills from the left to the right edge of the text box. + +=back + +=item linegap + +Gap between lines of text in pixels. This is in addition to the size +from $font->font_height. Can be positive or negative. Default 0. + +=back + +Any other parameters are passed onto Imager::Font->draw(). + +Returns a list: + + ($left, $top, $right, $bottom) + +which are the bounds of the space used to layout the text. + +If C<height> is set then this is the space used within that height. + +You can use this to calculate the space required to format the text +before doing it: + + my ($left, $top, $right, $bottom) = + Imager::Font::Wrap->wrap_text(string => $string, + font => $font, + width => $xsize); + my $img = Imager->new(xsize=>$xsize, ysize=>$bottom); + Imager::Font::Wrap->wrap_text(string => $string, + font => $font, + width => $xsize, + image => $image); + +=back + +=head1 BUGS + +Imager::Font can handle UTF8 encoded text itself, but this module +doesn't support that (and probably won't). This could probably be +done with regex magic. + +Currently ignores the C<sizew> parameter, if you supply one it will be +supplied to the draw() function and the text will be too short or too +long for the C<width>. + +Uses a simplistic text model, which is why there's no hyphenation, and +no tabs. + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 SEE ALSO + +Imager(3), Imager::Font(3) + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Fountain.pm b/Master/tlpkg/tlperl0/lib/Imager/Fountain.pm new file mode 100755 index 00000000000..72d0b8a2042 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Fountain.pm @@ -0,0 +1,429 @@ +package Imager::Fountain; +use strict; +use Imager::Color::Float; +use vars qw($VERSION); + +$VERSION = "1.006"; + +=head1 NAME + + Imager::Fountain - a class for building fountain fills suitable for use by + the fountain filter. + +=head1 SYNOPSIS + + use Imager::Fountain; + my $f1 = Imager::Fountain->read(gimp=>$filename); + $f->write(gimp=>$filename); + my $f1 = Imager::Fountain->new; + $f1->add(start=>0, middle=>0.5, end=>1.0, + c0=>Imager::Color->new(...), + c1=>Imager::Color->new(...), + type=>$trans_type, color=>$color_trans_type); + +=head1 DESCRIPTION + +Provide an interface to build arrays suitable for use by the Imager +fountain filter. These can be loaded from or saved to a GIMP gradient +file or you can build them from scratch. + +=over + +=item read(gimp=>$filename) + +=item read(gimp=>$filename, name=>\$name) + +Loads a gradient from the given GIMP gradient file, and returns a +new Imager::Fountain object. + +If the name parameter is supplied as a scalar reference then any name +field from newer GIMP gradient files will be returned in it. + + my $gradient = Imager::Fountain->read(gimp=>'foo.ggr'); + my $name; + my $gradient2 = Imager::Fountain->read(gimp=>'bar.ggr', name=>\$name); + +=cut + +sub read { + my ($class, %opts) = @_; + + if ($opts{gimp}) { + my $fh; + $fh = ref($opts{gimp}) ? $opts{gimp} : IO::File->new($opts{gimp}); + unless ($fh) { + $Imager::ERRSTR = "Cannot open $opts{gimp}: $!"; + return; + } + + my $trash_name; + my $name_ref = $opts{name} && ref $opts{name} ? $opts{name} : \$trash_name; + + return $class->_load_gimp_gradient($fh, $opts{gimp}, $name_ref); + } + else { + warn "$class::read: Nothing to do!"; + return; + } +} + +=item write(gimp=>$filename) + +=item write(gimp=>$filename, name=>$name) + +Save the gradient to a GIMP gradient file. + +The second variant allows the gradient name to be set (for newer +versions of the GIMP). + + $gradient->write(gimp=>'foo.ggr') + or die Imager->errstr; + $gradient->write(gimp=>'bar.ggr', name=>'the bar gradient') + or die Imager->errstr; + +=cut + +sub write { + my ($self, %opts) = @_; + + if ($opts{gimp}) { + my $fh; + $fh = ref($opts{gimp}) ? $opts{gimp} : IO::File->new("> ".$opts{gimp}); + unless ($fh) { + $Imager::ERRSTR = "Cannot open $opts{gimp}: $!"; + return; + } + + return $self->_save_gimp_gradient($fh, $opts{gimp}, $opts{name}); + } + else { + warn "Nothing to do\n"; + return; + } +} + +=item new + +Create an empty fountain fill description. + +=cut + +sub new { + my ($class) = @_; + + return bless [], $class; +} + +sub _first { + for (@_) { + return $_ if defined; + } + return undef; +} + +=item add(start=>$start, middle=>$middle, end=>1.0, c0=>$start_color, c1=>$end_color, type=>$trans_type, color=>$color_trans_type) + +Adds a new segment to the fountain fill, the possible options are: + +=over + +=item start + +The start position in the gradient where this segment +takes effect between 0 and 1. Default: 0. + +=item middle + +The mid-point of the transition between the 2 +colors, between 0 and 1. Default: average of I<start> and I<end>. + +=item end + +The end of the gradient, from 0 to 1. Default: 1. + +=item c0 + +The color of the fountain fill where the fill parameter is equal +to I<start>. Default: opaque black. + +=item c1 + +The color of the fountain fill where the fill parameter is equal to +I<end>. Default: opaque black. + +=item type + +The type of segment, controls the way in which the fill parameter +moves from 0 to 1. Default: linear. + +This can take any of the following values: + +=over + +=item linear + +=item curved + +Unimplemented so far. + +=item sine + +=item sphereup + +=item spheredown + +=back + +=item color + +The way in which the color transitions between I<c0> and I<c1>. +Default: direct. + +This can take any of the following values: + +=over + +=item direct + +Each channel is simple scaled between c0 and c1. + +=item hueup + +The color is converted to a HSV value and the scaling is done such +that the hue increases as the fill parameter increases. + +=item huedown + +The color is converted to a HSV value and the scaling is done such +that the hue decreases as the fill parameter increases. + +=back + +=back + +In most cases you can ignore some of the arguments, eg. + + # assuming $f is a new Imager::Fountain in each case here + use Imager ':handy'; + # simple transition from red to blue + $f->add(c0=>NC('#FF0000'), c1=>NC('#0000FF')); + # simple 2 stages from red to green to blue + $f->add(end=>0.5, c0=>NC('#FF0000'), c1=>NC('#00FF00')) + $f->add(start=>0.5, c0=>NC('#00FF00'), c1=>NC('#0000FF')); + +=cut + +# used to translate segment types and color transition types to numbers +my %type_names = + ( + linear => 0, + curved => 1, + sine => 2, + sphereup=> 3, + spheredown => 4, + ); + +my %color_names = + ( + direct => 0, + hueup => 1, + huedown => 2 + ); + +sub add { + my ($self, %opts) = @_; + + my $start = _first($opts{start}, 0); + my $end = _first($opts{end}, 1); + my $middle = _first($opts{middle}, ($start+$end)/2); + my @row = + ( + $start, $middle, $end, + _first($opts{c0}, Imager::Color::Float->new(0,0,0,1)), + _first($opts{c1}, Imager::Color::Float->new(1,1,1,0)), + _first($opts{type} && $type_names{$opts{type}}, $opts{type}, 0), + _first($opts{color} && $color_names{$opts{color}}, $opts{color}, 0) + ); + push(@$self, \@row); + + $self; +} + +=item simple(positions=>[ ... ], colors=>[...]) + +Creates a simple fountain fill object consisting of linear segments. + +The arrayrefs passed as positions and colors must have the same number +of elements. They must have at least 2 elements each. + +colors must contain Imager::Color or Imager::Color::Float objects. + +eg. + + my $f = Imager::Fountain->simple(positions=>[0, 0.2, 1.0], + colors=>[ NC(255,0,0), NC(0,255,0), + NC(0,0,255) ]); + +=cut + +sub simple { + my ($class, %opts) = @_; + + if ($opts{positions} && $opts{colors}) { + my $positions = $opts{positions}; + my $colors = $opts{colors}; + unless (@$positions == @$colors) { + $Imager::ERRSTR = "positions and colors must be the same size"; + return; + } + unless (@$positions >= 2) { + $Imager::ERRSTR = "not enough segments"; + return; + } + my $f = $class->new; + for my $i (0.. $#$colors-1) { + $f->add(start=>$positions->[$i], end=>$positions->[$i+1], + c0 => $colors->[$i], c1=>$colors->[$i+1]); + } + return $f; + } + else { + warn "Nothing to do"; + return; + } +} + +=back + +=head2 Implementation Functions + +Documented for internal use. + +=over + +=item _load_gimp_gradient($class, $fh, $name) + +Does the work of loading a GIMP gradient file. + +=cut + +sub _load_gimp_gradient { + my ($class, $fh, $filename, $name) = @_; + + my $head = <$fh>; + chomp $head; + unless ($head eq 'GIMP Gradient') { + $Imager::ERRSTR = "$filename is not a GIMP gradient file"; + return; + } + my $count = <$fh>; + chomp $count; + if ($count =~ /^name:\s?(.*)/i) { + ref $name and $$name = $1; + $count = <$fh>; # try again + chomp $count; + } + unless ($count =~ /^\d+$/) { + $Imager::ERRSTR = "$filename is missing the segment count"; + return; + } + my @result; + for my $i (1..$count) { + my $row = <$fh>; + chomp $row; + my @row = split ' ', $row; + unless (@row == 13) { + $Imager::ERRSTR = "Bad segment definition"; + return; + } + my ($start, $middle, $end) = splice(@row, 0, 3); + my $c0 = Imager::Color::Float->new(splice(@row, 0, 4)); + my $c1 = Imager::Color::Float->new(splice(@row, 0, 4)); + my ($type, $color) = @row; + push(@result, [ $start, $middle, $end, $c0, $c1, $type, $color ]); + } + return bless \@result, +} + +=item _save_gimp_gradient($self, $fh, $name) + +Does the work of saving to a GIMP gradient file. + +=cut + +sub _save_gimp_gradient { + my ($self, $fh, $filename, $name) = @_; + + print $fh "GIMP Gradient\n"; + defined $name or $name = ''; + $name =~ tr/ -~/ /cds; + if ($name) { + print $fh "Name: $name\n"; + } + print $fh scalar(@$self),"\n"; + for my $row (@$self) { + printf $fh "%.6f %.6f %.6f ",@{$row}[0..2]; + for my $i (0, 1) { + for ($row->[3+$i]->rgba) { + printf $fh "%.6f ", $_/255.0; + } + } + print $fh "@{$row}[5,6]"; + unless (print $fh "\n") { + $Imager::ERRSTR = "write error: $!"; + return; + } + } + + return 1; +} + +=back + +=head1 FILL PARAMETER + +The add() documentation mentions a fill parameter in a few places, +this is as good a place as any to discuss it. + +The process of deciding the color produced by the gradient works +through the following steps: + +=over + +=item 1. + +calculate the base value, which is typically a distance or an angle of +some sort. This can be positive or occasinally negative, depending on +the type of fill being performed (linear, radial, etc). + +=item 2. + +clamp or convert the base value to the range 0 through 1, how this is +done depends on the repeat parameter. I'm calling this result the +fill parameter. + +=item 3. + +the appropriate segment is found. This is currently done with a +linear search, and the first matching segment is used. If there is no +matching segment the pixel is not touched. + +=item 4. + +the fill parameter is scaled from 0 to 1 depending on the segment type. + +=item 5. + +the color produced, depending on the segment color type. + +=back + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 SEE ALSO + +Imager(3) + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Handy.pod b/Master/tlpkg/tlperl0/lib/Imager/Handy.pod new file mode 100755 index 00000000000..7bb2c7c6c41 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Handy.pod @@ -0,0 +1,57 @@ +=head1 NAME + +Imager::Handy - simple access to common functions + +=head1 SYNOPSIS + + use Imager ':handy'; + my $color = NC(255, 0, 0); + my $font = NF(1.0, 0, 0); + +=head1 DESCRIPTION + +If you use Imager with the C<:handy> import tag, it will export a +number of functions that can shorter your code. + +=over + +=item NC + +=item newcolor + +=item newcolour + +Create a new Imager::Color object, supplying any parameters to the +new() method. + + my $color = NC('red'); + +=item NF + +=item newfont + +Create a new Imager::Font object, supplying any parameters to the +new() method. + + my $font = NF(file => 'foo.ttf'); + +=item NCF + +Create a new L<Imager::Color::Font> object, supplying any parameter to +the new() method. + + my $colorf = NCF(1.0, 0, 0); + +=back + +=head1 BUGS + +NC() can be mostly replaced by supplying the color name or other +description directly to the drawing method. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/ImageTypes.pod b/Master/tlpkg/tlperl0/lib/Imager/ImageTypes.pod new file mode 100755 index 00000000000..b45de4664e2 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/ImageTypes.pod @@ -0,0 +1,1164 @@ +=head1 NAME + +Imager::ImageTypes - image models for Imager + +=head1 SYNOPSIS + + use Imager; + + $img = Imager->new(); # Empty image (size is 0 by 0) + $img->open(file=>'lena.png',type=>'png'); # Read image from file + + $img = Imager->new(xsize=>400, ysize=>300); # RGB data + + $img = Imager->new(xsize=>400, ysize=>300, # Grayscale + channels=>1); # + + $img = Imager->new(xsize=>400, ysize=>300, # RGB with alpha + channels=>4); # + + $img = Imager->new(xsize=>200, ysize=>200, + type=>'paletted'); # paletted image + + $img = Imager->new(xsize=>200, ysize=>200, + bits=>16); # 16 bits/channel rgb + + $img = Imager->new(xsize=>200, ysize=>200, + bits=>'double'); # 'double' floating point + # per channel + + $img->img_set(xsize=>500, ysize=>500, # reset the image object + channels=>4); + + + # Example getting information about an Imager object + + print "Image information:\n"; + print "Width: ", $img->getwidth(), "\n"; + print "Height: ", $img->getheight(), "\n"; + print "Channels: ", $img->getchannels(), "\n"; + print "Bits/Channel: ", $img->bits(), "\n"; + print "Virtual: ", $img->virtual() ? "Yes" : "No", "\n"; + my $colorcount = $img->getcolorcount(maxcolors=>512); + print "Actual number of colors in image: "; + print defined($colorcount) ? $colorcount : ">512", "\n"; + print "Type: ", $img->type(), "\n"; + + if ($img->type() eq 'direct') { + print "Modifiable Channels: "; + print join " ", map { + ($img->getmask() & 1<<$_) ? $_ : () + } 0..$img->getchannels(); + print "\n"; + + } else { + # palette info + my $count = $img->colorcount; + @colors = $img->getcolors(); + print "Palette size: $count\n"; + my $mx = @colors > 4 ? 4 : 0+@colors; + print "First $mx entries:\n"; + for (@colors[0..$mx-1]) { + my @res = $_->rgba(); + print "(", join(", ", @res[0..$img->getchannels()-1]), ")\n"; + } + } + + my @tags = $img->tags(); + if (@tags) { + print "Tags:\n"; + for(@tags) { + print shift @$_, ": ", join " ", @$_, "\n"; + } + } else { + print "No tags in image\n"; + } + +=head1 DESCRIPTION + +Imager supports two basic models of image: + +=over + +=item * + +direct color - all samples are stored for every pixel. eg. for an +8-bit/sample RGB image, 24 bits are stored for each pixel. + +=item * + +paletted - an index into a table of colors is stored for each pixel. + +=back + +Direct color or paletted images can have 1 to 4 samples per color +stored. Imager treats these as follows: + +=over + +=item * + +1 sample per color - grayscale image. + +=item * + +2 samples per color - grayscale image with alpha channel. + +=item * + +3 samples per color - RGB image. + +=item * + +4 samples per color - RGB image with alpha channel. + +=back + +Direct color images can have sample sizes of 8-bits per sample, +16-bits per sample or a double precision floating point number per +sample (64-bits on many systems). + +Paletted images are always 8-bits/sample. + +To query an existing image about it's parameters see the C<bits()>, +C<type()>, C<getwidth()>, C<getheight()>, C<getchannels()> and +C<virtual()> methods. + +The coordinate system in Imager has the origin in the upper left +corner, see L<Imager::Draw> for details. + +The alpha channel when one is present is considered unassociated - +ie. the color data has not been scaled by the alpha channel. Note +that not all code follows this (recent) rule, but will over time. + +=head2 Creating Imager Objects + +=over + +=item new + + $img = Imager->new(); + $img->read(file=>"alligator.ppm") or die $img->errstr; + +Here C<new()> creates an empty image with width and height of zero. +It's only useful for creating an Imager object to call the read() +method on later. + + %opts = (xsize=>300, ysize=>200); + $img = Imager->new(%opts); # create direct mode RGBA image + $img = Imager->new(%opts, channels=>4); # create direct mode RGBA image + +You can also read a file from new(): + + $img = Imager->new(file => "someimage.png"); + +The parameters for new are: + +=over + +=item * + +C<xsize>, C<ysize> - Defines the width and height in pixels of the +image. These must be positive. + +If not supplied then only placeholder object is created, which can be +supplied to the C<read()> or C<img_set()> methods. + +=item * + +C<channels> - The number of channels for the image. Default 3. Valid +values are from 1 to 4. + +=item * + +C<bits> - The storage type for samples in the image. Default: 8. +Valid values are: + +=over + +=item * + +C<8> - One byte per sample. 256 discrete values. + +=item * + +C<16> - 16-bits per sample, 65536 discrete values. + +=item * + +C<double> - one C double per sample. + +=back + +Note: you can use any Imager function on any sample size image. + +Paletted images always use 8 bits/sample. + +=item * + +C<type> - either C<'direct'> or C<'paletted'>. Default: C<'direct'>. + +Direct images store color values for each pixel. + +Paletted images keep a table of up to 256 colors called the palette, +each pixel is represented as an index into that table. + +In most cases when working with Imager you will want to use the +C<direct> image type. + +If you draw on a C<paletted> image with a color not in the image's +palette then Imager will transparently convert it to a C<direct> +image. + +=item * + +C<maxcolors> - the maximum number of colors in a paletted image. +Default: 256. This must be in the range 1 through 256. + +=item * + +C<file>, C<fh>, C<fd>, C<callback>, C<readcb> - specify a filename, +filehandle, file descriptor or callback to read image data from. See +L<Imager::Files> for details. The typical use is: + + my $im = Imager->new(file => $filename); + +=item * + +C<filetype> - treated as the file format parameter, as for C<type> +with the read() method, eg: + + my $im = Imager->new(file => $filename, filetype => "gif"); + +In most cases Imager will detect the file's format itself. + +=back + +In the simplest case just supply the width and height of the image: + + # 8 bit/sample, RGB image + my $img = Imager->new(xsize => $width, ysize => $height); + +or if you want an alpha channel: + + # 8 bits/sample, RGBA image + my $img = Imager->new(xsize => $width, ysize => $height, channels=>4); + +Note that it I<is> possible for image creation to fail, for example if +channels is out of range, or if the image would take too much memory. + +To create paletted images, set the 'type' parameter to 'paletted': + + $img = Imager->new(xsize=>200, ysize=>200, type=>'paletted'); + +which creates an image with a maxiumum of 256 colors, which you can +change by supplying the C<maxcolors> parameter. + +For improved color precision you can use the bits parameter to specify +16 bit per channel: + + $img = Imager->new(xsize=>200, ysize=>200, + channels=>3, bits=>16); + +or for even more precision: + + $img = Imager->new(xsize=>200, ysize=>200, + channels=>3, bits=>'double'); + +to get an image that uses a double for each channel. + +Note that as of this writing all functions should work on images with +more than 8-bits/channel, but many will only work at only +8-bit/channel precision. + +If you want an empty Imager object to call the read() method on, just +call new() with no parameters: + + my $img = Imager->new; + $img->read(file=>$filename) + or die $img->errstr; + +Though it's much easier now to just call new() with a C<file> +parameter: + + my $img = Imager->new(file => $filename) + or die Imager->errstr; + +=item img_set + +img_set destroys the image data in the object and creates a new one +with the given dimensions and channels. For a way to convert image +data between formats see the C<convert()> method. + + $img->img_set(xsize=>500, ysize=>500, channels=>4); + +This takes exactly the same parameters as the new() method. + +=back + +=head2 Image Attribute functions + +These return basic attributes of an image object. + +=over + +=item getwidth + + print "Image width: ", $img->getwidth(), "\n"; + +The C<getwidth()> method returns the width of the image. This value +comes either from C<new()> with xsize,ysize parameters or from reading +data from a file with C<read()>. If called on an image that has no +valid data in it like C<Imager-E<gt>new()> returns, the return value +of C<getwidth()> is undef. + +=item getheight + + print "Image height: ", $img->getheight(), "\n"; + +Same details apply as for L<getwidth>. + +=item getchannels + + print "Image has ",$img->getchannels(), " channels\n"; + +To get the number of channels in an image C<getchannels()> is used. + + +=item bits + +The bits() method retrieves the number of bits used to represent each +channel in a pixel, 8 for a normal image, 16 for 16-bit image and +'double' for a double/channel image. + + if ($img->bits eq 8) { + # fast but limited to 8-bits/sample + } + else { + # slower but more precise + } + +=item type + +The type() method returns either 'direct' for truecolor images or +'paletted' for paletted images. + + if ($img->type eq 'paletted') { + # print the palette + for my $color ($img->getcolors) { + print join(",", $color->rgba), "\n"; + } + } + +=item virtual + +The virtual() method returns non-zero if the image contains no actual +pixels, for example masked images. + +This may also be used for non-native Imager images in the future, for +example, for an Imager object that draws on an SDL surface. + +=item is_bilevel + +Tests if the image will be written as a monochrome or bi-level image +for formats that support that image organization. + +In scalar context, returns true if the image is bi-level. + +In list context returns a list: + + ($is_bilevel, $zero_is_white) = $img->is_bilevel; + +An image is considered bi-level, if all of the following are true: + +=over + +=item * + +the image is a paletted image + +=item * + +the image has 1 or 3 channels + +=item * + +the image has only 2 colors in the palette + +=item * + +those 2 colors are black and white, in either order. + +=back + +If a real bi-level organization image is ever added to Imager, this +function will return true for that too. + +=back + +=head2 Direct Type Images + +Direct images store the color value directly for each pixel in the +image. + +=over + +=item getmask + + @rgbanames = qw( red green blue alpha ); + my $mask = $img->getmask(); + print "Modifiable channels:\n"; + for (0..$img->getchannels()-1) { + print $rgbanames[$_],"\n" if $mask & 1<<$_; + } + +C<getmask()> is used to fetch the current channel mask. The mask +determines what channels are currently modifiable in the image. The +channel mask is an integer value, if the i-th lsb is set the i-th +channel is modifiable. eg. a channel mask of 0x5 means only channels +0 and 2 are writable. + +=item setmask + + $mask = $img->getmask(); + $img->setmask(mask=>8); # modify alpha only + + ... + + $img->setmask(mask=>$mask); # restore previous mask + +C<setmask()> is used to set the channel mask of the image. See +L<getmask> for details. + +=back + +=head2 Palette Type Images + +Paletted images keep an array of up to 256 colors, and each pixel is +stored as an index into that array. + +In general you can work with paletted images in the same way as RGB +images, except that if you attempt to draw to a paletted image with a +color that is not in the image's palette, the image will be converted +to an RGB image. This means that drawing on a paletted image with +anti-aliasing enabled will almost certainly convert the image to RGB. + +Palette management takes place through C<addcolors()>, C<setcolors()>, +C<getcolors()> and C<findcolor()>: + +=over + +=item addcolors + +You can add colors to a paletted image with the addcolors() method: + + my @colors = ( Imager::Color->new(255, 0, 0), + Imager::Color->new(0, 255, 0) ); + my $index = $img->addcolors(colors=>\@colors); + +The return value is the index of the first color added, or undef if +adding the colors would overflow the palette. + +The only parameter is C<colors> which must be a reference to an array +of Imager::Color objects. + +=item setcolors + + $img->setcolors(start=>$start, colors=>\@colors); + +Once you have colors in the palette you can overwrite them with the +C<setcolors()> method: C<setcolors()> returns true on success. + +Parameters: + +=over + +=item * + +start - the first index to be set. Default: 0 + +=item * + +colors - reference to an array of Imager::Color objects. + +=back + +=item getcolors + +To retrieve existing colors from the palette use the getcolors() method: + + # get the whole palette + my @colors = $img->getcolors(); + # get a single color + my $color = $img->getcolors(start=>$index); + # get a range of colors + my @colors = $img->getcolors(start=>$index, count=>$count); + +=item findcolor + +To quickly find a color in the palette use findcolor(): + + my $index = $img->findcolor(color=>$color); + +which returns undef on failure, or the index of the color. + +Parameter: + +=over + +=item * + +color - an Imager::Color object. + +=back + +=item colorcount + +Returns the number of colors in the image's palette: + + my $count = $img->colorcount; + +=item maxcolors + +Returns the maximum size of the image's palette. + + my $maxcount = $img->maxcolors; + +=back + +=head2 Color Distribution + +=over + +=item getcolorcount + +Calculates the number of colors in an image. + +The amount of memory used by this is proportional to the number of +colors present in the image, so to avoid using too much memory you can +supply a maxcolors parameter to limit the memory used. + +Note: getcolorcount() treats the image as an 8-bit per sample image. + +=over + +=item * + +X<maxcolors!getcolorcount>maxcolors - the maximum number of colors to +return. Default: unlimited. + +=back + + if (defined($img->getcolorcount(maxcolors=>512)) { + print "Less than 512 colors in image\n"; + } + +=item getcolorusagehash + +Calculates a histogram of colors used by the image. + +=over + +=item * + +X<maxcolors!getcolorusagehash>maxcolors - the maximum number of colors +to return. Default: unlimited. + +=back + +Returns a reference to a hash where the keys are the raw color as +bytes, and the values are the counts for that color. + +The alpha channel of the image is ignored. If the image is grayscale +then the hash keys will each be a single character. + + my $colors = $img->getcolorusagehash; + my $blue_count = $colors->{pack("CCC", 0, 0, 255)} || 0; + print "#0000FF used $blue_count times\n"; + +=item getcolorusage + +Calculates color usage counts and returns just the counts. + +=over + +=item * + +X<maxcolors!getcolorusage>maxcolors - the maximum number of colors to +return. Default: unlimited. + +=back + +Returns a list of the color frequencies in ascending order. + + my @counts = $img->getcolorusage; + print "The most common color is used $counts[0] times\n"; + +=back + +=head2 Conversion Between Image Types + +Warning: if you draw on a paletted image with colors that aren't in +the palette, the image will be internally converted to a normal image. + +=over + +=item to_paletted + +You can create a new paletted image from an existing image using the +to_paletted() method: + + $palimg = $img->to_paletted(\%opts) + +where %opts contains the options specified under L<Quantization options>. + + # convert to a paletted image using the web palette + # use the closest color to each pixel + my $webimg = $img->to_paletted({ make_colors => 'webmap' }); + + # convert to a paletted image using a fairly optimal palette + # use an error diffusion dither to try to reduce the average error + my $optimag = $img->to_paletted({ make_colors => 'mediancut', + translate => 'errdiff' }); + +=item to_rgb8 + +You can convert a paletted image (or any image) to an 8-bit/channel +RGB image with: + + $rgbimg = $img->to_rgb8; + +No parameters. + +=item to_rgb16 + +You can convert a paletted image (or any image) to an 16-bit/channel +RGB image with: + + $rgbimg = $img->to_rgb16; + +No parameters. + +=item masked + +Creates a masked image. A masked image lets you create an image proxy +object that protects parts of the underlying target image. + +In the discussion below there are 3 image objects involved: + +=over + +=item * + +the masked image - the return value of the masked() method. Any +writes to this image are written to the target image, assuming the +mask image allows it. + +=item * + +the mask image - the image that protects writes to the target image. +Supplied as the C<mask> parameter to the masked() method. + +=item * + +the target image - the image you called the masked() method on. Any +writes to the masked image end up on this image. + +=back + +Parameters: + +=over + +=item * + +mask - the mask image. If not supplied then all pixels in the target +image are writable. On each write to the masked image, only pixels +that have non-zero in chennel 0 of the mask image will be written to +the original image. Default: none, if not supplied then no masking is +done, but the other parameters are still honored. + +=item * + +left, top - the offset of writes to the target image. eg. if you +attempt to set pixel (x,y) in the masked image, then pixel (x+left, +y+top) will be written to in the original image. + +=item * + +bottom, right - the bottom right of the area in the target available +from the masked image. + +=back + +Masked images let you control which pixels are modified in an +underlying image. Where the first channel is completely black in the +mask image, writes to the underlying image are ignored. + +For example, given a base image called $img: + + my $mask = Imager->new(xsize=>$img->getwidth, ysize=>$img->getheight, + channels=>1); + # ... draw something on the mask + my $maskedimg = $img->masked(mask=>$mask); + + # now draw on $maskedimg and it will only draw on areas of $img + # where $mask is non-zero in channel 0. + +You can specifiy the region of the underlying image that is masked +using the left, top, right and bottom options. + +If you just want a subset of the image, without masking, just specify +the region without specifying a mask. For example: + + # just work with a 100x100 region of $img + my $maskedimg = $img->masked(left => 100, top=>100, + right=>200, bottom=>200); + +=back + +=head2 Tags + +Image tags contain meta-data about the image, ie. information not +stored as pixels of the image. + +At the perl level each tag has a name or code and a value, which is an +integer or an arbitrary string. An image can contain more than one +tag with the same name or code, but having more than one tag with the +same name is discouraged. + +You can retrieve tags from an image using the tags() method, you can +get all of the tags in an image, as a list of array references, with +the code or name of the tag followed by the value of the tag. + +=over + +=item tags + +Retrieve tags from the image. + +With no parameters, retrieves a list array references, each containing +a name and value: all tags in the image: + + # get a list of ( [ name1 => value1 ], [ name2 => value2 ] ... ) + my @alltags = $img->tags; + print $_->[0], ":", $_->[1], "\n" for @all_tags; + + # or put it in a hash, but this will lose duplicates + my %alltags = map @$_, $img->tags; + +in scalar context this returns the number of tags: + + my $num_tags = $img->tags; + +or you can get all tags values for the given name: + + my @namedtags = $img->tags(name => $name); + +in scalar context this returns the first tag of that name: + + my $firstnamed = $img->tags(name => $name); + +or a given code: + + my @tags = $img->tags(code=>$code); + +=item addtag + +You can add tags using the addtag() method, either by name: + + my $index = $img->addtag(name=>$name, value=>$value); + +or by code: + + my $index = $img->addtag(code=>$code, value=>$value); + +=item deltag + +You can remove tags with the deltag() method, either by index: + + $img->deltag(index=>$index); + +or by name: + + $img->deltag(name=>$name); + +or by code: + + $img->deltag(code=>$code); + +In each case deltag() returns the number of tags deleted. + +=item settag + +settag() replaces any existing tags with a new tag. This is +equivalent to calling deltag() then addtag(). + +=back + +=head2 Common Tags + +Many tags are only meaningful for one format. GIF looping information +is pretty useless for JPEG for example. Thus, many tags are set by +only a single reader or used by a single writer. For a complete list +of format specific tags see L<Imager::Files>. + +Since tags are a relatively new addition their use is not wide spread +but eventually we hope to have all the readers for various formats set +some standard information. + +=over + +=item * + +X<i_xres tag>X<i_yres tag>X<tags, i_xres>X<tags, i_yres>i_xres, i_yres +- The spatial resolution of the image in pixels per inch. If the +image format uses a different scale, eg. pixels per meter, then this +value is converted. A floating point number stored as a string. + + # our image was generated as a 300 dpi image + $img->settag(name => 'i_xres', value => 300); + $img->settag(name => 'i_yres', value => 300); + + # 100 pixel/cm for a TIFF image + $img->settag(name => 'tiff_resolutionunit', value => 3); # RESUNIT_CENTIMETER + # convert to pixels per inch, Imager will convert it back + $img->settag(name => 'i_xres', value => 100 * 2.54); + $img->settag(name => 'i_yres', value => 100 * 2.54); + +=item * + +X<i_aspect_only tag>X<tags, i_aspect_only>i_aspect_only - If this is +non-zero then the values in i_xres and i_yres are treated as a ratio +only. If the image format does not support aspect ratios then this is +scaled so the smaller value is 72dpi. + +=item * + +X<i_incomplete tag>X<tags, i_incomplete>i_incomplete - If this tag is +present then the whole image could not be read. This isn't +implemented for all images yet, and may not be. + +=item * + +X<i_lines_read tag>X<tags, i_lines_read>i_lines_read - If +C<i_incomplete> is set then this tag may be set to the number of +scanlines successfully read from the file. This can be used to decide +whether an image is worth processing. + +=item * + +X<i_format tag>X<tags, i_format>i_format - The file format this file +was read from. + +=item * + +X<i_background>X<tags, i_background>i_background - used when writing +an image with an alpha channel to a file format that doesn't support +alpha channels. The C<write> method will convert a normal color +specification like "#FF0000" into a color object for you, but if you +set this as a tag you will need to format it like +C<color(>I<red>C<,>I<green>C<,>I<blue>C<)>, eg color(255,0,0). + +=back + +=head2 Quantization options + +These options can be specified when calling +L<Imager::ImageTypes/to_paletted>, write_multi() for gif files, when +writing a single image with the gifquant option set to 'gen', or for +direct calls to i_writegif_gen and i_writegif_callback. + +=over + +=item colors + +A arrayref of colors that are fixed. Note that some color generators +will ignore this. If this is supplied it will be filled with the +color table generated for the image. + +=item transp + +The type of transparency processing to perform for images with an +alpha channel where the output format does not have a proper alpha +channel (eg. gif). This can be any of: + +=over + +=item none + +No transparency processing is done. (default) + +=item threshold + +Pixels more transparent that tr_threshold are rendered as transparent. + +=item errdiff + +An error diffusion dither is done on the alpha channel. Note that +this is independent of the translation performed on the colour +channels, so some combinations may cause undesired artifacts. + +=item ordered + +The ordered dither specified by tr_orddith is performed on the alpha +channel. + +=back + +This will only be used if the image has an alpha channel, and if there +is space in the palette for a transparency colour. + +=item tr_threshold + +The highest alpha value at which a pixel will be made transparent when +transp is 'threshold'. (0-255, default 127) + +=item tr_errdiff + +The type of error diffusion to perform on the alpha channel when +transp is 'errdiff'. This can be any defined error diffusion type +except for custom (see errdiff below). + +=item tr_orddith + +The type of ordered dither to perform on the alpha channel when transp +is 'ordered'. Possible values are: + +=over + +=item random + +A semi-random map is used. The map is the same each time. + +=item dot8 + +8x8 dot dither. + +=item dot4 + +4x4 dot dither + +=item hline + +horizontal line dither. + +=item vline + +vertical line dither. + +=item "/line" + +=item slashline + +diagonal line dither + +=item '\line' + +=item backline + +diagonal line dither + +=item tiny + +dot matrix dither (currently the default). This is probably the best +for displays (like web pages). + +=item custom + +A custom dither matrix is used - see tr_map + +=back + +=item tr_map + +When tr_orddith is custom this defines an 8 x 8 matrix of integers +representing the transparency threshold for pixels corresponding to +each position. This should be a 64 element array where the first 8 +entries correspond to the first row of the matrix. Values should be +betweern 0 and 255. + +=item make_colors + +Defines how the quantization engine will build the palette(s). +Currently this is ignored if 'translate' is 'giflib', but that may +change. Possible values are: + +=over + +=item * + +none - only colors supplied in 'colors' are used. + +=item * + +webmap - the web color map is used (need url here.) + +=item * + +addi - The original code for generating the color map (Addi's code) is +used. + +=item * + +mediancut - Uses a mediancut algorithm, faster than 'addi', but not as good a +result. + +=item * + +mono, monochrome - a fixed black and white palette, suitable for +producing bi-level images (eg. facsimile) + +=back + +Other methods may be added in the future. + +=item colors + +A arrayref containing Imager::Color objects, which represents the +starting set of colors to use in translating the images. webmap will +ignore this. On return the final colors used are copied back into +this array (which is expanded if necessary.) + +=item max_colors + +The maximum number of colors to use in the image. + +=item translate + +The method used to translate the RGB values in the source image into +the colors selected by make_colors. Note that make_colors is ignored +whene translate is 'giflib'. + +Possible values are: + +=over + +=item giflib + +The giflib native quantization function is used. + +=item closest + +The closest color available is used. + +=item perturb + +The pixel color is modified by perturb, and the closest color is chosen. + +=item errdiff + +An error diffusion dither is performed. + +=back + +It's possible other transate values will be added. + +=item errdiff + +The type of error diffusion dither to perform. These values (except +for custom) can also be used in tr_errdif. + +=over + +=item floyd + +Floyd-Steinberg dither + +=item jarvis + +Jarvis, Judice and Ninke dither + +=item stucki + +Stucki dither + +=item custom + +Custom. If you use this you must also set errdiff_width, +errdiff_height and errdiff_map. + +=back + +=item errdiff_width + +=item errdiff_height + +=item errdiff_orig + +=item errdiff_map + +When translate is 'errdiff' and errdiff is 'custom' these define a +custom error diffusion map. errdiff_width and errdiff_height define +the size of the map in the arrayref in errdiff_map. errdiff_orig is +an integer which indicates the current pixel position in the top row +of the map. + +=item perturb + +When translate is 'perturb' this is the magnitude of the random bias +applied to each channel of the pixel before it is looked up in the +color table. + +=back + +=head1 INITIALIZATION + +This documents the Imager initialization function, which you will +almost never need to call. + +=over + +=item init + +This is a function, not a method. + +This function is a mess, it can take the following named parameters: + +=over + +=item * + +log - name of a log file to log Imager's actions to. Not all actions +are logged, but the debugging memory allocator does log allocations +here. Ignored if Imager has been built without logging support. + +=item * + +loglevel - the maximum level of message to log. Default: 1. + +=item * + +warn_obsolete - if this is non-zero then Imager will warn when you +attempt to use obsoleted parameters or functionality. This currently +only includes the old gif output options instead of tags. + +=item * + +t1log - if non-zero then T1lib will be configured to produce a log +file. This will fail if there are any existing T1lib font objects. + +=back + +Example: + + Imager::init(log => 'trace.log', loglevel => 9); + +=back + +=head1 REVISION + +$Revision: 1626 $ + +=head1 AUTHORS + +Tony Cook, Arnar M. Hrafnkelsson + +=head1 SEE ALSO + +Imager(3), Imager::Files(3), Imager::Draw(3), +Imager::Color(3), Imager::Fill(3), Imager::Font(3), +Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3), +Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3) + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Inline.pod b/Master/tlpkg/tlperl0/lib/Imager/Inline.pod new file mode 100755 index 00000000000..8afc51e5e0e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Inline.pod @@ -0,0 +1,74 @@ +=head1 NAME + +Imager::Inline - using Imager with Inline::C. + +=head1 SYNOPSIS + + use Inline with => 'Imager'; + use Inline C => <<'EOS'; + Imager some_func(Imager::Color c, Imager::Fill f) { + Imager img = i_img_8_new(200, 200, 3); + /* fill with color */ + i_box_filled(img, 0, 0, 199, 199, c); + /* inner area with fill */ + i_box_cfill(img, 50, 50, 149, 149, f); + + return img; + } + EOS + +=head1 DESCRIPTION + +Imager hooks into Inline's C<with> syntax to make it easier to write +Inline::C code that works with Imager, you can call Imager functions +without having to include headers or perform initialization. + +Imager's inline C<with> support does the following: + +=over + +=item * + +add the installed Imager include directory to INC + +=item * + +add the Imager typemap to TYPEMAPS + +=item * + +include the headers needed by Imager C extension modules. + +=item * + +declare and initialize the Imager API function table pointer + +=item * + +filter the supplied code to replace Imager's class names with those +that Inline::C can handle. + +=back + +=head1 LIMITATIONS + +The filtering mechanism is global, it will replace the class names +even inside string constants. If you need a string matching the name +of one of Imager's classes, like C<"Imager::Color"> you will need to +split it into 2 to use C's string pasting mechanism, for example: +C<"Imager:" ":Color">. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 REVISION + +$Revision$ + +=head1 SEE ALSO + +Imager, Imager::ExtUtils, Imager::API, Imager::APIRef, +samples/inline_replace_color.pl + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/LargeSamples.pod b/Master/tlpkg/tlperl0/lib/Imager/LargeSamples.pod new file mode 100755 index 00000000000..fe2f8f027ad --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/LargeSamples.pod @@ -0,0 +1,110 @@ +=head1 NAME + +Imager::LargeSamples - track/document large sample support + +=head1 SYNOPSIS + + # make a large sample image + my $im = Imager->new(..., bits => 16); + + # call some method + my $result = $im->$method(...); + + # was the image modified at its full sample size + +=head1 DESCRIPTION + +Imager has had in-memory support for large samples for years now, but +many methods still don't work at the higher sample size when supplied +with a large sample image. + +This document will track which methods support large samples and which +don't, for future improvements. + +=head1 Support by method + + Method Support Notes + ------ ------- ----- + arc Partial [1] + box Partial [1] + circle Partial [1] + convert Full + copy Full + crop Full + difference Full + filter Partial Depends on the filter. + flip Full + flood_fill Partial [1] + getpixel Full + getsamples Full + getscanline Full + map None + masked Full + matrix_transform + Full + paste Full + polygon Partial [1] + polyline None + read Partial See L<File format large sample support> + read_multi Partial See L<File format large sample support> + rotate Full + rubthrough Full + scale Partial Some qtypes support large samples + scaleX None + scaleY None + setpixel Full + setscanline Full + string Full Preserves large samples, but most font drivers + generate 8 or fewer bits of levels of coverage. + transform None + transform2 None + write Partial See L<File format large sample support> + write_multi Partial See L<File format large sample support> + +[1] filling an area using the fill parameter works at the full depth +of the image, using filled => 1 and color works at 8-bits/sample + +=head1 File format large sample support + + Format Format samples Imager support + ------ -------------- -------------- + BMP 8 8 + GIF 8 8 + ICO 8 8 + JPEG 8, 12 8 + PBM 1 1 + PGM/PPM 1-16 read any, writes 8, 16 + PNG 1, 2, 4, 8, 16 8 + RAW 8 + SGI 8, 16 8, 16 + TGA 8 8 + TIFF (many) read/write 8, 16, 32 contig rgb/grey images + read/write bi-level + read/write 4/8 paletted images + +=head1 Filter larger sample support + + Filter Large sample support + ------ -------------------- + autolevels No + bumpmap No + bumpmap_complex No + contrast No + conv Yes + fountain Yes + gaussian Yes + gradgen No + hardinvert Yes + mosaic No + postlevels No + radnoise No + turbnoise No + unsharpmask Yes + watermark No + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Matrix2d.pm b/Master/tlpkg/tlperl0/lib/Imager/Matrix2d.pm new file mode 100755 index 00000000000..a1000092ea4 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Matrix2d.pm @@ -0,0 +1,409 @@ +package Imager::Matrix2d; +use strict; +use vars qw($VERSION); + +$VERSION = "1.008"; + +=head1 NAME + + Imager::Matrix2d - simple wrapper for matrix construction + +=head1 SYNOPSIS + + use Imager::Matrix2d; + $m1 = Imager::Matrix2d->identity; + $m2 = Imager::Matrix2d->rotate(radians=>$angle, x=>$cx, y=>$cy); + $m3 = Imager::Matrix2d->translate(x=>$dx, y=>$dy); + $m4 = Imager::Matrix2d->shear(x=>$sx, y=>$sy); + $m5 = Imager::Matrix2d->reflect(axis=>$axis); + $m6 = Imager::Matrix2d->scale(x=>$xratio, y=>$yratio); + $m6 = $m1 * $m2; + $m7 = $m1 + $m2; + use Imager::Matrix2d qw(:handy); + # various m2d_* functions imported + # where m2d_(.*) calls Imager::Matrix2d->$1() + +=head1 DESCRIPTION + +This class provides a simple wrapper around a reference to an array of +9 co-efficients, treated as a matrix: + + [ 0, 1, 2, + 3, 4, 5, + 6, 7, 8 ] + +Most of the methods in this class are constructors. The others are +overloaded operators. + +Note that since Imager represents images with y increasing from top to +bottom, rotation angles are clockwise, rather than counter-clockwise. + +=over + +=cut + +use vars qw(@EXPORT_OK %EXPORT_TAGS @ISA); +@ISA = 'Exporter'; +require 'Exporter.pm'; +@EXPORT_OK = qw(m2d_rotate m2d_identity m2d_translate m2d_shear + m2d_reflect m2d_scale); +%EXPORT_TAGS = + ( + handy=> [ qw(m2d_rotate m2d_identity m2d_translate m2d_shear + m2d_reflect m2d_scale) ], + ); + +use overload + '*' => \&_mult, + '+' => \&_add, + '""'=>\&_string; + +=item identity() + +Returns the identity matrix. + +=cut + +sub identity { + return bless [ 1, 0, 0, + 0, 1, 0, + 0, 0, 1 ], $_[0]; +} + +=item rotate(radians=>$angle) + +=item rotate(degrees=>$angle) + +Creates a matrix that rotates around the origin, or around the point +(x,y) if the 'x' and 'y' parameters are provided. + +=cut + +sub rotate { + my ($class, %opts) = @_; + my $angle; + + if (defined $opts{radians}) { + $angle = $opts{radians}; + } + elsif (defined $opts{degrees}) { + $angle = $opts{degrees} * 3.1415926535 / 180; + } + else { + $Imager::ERRSTR = "degrees or radians parameter required"; + return undef; + } + + if ($opts{'x'} || $opts{'y'}) { + $opts{'x'} ||= 0; + $opts{'y'} ||= 0; + return $class->translate('x'=>-$opts{'x'}, 'y'=>-$opts{'y'}) + * $class->rotate(radians=>$angle) + * $class->translate('x'=>$opts{'x'}, 'y'=>$opts{'y'}); + } + else { + my $sin = sin($angle); + my $cos = cos($angle); + return bless [ $cos, -$sin, 0, + $sin, $cos, 0, + 0, 0, 1 ], $class; + } +} + +=item translate(x=>$dx, y=>$dy) + +=item translate(x=>$dx) + +=item translate(y=>$dy) + +Translates by the specify amounts. + +=cut + +sub translate { + my ($class, %opts) = @_; + + if (defined $opts{'x'} || defined $opts{'y'}) { + my $x = $opts{'x'} || 0; + my $y = $opts{'y'} || 0; + return bless [ 1, 0, $x, + 0, 1, $y, + 0, 0, 1 ], $class; + } + + $Imager::ERRSTR = 'x or y parameter required'; + return undef; +} + +=item shear(x=>$sx, y=>$sy) + +=item shear(x=>$sx) + +=item shear(y=>$sy) + +Shear by the given amounts. + +=cut +sub shear { + my ($class, %opts) = @_; + + if (defined $opts{'x'} || defined $opts{'y'}) { + return bless [ 1, $opts{'x'}||0, 0, + $opts{'y'}||0, 1, 0, + 0, 0, 1 ], $class; + } + $Imager::ERRSTR = 'x and y parameters required'; + return undef; +} + +=item reflect(axis=>$axis) + +Reflect around the given axis, either 'x' or 'y'. + +=item reflect(radians=>$angle) + +=item reflect(degrees=>$angle) + +Reflect around a line drawn at the given angle from the origin. + +=cut + +sub reflect { + my ($class, %opts) = @_; + + if (defined $opts{axis}) { + my $result = $class->identity; + if ($opts{axis} eq "y") { + $result->[0] = -$result->[0]; + } + elsif ($opts{axis} eq "x") { + $result->[4] = -$result->[4]; + } + else { + $Imager::ERRSTR = 'axis must be x or y'; + return undef; + } + + return $result; + } + my $angle; + if (defined $opts{radians}) { + $angle = $opts{radians}; + } + elsif (defined $opts{degrees}) { + $angle = $opts{degrees} * 3.1415926535 / 180; + } + else { + $Imager::ERRSTR = 'axis, degrees or radians parameter required'; + return undef; + } + + # fun with matrices + return $class->rotate(radians=>-$angle) * $class->reflect(axis=>'x') + * $class->rotate(radians=>$angle); +} + +=item scale(x=>$xratio, y=>$yratio) + +Scales at the given ratios. + +You can also specify a center for the scaling with the cx and cy +parameters. + +=cut + +sub scale { + my ($class, %opts) = @_; + + if (defined $opts{'x'} || defined $opts{'y'}) { + $opts{'x'} = 1 unless defined $opts{'x'}; + $opts{'y'} = 1 unless defined $opts{'y'}; + if ($opts{cx} || $opts{cy}) { + return $class->translate('x'=>-$opts{cx}, 'y'=>-$opts{cy}) + * $class->scale('x'=>$opts{'x'}, 'y'=>$opts{'y'}) + * $class->translate('x'=>$opts{cx}, 'y'=>$opts{cy}); + } + else { + return bless [ $opts{'x'}, 0, 0, + 0, $opts{'y'}, 0, + 0, 0, 1 ], $class; + } + } + else { + $Imager::ERRSTR = 'x or y parameter required'; + return undef; + } +} + +=item _mult() + +Implements the overloaded '*' operator. Internal use. + +Currently both the left and right-hand sides of the operator must be +an Imager::Matrix2d. + +=cut +sub _mult { + my ($left, $right, $order) = @_; + + if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) { + if ($order) { + ($left, $right) = ($right, $left); + } + my @result; + for my $i (0..2) { + for my $j (0..2) { + my $accum = 0; + for my $k (0..2) { + $accum += $left->[3*$i + $k] * $right->[3*$k + $j]; + } + $result[3*$i+$j] = $accum; + } + } + return bless \@result, __PACKAGE__; + } + else { + # presumably N * matrix or matrix * N + return undef; # for now + } +} + +=item _add() + +Implements the overloaded binary '+' operator. + +Currently both the left and right sides of the operator must be +Imager::Matrix2d objects. + +=cut +sub _add { + my ($left, $right, $order) = @_; + + if (ref($right) && UNIVERSAL::isa($right, __PACKAGE__)) { + my @result; + for (0..8) { + push @result, $left->[$_] + $right->[$_]; + } + + return bless \@result, __PACKAGE__; + } + else { + return undef; + } +} + +=item _string() + +Implements the overloaded stringification operator. + +This returns a string containing 3 lines of text with no terminating +newline. + +I tried to make it fairly nicely formatted. You might disagree :) + +=cut + +sub _string { + my ($m) = @_; + + my $maxlen = 0; + for (@$m[0..8]) { + if (length() > $maxlen) { + $maxlen = length; + } + } + $maxlen <= 9 or $maxlen = 9; + + my @left = ('[ ', ' ', ' '); + my @right = ("\n", "\n", ']'); + my $out; + my $width = $maxlen+2; + for my $i (0..2) { + $out .= $left[$i]; + for my $j (0..2) { + my $val = $m->[$i*3+$j]; + if (length $val > 9) { + $val = sprintf("%9f", $val); + if ($val =~ /\./ && $val !~ /e/i) { + $val =~ s/0+$//; + $val =~ s/\.$//; + } + $val =~ s/^\s//; + } + $out .= sprintf("%-${width}s", "$val, "); + } + $out =~ s/ +\Z/ /; + $out .= $right[$i]; + } + $out; +} + +=back + +The following functions are shortcuts to the various constructors. + +These are not methods. + +You can import these methods with: + + use Imager::Matrix2d ':handy'; + +=over + +=item m2d_identity + +=item m2d_rotate() + +=item m2d_translate() + +=item m2d_shear() + +=item m2d_reflect() + +=item m2d_scale() + +=back + +=cut + +sub m2d_identity { + return __PACKAGE__->identity; +} + +sub m2d_rotate { + return __PACKAGE__->rotate(@_); +} + +sub m2d_translate { + return __PACKAGE__->translate(@_); +} + +sub m2d_shear { + return __PACKAGE__->shear(@_); +} + +sub m2d_reflect { + return __PACKAGE__->reflect(@_); +} + +sub m2d_scale { + return __PACKAGE__->scale(@_); +} + +1; + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=head1 BUGS + +Needs a way to invert matrixes. + +=head1 SEE ALSO + +Imager(3), Imager::Font(3) + +http://imager.perl.org/ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Preprocess.pm b/Master/tlpkg/tlperl0/lib/Imager/Preprocess.pm new file mode 100755 index 00000000000..f0b5be78892 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Preprocess.pm @@ -0,0 +1,297 @@ +package Imager::Preprocess; +use strict; +require Exporter; +use vars qw(@ISA @EXPORT); + +@EXPORT = qw(preprocess); +@ISA = qw(Exporter); + + +sub preprocess { + my $src = shift @ARGV; + my $dest = shift @ARGV + or usage(); + + open SRC, "< $src" + or die "Cannot open $src: $!\n"; + + my $cond; + my $cond_line; + my $save_code; + my @code; + my $code_line; + my @out; + my $failed; + + push @out, + "#define IM_ROUND_8(x) ((int)((x)+0.5))\n", + "#define IM_ROUND_double(x) (x)\n", + "#define IM_LIMIT_8(x) ((x) < 0 ? 0 : (x) > 255 ? 255 : (x))\n", + "#define IM_LIMIT_double(x) ((x) < 0.0 ? 0.0 : (x) > 1.0 ? 1.0 : (x))\n", + "#line 1 \"$src\"\n"; + while (defined(my $line = <SRC>)) { + if ($line =~ /^\#code\s+(\S.+)$/) { + $save_code + and do { warn "$src:$code_line:Unclosed #code block\n"; ++$failed; }; + + $cond = $1; + $cond_line = $.; + $code_line = $. + 1; + $save_code = 1; + } + elsif ($line =~ /^\#code\s*$/) { + $save_code + and do { warn "$src:$code_line:Unclosed #code block\n"; ++$failed; }; + + $cond = ''; + $cond_line = 0; + $code_line = $. + 1; + $save_code = 1; + } + elsif ($line =~ /^\#\/code\s*$/) { + $save_code + or do { warn "$src:$.:#/code without #code\n"; ++$failed; next; }; + + if ($cond) { + push @out, "#line $cond_line \"$src\"\n"; + push @out, " if ($cond) {\n"; + } + push @out, + "#undef IM_EIGHT_BIT\n", + "#define IM_EIGHT_BIT 1\n", + "#undef IM_FILL_COMBINE\n", + "#define IM_FILL_COMBINE(fill) ((fill)->combine)\n", + "#undef IM_FILL_FILLER\n", + "#define IM_FILL_FILLER(fill) ((fill)->f_fill_with_color)\n"; + push @out, "#line $code_line \"$src\"\n"; + push @out, byte_samples(@code); + push @out, " }\n", " else {\n" + if $cond; + push @out, + "#undef IM_EIGHT_BIT\n", + "#undef IM_FILL_COMBINE\n", + "#define IM_FILL_COMBINE(fill) ((fill)->combinef)\n", + "#undef IM_FILL_FILLER\n", + "#define IM_FILL_FILLER(fill) ((fill)->f_fill_with_fcolor)\n"; + push @out, "#line $code_line \"$src\"\n"; + push @out, double_samples(@code); + push @out, " }\n" + if $cond; + push @out, "#line ",$.+1," \"$src\"\n"; + @code = (); + $save_code = 0; + } + elsif ($save_code) { + push @code, $line; + } + else { + push @out, $line; + } + } + + if ($save_code) { + warn "$src:$code_line:#code block not closed by EOF\n"; + ++$failed; + } + + close SRC; + + $failed + and die "Errors during parsing, aborting\n"; + + open DEST, "> $dest" + or die "Cannot open $dest: $!\n"; + print DEST @out; + close DEST; +} + +sub byte_samples { + # important we make a copy + my @lines = @_; + + for (@lines) { + s/\bIM_GPIX\b/i_gpix/g; + s/\bIM_GLIN\b/i_glin/g; + s/\bIM_PPIX\b/i_ppix/g; + s/\bIM_PLIN\b/i_plin/g; + s/\bIM_GSAMP\b/i_gsamp/g; + s/\bIM_SAMPLE_MAX\b/255/g; + s/\bIM_SAMPLE_MAX2\b/65025/g; + s/\bIM_SAMPLE_T/i_sample_t/g; + s/\bIM_COLOR\b/i_color/g; + s/\bIM_WORK_T\b/int/g; + s/\bIM_Sf\b/"%d"/g; + s/\bIM_Wf\b/"%d"/g; + s/\bIM_SUFFIX\((\w+)\)/$1_8/g; + s/\bIM_ROUND\(/IM_ROUND_8(/g; + s/\bIM_ADAPT_COLORS\(/i_adapt_colors(/g; + s/\bIM_LIMIT\(/IM_LIMIT_8(/g; + s/\bIM_RENDER_LINE\(/i_render_line(/g; + s/\bIM_FILL_COMBINE_F\b/i_fill_combine_f/g; + } + + @lines; +} + +sub double_samples { + # important we make a copy + my @lines = @_; + + for (@lines) { + s/\bIM_GPIX\b/i_gpixf/g; + s/\bIM_GLIN\b/i_glinf/g; + s/\bIM_PPIX\b/i_ppixf/g; + s/\bIM_PLIN\b/i_plinf/g; + s/\bIM_GSAMP\b/i_gsampf/g; + s/\bIM_SAMPLE_MAX\b/1.0/g; + s/\bIM_SAMPLE_MAX2\b/1.0/g; + s/\bIM_SAMPLE_T/i_fsample_t/g; + s/\bIM_COLOR\b/i_fcolor/g; + s/\bIM_WORK_T\b/double/g; + s/\bIM_Sf\b/"%f"/g; + s/\bIM_Wf\b/"%f"/g; + s/\bIM_SUFFIX\((\w+)\)/$1_double/g; + s/\bIM_ROUND\(/IM_ROUND_double(/g; + s/\bIM_ADAPT_COLORS\(/i_adapt_fcolors(/g; + s/\bIM_LIMIT\(/IM_LIMIT_double(/g; + s/\bIM_RENDER_LINE\(/i_render_linef(/g; + s/\bIM_FILL_COMBINE_F\b/i_fill_combinef_f/g; + } + + @lines; +} + +1; + +__END__ + +=head1 NAME + +Imager::Preprocess - simple preprocessor for handling multiple sample sizes + +=head1 SYNOPSIS + + /* in the source: */ + #code condition true to work with 8-bit samples + ... code using preprocessor types/values ... + #/code + + perl -MImager -epreprocess foo.im foo.c + +=head1 DESCRIPTION + +This is a simple preprocessor that aims to reduce duplication of +source code when implementing an algorithm both for 8-bit samples and +double samples in Imager. + +Imager's Makefile.PL currently scans the MANIFEST for .im files and +adds Makefile files to convert these to .c files. + +The beginning of a sample-independent section of code is preceded by: + + #code expression + +where I<expression> should return true if processing should be done at +8-bits/sample. + +You can also use a #code block around a function definition to produce +8-bit and double sample versions of a function. In this case #code +has no expression and you will need to use IM_SUFFIX() to produce +different function names. + +The end of a sample-independent section of code is terminated by: + + #/code + +#code sections cannot be nested. + +#/code without a starting #code is an error. + +The following types and values are defined in a #code section: + +=over + +=item * + +IM_GPIX(im, x, y, &col) + +=item * + +IM_GLIN(im, l, r, y, colors) + +=item * + +IM_PPIX(im, x, y, &col) + +=item * + +IM_PLIN(im, x, y, colors) + +=item * + +IM_GSAMP(im, l, r, y, samples, chans, chan_count) + +These correspond to the appropriate image function, eg. IM_GPIX() +becomes i_gpix() or i_gpixf() as appropriate. + +=item * + +IM_ADAPT_COLORS(dest_channes, src_channels, colors, count) + +Call i_adapt_colors() or i_adapt_fcolors(). + +=item * + +IM_FILL_COMBINE(fill) - retrieve the combine function from a fill +object. + +=item * + +IM_FILL_FILLER(fill) - retrieve the fill_with_* function from a fill +object. + +=item * + +IM_SAMPLE_MAX - maximum value for a sample + +=item * + +IM_SAMPLE_MAX2 - maximum value for a sample, squared + +=item * + +IM_SAMPLE_T - type of a sample (i_sample_t or i_fsample_t) + +=item * + +IM_COLOR - color type, either i_color or i_fcolor. + +=item * + +IM_WORK_T - working sample type, either int or double. + +=item * + +IM_Sf - format string for the sample type, C<"%d"> or C<"%f">. + +=item * + +IM_Wf - format string for the work type, C<"%d"> or C<"%f">. + +=item * + +IM_SUFFIX(identifier) - adds _8 or _double onto the end of identifier. + +=item * + +IM_EIGHT_BIT - this is a macro defined only in 8-bit/sample code. + +=back + +Other types, functions and values may be added in the future. + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Regops.pm b/Master/tlpkg/tlperl0/lib/Imager/Regops.pm new file mode 100755 index 00000000000..e2ed07e659f --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Regops.pm @@ -0,0 +1,528 @@ +# AUTOMATICALLY GENERATED BY regops.perl +package Imager::Regops; +use strict; +require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK %Attr $MaxOperands $PackCode); +@ISA = qw(Exporter); +@EXPORT_OK = qw(%Attr $MaxOperands $PackCode); + +use constant RBC_ADD => 0; +use constant RBC_SUBTRACT => 1; +use constant RBC_MULT => 2; +use constant RBC_DIV => 3; +use constant RBC_MOD => 4; +use constant RBC_POW => 5; +use constant RBC_UMINUS => 6; +use constant RBC_MULTP => 7; +use constant RBC_ADDP => 8; +use constant RBC_SUBTRACTP => 9; +use constant RBC_SIN => 10; +use constant RBC_COS => 11; +use constant RBC_ATAN2 => 12; +use constant RBC_SQRT => 13; +use constant RBC_DISTANCE => 14; +use constant RBC_GETP1 => 15; +use constant RBC_GETP2 => 16; +use constant RBC_GETP3 => 17; +use constant RBC_VALUE => 18; +use constant RBC_HUE => 19; +use constant RBC_SAT => 20; +use constant RBC_HSV => 21; +use constant RBC_RED => 22; +use constant RBC_GREEN => 23; +use constant RBC_BLUE => 24; +use constant RBC_RGB => 25; +use constant RBC_INT => 26; +use constant RBC_IF => 27; +use constant RBC_IFP => 28; +use constant RBC_LE => 29; +use constant RBC_LT => 30; +use constant RBC_GE => 31; +use constant RBC_GT => 32; +use constant RBC_EQ => 33; +use constant RBC_NE => 34; +use constant RBC_AND => 35; +use constant RBC_OR => 36; +use constant RBC_NOT => 37; +use constant RBC_ABS => 38; +use constant RBC_RET => 39; +use constant RBC_JUMP => 40; +use constant RBC_JUMPZ => 41; +use constant RBC_JUMPNZ => 42; +use constant RBC_SET => 43; +use constant RBC_SETP => 44; +use constant RBC_PRINT => 45; +use constant RBC_RGBA => 46; +use constant RBC_HSVA => 47; +use constant RBC_ALPHA => 48; +use constant RBC_LOG => 49; +use constant RBC_EXP => 50; +use constant RBC_DET => 51; +use constant RBC_OP_COUNT => 52; + +@EXPORT = qw(RBC_ADD RBC_SUBTRACT RBC_MULT RBC_DIV RBC_MOD RBC_POW RBC_UMINUS RBC_MULTP RBC_ADDP RBC_SUBTRACTP RBC_SIN RBC_COS RBC_ATAN2 RBC_SQRT RBC_DISTANCE RBC_GETP1 RBC_GETP2 RBC_GETP3 RBC_VALUE RBC_HUE RBC_SAT RBC_HSV RBC_RED RBC_GREEN RBC_BLUE RBC_RGB RBC_INT RBC_IF RBC_IFP RBC_LE RBC_LT RBC_GE RBC_GT RBC_EQ RBC_NE RBC_AND RBC_OR RBC_NOT RBC_ABS RBC_RET RBC_JUMP RBC_JUMPZ RBC_JUMPNZ RBC_SET RBC_SETP RBC_PRINT RBC_RGBA RBC_HSVA RBC_ALPHA RBC_LOG RBC_EXP RBC_DET RBC_OP_COUNT); + +%Attr = + ( + 'abs' => + { + 'func' => 1, + 'opcode' => 38, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'add' => + { + 'func' => 0, + 'opcode' => 0, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'addp' => + { + 'func' => 0, + 'opcode' => 8, + 'parms' => 2, + 'result' => 'p', + 'types' => 'pp', + }, + 'alpha' => + { + 'func' => 1, + 'opcode' => 48, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'and' => + { + 'func' => 0, + 'opcode' => 35, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'atan2' => + { + 'func' => 1, + 'opcode' => 12, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'blue' => + { + 'func' => 1, + 'opcode' => 24, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'cos' => + { + 'func' => 1, + 'opcode' => 11, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'det' => + { + 'func' => 1, + 'opcode' => 51, + 'parms' => 4, + 'result' => 'r', + 'types' => 'rrrr', + }, + 'distance' => + { + 'func' => 1, + 'opcode' => 14, + 'parms' => 4, + 'result' => 'r', + 'types' => 'rrrr', + }, + 'div' => + { + 'func' => 0, + 'opcode' => 3, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'eq' => + { + 'func' => 0, + 'opcode' => 33, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'exp' => + { + 'func' => 1, + 'opcode' => 50, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'ge' => + { + 'func' => 0, + 'opcode' => 31, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'getp1' => + { + 'func' => 1, + 'opcode' => 15, + 'parms' => 2, + 'result' => 'p', + 'types' => 'rr', + }, + 'getp2' => + { + 'func' => 1, + 'opcode' => 16, + 'parms' => 2, + 'result' => 'p', + 'types' => 'rr', + }, + 'getp3' => + { + 'func' => 1, + 'opcode' => 17, + 'parms' => 2, + 'result' => 'p', + 'types' => 'rr', + }, + 'green' => + { + 'func' => 1, + 'opcode' => 23, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'gt' => + { + 'func' => 0, + 'opcode' => 32, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'hsv' => + { + 'func' => 1, + 'opcode' => 21, + 'parms' => 3, + 'result' => 'p', + 'types' => 'rrr', + }, + 'hsva' => + { + 'func' => 1, + 'opcode' => 47, + 'parms' => 4, + 'result' => 'p', + 'types' => 'rrrr', + }, + 'hue' => + { + 'func' => 1, + 'opcode' => 19, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'if' => + { + 'func' => 1, + 'opcode' => 27, + 'parms' => 3, + 'result' => 'r', + 'types' => 'rrr', + }, + 'ifp' => + { + 'func' => 1, + 'opcode' => 28, + 'parms' => 3, + 'result' => 'p', + 'types' => 'rpp', + }, + 'int' => + { + 'func' => 1, + 'opcode' => 26, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'jump' => + { + 'func' => 0, + 'opcode' => 40, + 'parms' => 0, + 'result' => undef, + 'types' => '', + }, + 'jumpnz' => + { + 'func' => 0, + 'opcode' => 42, + 'parms' => 1, + 'result' => undef, + 'types' => 'r', + }, + 'jumpz' => + { + 'func' => 0, + 'opcode' => 41, + 'parms' => 1, + 'result' => undef, + 'types' => 'r', + }, + 'le' => + { + 'func' => 0, + 'opcode' => 29, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'log' => + { + 'func' => 1, + 'opcode' => 49, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'lt' => + { + 'func' => 0, + 'opcode' => 30, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'mod' => + { + 'func' => 0, + 'opcode' => 4, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'mult' => + { + 'func' => 0, + 'opcode' => 2, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'multp' => + { + 'func' => 0, + 'opcode' => 7, + 'parms' => 2, + 'result' => 'p', + 'types' => 'pr', + }, + 'ne' => + { + 'func' => 0, + 'opcode' => 34, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'not' => + { + 'func' => 0, + 'opcode' => 37, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'op_count' => + { + 'func' => 0, + 'opcode' => 52, + 'parms' => 0, + 'result' => undef, + 'types' => '', + }, + 'or' => + { + 'func' => 0, + 'opcode' => 36, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'pow' => + { + 'func' => 0, + 'opcode' => 5, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'print' => + { + 'func' => 1, + 'opcode' => 45, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'red' => + { + 'func' => 1, + 'opcode' => 22, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'ret' => + { + 'func' => 0, + 'opcode' => 39, + 'parms' => 1, + 'result' => undef, + 'types' => 'p', + }, + 'rgb' => + { + 'func' => 1, + 'opcode' => 25, + 'parms' => 3, + 'result' => 'p', + 'types' => 'rrr', + }, + 'rgba' => + { + 'func' => 1, + 'opcode' => 46, + 'parms' => 4, + 'result' => 'p', + 'types' => 'rrrr', + }, + 'sat' => + { + 'func' => 1, + 'opcode' => 20, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + 'set' => + { + 'func' => 0, + 'opcode' => 43, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'setp' => + { + 'func' => 0, + 'opcode' => 44, + 'parms' => 1, + 'result' => 'p', + 'types' => 'p', + }, + 'sin' => + { + 'func' => 1, + 'opcode' => 10, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'sqrt' => + { + 'func' => 1, + 'opcode' => 13, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'subtract' => + { + 'func' => 0, + 'opcode' => 1, + 'parms' => 2, + 'result' => 'r', + 'types' => 'rr', + }, + 'subtractp' => + { + 'func' => 0, + 'opcode' => 9, + 'parms' => 2, + 'result' => 'p', + 'types' => 'pp', + }, + 'uminus' => + { + 'func' => 0, + 'opcode' => 6, + 'parms' => 1, + 'result' => 'r', + 'types' => 'r', + }, + 'value' => + { + 'func' => 1, + 'opcode' => 18, + 'parms' => 1, + 'result' => 'r', + 'types' => 'p', + }, + ); +$MaxOperands = 4; +$PackCode = "i"; +1; + +__END__ + +=head1 NAME + +Imager::Regops - generated information about the register based VM + +=head1 SYNOPSIS + + use Imager::Regops; + $Imager::Regops::Attr{$opname}->{opcode} # opcode for given operator + $Imager::Regops::Attr{$opname}->{parms} # number of parameters + $Imager::Regops::Attr{$opname}->{types} # types of parameters + $Imager::Regops::Attr{$opname}->{func} # operator is a function + $Imager::Regops::Attr{$opname}->{result} # r for numeric, p for pixel result + $Imager::Regops::MaxOperands; # maximum number of operands + +=head1 DESCRIPTION + +This module is generated automatically from regmach.h so we don't need to +maintain the same information in at least one extra place. + +At least that's the idea. + +=head1 AUTHOR + +Tony Cook, tony@develop-help.com + +=head1 SEE ALSO + +perl(1), Imager(3), http://imager.perl.org/ + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/Test.pm b/Master/tlpkg/tlperl0/lib/Imager/Test.pm new file mode 100755 index 00000000000..8d66ecb26b5 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Test.pm @@ -0,0 +1,694 @@ +package Imager::Test; +use strict; +use Test::Builder; +require Exporter; +use vars qw(@ISA @EXPORT_OK); +@ISA = qw(Exporter); +@EXPORT_OK = + qw( + diff_text_with_nul + test_image_raw + test_image_16 + test_image + test_image_double + is_color1 + is_color3 + is_color4 + is_color_close3 + is_fcolor4 + color_cmp + is_image + is_imaged + is_image_similar + isnt_image + image_bounds_checks + mask_tests + test_colorf_gpix + test_color_gpix + test_colorf_glin); + +sub diff_text_with_nul { + my ($desc, $text1, $text2, @params) = @_; + + my $builder = Test::Builder->new; + + print "# $desc\n"; + my $imbase = Imager->new(xsize => 100, ysize => 100); + my $imcopy = Imager->new(xsize => 100, ysize => 100); + + $builder->ok($imbase->string(x => 5, 'y' => 50, size => 20, + string => $text1, + @params), "$desc - draw text1"); + $builder->ok($imcopy->string(x => 5, 'y' => 50, size => 20, + string => $text2, + @params), "$desc - draw text2"); + $builder->isnt_num(Imager::i_img_diff($imbase->{IMG}, $imcopy->{IMG}), 0, + "$desc - check result different"); +} + +sub is_color3($$$$$) { + my ($color, $red, $green, $blue, $comment) = @_; + + my $builder = Test::Builder->new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cr, $cg, $cb) = $color->rgba; + unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) { + $builder->diag(<<END_DIAG); +Color mismatch: + Red: $red vs $cr +Green: $green vs $cg + Blue: $blue vs $cb +END_DIAG + return; + } + + return 1; +} + +sub is_color_close3($$$$$$) { + my ($color, $red, $green, $blue, $tolerance, $comment) = @_; + + my $builder = Test::Builder->new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cr, $cg, $cb) = $color->rgba; + unless ($builder->ok(abs($cr - $red) <= $tolerance + && abs($cg - $green) <= $tolerance + && abs($cb - $blue) <= $tolerance, $comment)) { + $builder->diag(<<END_DIAG); +Color out of tolerance ($tolerance): + Red: expected $red vs received $cr +Green: expected $green vs received $cg + Blue: expected $blue vs received $cb +END_DIAG + return; + } + + return 1; +} + +sub is_color4($$$$$$) { + my ($color, $red, $green, $blue, $alpha, $comment) = @_; + + my $builder = Test::Builder->new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cr, $cg, $cb, $ca) = $color->rgba; + unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue + && $ca == $alpha, $comment)) { + $builder->diag(<<END_DIAG); +Color mismatch: + Red: $cr vs $red +Green: $cg vs $green + Blue: $cb vs $blue +Alpha: $ca vs $alpha +END_DIAG + return; + } + + return 1; +} + +sub is_fcolor4($$$$$$;$) { + my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_; + my ($comment, $mindiff); + if (defined $comment_or_undef) { + ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef ) + } + else { + ( $mindiff, $comment ) = ( 0.001, $comment_or_diff ) + } + + my $builder = Test::Builder->new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cr, $cg, $cb, $ca) = $color->rgba; + unless ($builder->ok(abs($cr - $red) <= $mindiff + && abs($cg - $green) <= $mindiff + && abs($cb - $blue) <= $mindiff + && abs($ca - $alpha) <= $mindiff, $comment)) { + $builder->diag(<<END_DIAG); +Color mismatch: + Red: $cr vs $red +Green: $cg vs $green + Blue: $cb vs $blue +Alpha: $ca vs $alpha +END_DIAG + return; + } + + return 1; +} + +sub is_color1($$$) { + my ($color, $grey, $comment) = @_; + + my $builder = Test::Builder->new; + + unless (defined $color) { + $builder->ok(0, $comment); + $builder->diag("color is undef"); + return; + } + unless ($color->can('rgba')) { + $builder->ok(0, $comment); + $builder->diag("color is not a color object"); + return; + } + + my ($cgrey) = $color->rgba; + unless ($builder->ok($cgrey == $grey, $comment)) { + $builder->diag(<<END_DIAG); +Color mismatch: + Grey: $grey vs $cgrey +END_DIAG + return; + } + + return 1; +} + +sub test_image_raw { + my $green=Imager::i_color_new(0,255,0,255); + my $blue=Imager::i_color_new(0,0,255,255); + my $red=Imager::i_color_new(255,0,0,255); + + my $img=Imager::ImgRaw::new(150,150,3); + + Imager::i_box_filled($img,70,25,130,125,$green); + Imager::i_box_filled($img,20,25,80,125,$blue); + Imager::i_arc($img,75,75,30,0,361,$red); + Imager::i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]); + + $img; +} + +sub test_image { + my $green = Imager::Color->new(0, 255, 0, 255); + my $blue = Imager::Color->new(0, 0, 255, 255); + my $red = Imager::Color->new(255, 0, 0, 255); + my $img = Imager->new(xsize => 150, ysize => 150); + $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]); + $img->box(filled => 1, color => $blue, box => [ 20, 26, 80, 126 ]); + $img->arc(x => 75, y => 75, r => 30, color => $red); + $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); + + $img; +} + +sub test_image_16 { + my $green = Imager::Color->new(0, 255, 0, 255); + my $blue = Imager::Color->new(0, 0, 255, 255); + my $red = Imager::Color->new(255, 0, 0, 255); + my $img = Imager->new(xsize => 150, ysize => 150, bits => 16); + $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]); + $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]); + $img->arc(x => 75, y => 75, r => 30, color => $red); + $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); + + $img; +} + +sub test_image_double { + my $green = Imager::Color->new(0, 255, 0, 255); + my $blue = Imager::Color->new(0, 0, 255, 255); + my $red = Imager::Color->new(255, 0, 0, 255); + my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double'); + $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]); + $img->box(filled => 1, color => $blue, box => [ 20, 25, 80, 125 ]); + $img->arc(x => 75, y => 75, r => 30, color => $red); + $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]); + + $img; +} + +sub _low_image_diff_check { + my ($left, $right, $comment) = @_; + + my $builder = Test::Builder->new; + + unless (defined $left) { + $builder->ok(0, $comment); + $builder->diag("left is undef"); + return; + } + unless (defined $right) { + $builder->ok(0, $comment); + $builder->diag("right is undef"); + return; + } + unless ($left->{IMG}) { + $builder->ok(0, $comment); + $builder->diag("left image has no low level object"); + return; + } + unless ($right->{IMG}) { + $builder->ok(0, $comment); + $builder->diag("right image has no low level object"); + return; + } + unless ($left->getwidth == $right->getwidth) { + $builder->ok(0, $comment); + $builder->diag("left width " . $left->getwidth . " vs right width " + . $right->getwidth); + return; + } + unless ($left->getheight == $right->getheight) { + $builder->ok(0, $comment); + $builder->diag("left height " . $left->getheight . " vs right height " + . $right->getheight); + return; + } + unless ($left->getchannels == $right->getchannels) { + $builder->ok(0, $comment); + $builder->diag("left channels " . $left->getchannels . " vs right channels " + . $right->getchannels); + return; + } + + return 1; +} + +sub is_image_similar($$$$) { + my ($left, $right, $limit, $comment) = @_; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + _low_image_diff_check($left, $right, $comment) + or return; + } + + my $builder = Test::Builder->new; + + my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); + if ($diff > $limit) { + $builder->ok(0, $comment); + $builder->diag("image data difference > $limit - $diff"); + + if ($limit == 0) { + # find the first mismatch + PIXELS: + for my $y (0 .. $left->getheight()-1) { + for my $x (0.. $left->getwidth()-1) { + my @lsamples = $left->getsamples(x => $x, y => $y, width => 1); + my @rsamples = $right->getsamples(x => $x, y => $y, width => 1); + if ("@lsamples" ne "@rsamples") { + $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples"); + last PIXELS; + } + } + } + } + + return; + } + + return $builder->ok(1, $comment); +} + +sub is_image($$$) { + my ($left, $right, $comment) = @_; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + return is_image_similar($left, $right, 0, $comment); +} + +sub is_imaged($$$) { + my ($left, $right, $comment) = @_; + + { + local $Test::Builder::Level = $Test::Builder::Level + 1; + + _low_image_diff_check($left, $right, $comment) + or return; + } + + my $builder = Test::Builder->new; + + my $diff = Imager::i_img_diffd($left->{IMG}, $right->{IMG}); + if ($diff > 0) { + $builder->ok(0, $comment); + $builder->diag("image data difference: $diff"); + + # find the first mismatch + PIXELS: + for my $y (0 .. $left->getheight()-1) { + for my $x (0.. $left->getwidth()-1) { + my @lsamples = $left->getsamples(x => $x, y => $y, width => 1); + my @rsamples = $right->getsamples(x => $x, y => $y, width => 1); + if ("@lsamples" ne "@rsamples") { + $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples"); + last PIXELS; + } + } + } + + return; + } + + return $builder->ok(1, $comment); +} + +sub isnt_image { + my ($left, $right, $comment) = @_; + + my $builder = Test::Builder->new; + + my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG}); + + return $builder->ok($diff, "$comment"); +} + +sub image_bounds_checks { + my $im = shift; + + my $builder = Test::Builder->new; + + $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)'); + $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)'); + $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)'); + $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)'); + $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float'); + $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float'); + $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float'); + $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float'); + my $black = Imager::Color->new(0, 0, 0); + require Imager::Color::Float; + my $blackf = Imager::Color::Float->new(0, 0, 0); + $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)'); + $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)'); + $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)'); + $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)'); + $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float'); + $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float'); + $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float'); + $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float'); +} + +sub test_colorf_gpix { + my ($im, $x, $y, $expected, $epsilon, $comment) = @_; + + my $builder = Test::Builder->new; + + defined $comment or $comment = ''; + + my $c = Imager::i_gpixf($im, $x, $y); + unless ($c) { + $builder->ok(0, "$comment - retrieve color at ($x,$y)"); + return; + } + unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0, + "$comment - got right color ($x, $y)")) { + my @c = $c->rgba; + my @exp = $expected->rgba; + $builder->diag(<<EOS); +# got: ($c[0], $c[1], $c[2]) +# expected: ($exp[0], $exp[1], $exp[2]) +EOS + } + 1; +} + +sub test_color_gpix { + my ($im, $x, $y, $expected, $comment) = @_; + + my $builder = Test::Builder->new; + + defined $comment or $comment = ''; + my $c = Imager::i_get_pixel($im, $x, $y); + unless ($c) { + $builder->ok(0, "$comment - retrieve color at ($x,$y)"); + return; + } + unless ($builder->ok(color_cmp($c, $expected) == 0, + "got right color ($x, $y)")) { + my @c = $c->rgba; + my @exp = $expected->rgba; + $builder->diag(<<EOS); +# got: ($c[0], $c[1], $c[2]) +# expected: ($exp[0], $exp[1], $exp[2]) +EOS + return; + } + + return 1; +} + +sub test_colorf_glin { + my ($im, $x, $y, $pels, $comment) = @_; + + my $builder = Test::Builder->new; + + my @got = Imager::i_glinf($im, $x, $x+@$pels, $y); + @got == @$pels + or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved"); + + return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got), + "$comment - check colors ($x, $y)"); +} + +sub colorf_cmp { + my ($c1, $c2, $epsilon) = @_; + + defined $epsilon or $epsilon = 0; + + my @s1 = $c1->rgba; + my @s2 = $c2->rgba; + + # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n"; + return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0] + || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1] + || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2]; +} + +sub color_cmp { + my ($c1, $c2) = @_; + + my @s1 = $c1->rgba; + my @s2 = $c2->rgba; + + return $s1[0] <=> $s2[0] + || $s1[1] <=> $s2[1] + || $s1[2] <=> $s2[2]; +} + +# these test the action of the channel mask on the image supplied +# which should be an OO image. +sub mask_tests { + my ($im, $epsilon) = @_; + + my $builder = Test::Builder->new; + + defined $epsilon or $epsilon = 0; + + # we want to check all four of ppix() and plin(), ppix() and plinf() + # basic test procedure: + # first using default/all 1s mask, set to white + # make sure we got white + # set mask to skip a channel, set to grey + # make sure only the right channels set + + print "# channel mask tests\n"; + # 8-bit color tests + my $white = Imager::NC(255, 255, 255); + my $grey = Imager::NC(128, 128, 128); + my $white_grey = Imager::NC(128, 255, 128); + + print "# with ppix\n"; + $builder->ok($im->setmask(mask=>~0), "set to default mask"); + $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels"); + test_color_gpix($im->{IMG}, 0, 0, $white, "ppix"); + $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); + $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2"); + test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked"); + + print "# with plin\n"; + $builder->ok($im->setmask(mask=>~0), "set to default mask"); + $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]), + "set to white all channels"); + test_color_gpix($im->{IMG}, 0, 1, $white, "plin"); + $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); + $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]), + "set to grey, no channel 2"); + test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked"); + + # float color tests + my $whitef = Imager::NCF(1.0, 1.0, 1.0); + my $greyf = Imager::NCF(0.5, 0.5, 0.5); + my $white_greyf = Imager::NCF(0.5, 1.0, 0.5); + + print "# with ppixf\n"; + $builder->ok($im->setmask(mask=>~0), "set to default mask"); + $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels"); + test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf"); + $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); + $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2"); + test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked"); + + print "# with plinf\n"; + $builder->ok($im->setmask(mask=>~0), "set to default mask"); + $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]), + "set to white all channels"); + test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf"); + $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1"); + $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]), + "set to grey, no channel 2"); + test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked"); + +} + +1; + +__END__ + +=head1 NAME + +Imager::Test - common functions used in testing Imager + +=head1 SYNOPSIS + + use Imager::Test 'diff_text_with_nul'; + diff_text_with_nul($test_name, $text1, $text2, @string_options); + +=head1 DESCRIPTION + +This is a repository of functions used in testing Imager. + +Some functions will only be useful in testing Imager itself, while +others should be useful in testing modules that use Imager. + +No functions are exported by default. + +=head1 FUNCTIONS + +=over + +=item is_color3($color, $red, $blue, $green, $comment) + +Tests is $color matches the given ($red, $blue, $green) + +=item is_image($im1, $im2, $comment) + +Tests if the 2 images have the same content. Both images must be +defined, have the same width, height, channels and the same color in +each pixel. The color comparison is done at 8-bits per pixel. The +color representation such as direct vs paletted, bits per sample are +not checked. Equivalent to is_image_similar($im1, $im2, 0, $comment). + +=item is_imaged($im, $im2, $comment) + +Tests if the two images have the same content at the double/sample +level. + +=item is_image_similar($im1, $im2, $maxdiff, $comment) + +Tests if the 2 images have similar content. Both images must be +defined, have the same width, height and channels. The cum of the +squares of the differences of each sample are calculated and must be +less than or equal to I<$maxdiff> for the test to pass. The color +comparison is done at 8-bits per pixel. The color representation such +as direct vs paletted, bits per sample are not checked. + +=item test_image_raw() + +Returns a 150x150x3 Imager::ImgRaw test image. + +=item test_image() + +Returns a 150x150x3 8-bit/sample OO test image. + +=item test_image_16() + +Returns a 150x150x3 16-bit/sample OO test image. + +=item test_image_double() + +Returns a 150x150x3 double/sample OO test image. + +=item diff_text_with_nul($test_name, $text1, $text2, @options) + +Creates 2 test images and writes $text1 to the first image and $text2 +to the second image with the string() method. Each call adds 3 ok/not +ok to the output of the test script. + +Extra options that should be supplied include the font and either a +color or channel parameter. + +This was explicitly created for regression tests on #21770. + +=item image_bounds_checks($im) + +Attempts to write to various pixel positions outside the edge of the +image to ensure that it fails in those locations. + +Any new image type should pass these tests. Does 16 separate tests. + +=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment) + +Retrieves the pixel ($x,$y) from the low-level image $im and compares +it to the floating point color $expected, with a tolerance of epsilon. + +=item test_color_gpix($im, $x, $y, $expected, $comment) + +Retrieves the pixel ($x,$y) from the low-level image $im and compares +it to the floating point color $expected. + +=item test_colorf_glin($im, $x, $y, $pels, $comment) + +Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the +low level image $im and compares them against @$pels. + +=item mask_tests($im, $epsilon) + +Perform a standard set of mask tests on the OO image $im. + +=back + +=head1 AUTHOR + +Tony Cook <tony@develop-help.com> + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Transform.pm b/Master/tlpkg/tlperl0/lib/Imager/Transform.pm new file mode 100755 index 00000000000..4c43abbe1f7 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Transform.pm @@ -0,0 +1,534 @@ +package Imager::Transform; +use strict; +use Imager; +use Imager::Expr::Assem; +use vars qw($VERSION); + +$VERSION = "1.004"; + +my %funcs = + ( + mandel=> + { + desc=>"Mandelbrot set", + type=>'assem', + assem=><<EOS, +# x treated as in range minx..maxx +# y treated as in range miny..maxy + var nx:n ; var ny:n + var diffx:n ; var diffy:n +# conx/y are x/y adjusted to min..max ranges + var conx:n ; var cony:n + diffx = subtract maxx minx + conx = div x w + conx = mult conx diffx + conx = add conx minx + diffy = subtract maxy miny + cony = div y h + cony = mult cony diffy + cony = add cony miny + nx = 0 + ny = 0 + var count:n + count = 0 +loop: +# calculate (nx,ny)**2 +(x,y)-> +# (nx*nx-ny*ny+x, 2.nx.ny+y) + var wx:n ; var wy:n ; var work:n + wx = mult nx nx + wy = mult ny ny + wx = subtract wx wy + ny = mult ny nx + ny = mult ny 2 + nx = wx + nx = add nx conx + ny = add ny cony + work = distance nx ny 0 0 + work = gt work 2 + jumpnz work docol + count = add count 1 + work = lt count maxcount + jumpnz work loop + jumpnz insideangle doinang + var workp:p + workp = rgb 0 0 0 + ret workp + doinang: + var ang:n + ang = atan2 ny nx + ang = mult ang 360 + ang = div ang pi + workp = hsv ang 255 0.5 + ret workp + docol: + var outvalue:n + outvalue = mult outsidevaluestep count + outvalue = add outvalue outsidevalue + outvalue = mod outvalue 1.01 + jumpnz outsideangle do_outang + work = mult count huestep + work = add work huebase + work = mod work 360 + workp = hsv work 1 outvalue + ret workp + do_outang: + ang = atan2 ny nx + ang = mult ang 360 + ang = div ang pi + ang = add ang outsidebase + workp = hsv ang outsidesat outvalue + ret workp +EOS + constants=> + { + minx=>{ default=>-2, desc=>'Left of rendered area', }, + miny=>{ default=>-1.5, desc=>'Top of rendered area', }, + maxx=>{ default=>1, desc=>'Right of rendered area', }, + maxy=>{ default=>1.5, desc=>'Bottom of rendered area', }, + maxcount=>{ default=>100, desc=>'Maximum iterations', }, + huestep=>{ default=>21.1, desc=>'Hue step for number of iterations', }, + huebase=>{ default=>0, desc=>'Base hue for number of iterations', }, + insideangle=> + { + default=>0, + desc=>'Non-zero to use angle of final as hue for inside', + }, + insidebase=> + { + default=>0, + desc=>'Base angle for inside colours if insideangle is non-zero', + }, + outsideangle=> + { + default=>0, + desc=>'Non-zero to use angle of final as hue for outside', + }, + outsidebase=> + { + default=>0, + desc=>'Base angle if outsideangle is true', + }, + outsidevalue=> + { + default=>1, + desc=>'Brightness for outside pixels', + }, + outsidevaluestep=> + { + default=>0, + desc=>'Brightness step for each count for outside pixels', + }, + outsidesat=> + { + default=>1, + desc=>'Saturation for outside pixels', + }, + }, + inputs=>[], + }, + julia=> + { + desc=>"Julia set", + type=>'assem', + assem=><<EOS, +# print x +# x treated as in range minx..maxx +# y treated as in range miny..maxy + var nx:n ; var ny:n + var diffx:n ; var diffy:n +# conx/y are x/y adjusted to min..max ranges + var conx:n ; var cony:n + diffx = subtract maxx minx + conx = div x w + conx = mult conx diffx + conx = add conx minx + diffy = subtract maxy miny + cony = div y h + cony = mult cony diffy + cony = add cony miny + nx = conx + ny = cony + var count:n + count = 0 +loop: +# calculate (nx,ny)**2 +(x,y)-> +# (nx*nx-ny*ny+x, 2.nx.ny+y) + var wx:n ; var wy:n ; var work:n + wx = mult nx nx + wy = mult ny ny + wx = subtract wx wy + ny = mult ny nx + ny = mult ny 2 + nx = wx + nx = add nx zx + ny = add ny zy + work = distance nx ny 0 0 + work = gt work 2 + jumpnz work docol + count = add count 1 + work = lt count maxcount + jumpnz work loop + jumpnz insideangle doinang + var workp:p + workp = rgb 0 0 0 + ret workp + doinang: + var ang:n + ang = atan2 ny nx + ang = mult ang 360 + ang = div ang pi + workp = hsv ang 255 0.5 + ret workp + docol: + var outvalue:n + outvalue = mult outsidevaluestep count + outvalue = add outvalue outsidevalue + outvalue = mod outvalue 1.01 + jumpnz outsideangle do_outang + work = mult count huestep + work = add work huebase + work = mod work 360 + workp = hsv work 1 outvalue + ret workp + do_outang: + ang = atan2 ny nx + ang = mult ang 360 + ang = div ang pi + ang = add ang outsidebase + workp = hsv ang outsidesat outvalue + ret workp +EOS + constants=> + { + zx=>{default=>0.7, desc=>'Real part of initial Z', }, + zy=>{default=>0.2, desc=>'Imaginary part of initial Z', }, + minx=>{ default=>-1.5, desc=>'Left of rendered area', }, + miny=>{ default=>-1.5, desc=>'Top of rendered area', }, + maxx=>{ default=>1.5, desc=>'Right of rendered area', }, + maxy=>{ default=>1.5, desc=>'Bottom of rendered area', }, + maxcount=>{ default=>100, desc=>'Maximum iterations', }, + huestep=>{ default=>21.1, desc=>'Hue step for number of iterations', }, + huebase=>{ default=>0, desc=>'Base hue for number of iterations', }, + insideangle=> + { + default=>0, + desc=>'Non-zero to use angle of final as hue for inside', + }, + insidebase=> + { + default=>0, + desc=>'Base angle for inside colours if insideangle is non-zero', + }, + outsideangle=> + { + default=>0, + desc=>'Non-zero to use angle of final as hue for outside', + }, + outsidebase=> + { + default=>0, + desc=>'Base angle if outsideangle is true', + }, + outsidevalue=> + { + default=>1, + desc=>'Brightness for outside pixels', + }, + outsidevaluestep=> + { + default=>0, + desc=>'Brightness step for each count for outside pixels', + }, + outsidesat=> + { + default=>1, + desc=>'Saturation for outside pixels', + }, + }, + inputs=>[], + }, + circleripple=> + { + type=>'rpnexpr', + desc=>'Adds a circular ripple effect', + rpnexpr=><<'EOS', +x y cx cy distance !dist +@dist freq / sin !scale +@scale depth * @dist + !adj +y cy - x cx - atan2 !ang +cx @ang cos @adj * + cy @ang sin @adj * + getp1 @scale shadow + shadow 1 + / * +EOS + constants=> + { + freq=> { desc=>'Frequency of ripples', default=>5 }, + depth=> { desc=>'Depth of ripples', default=>10 }, + shadow=> { desc=>'Fraction of shadow', default=>20 }, + }, + inputs=> + [ + { desc=>'Image to ripple' } + ], + }, + spiral=> + { + type=>'rpnexpr', + desc=>'Render a colorful spiral', + rpnexpr=><<'EOS', +x y cx cy distance !d y cy - x cx - atan2 !a +@d spacing / @a + pi 2 * % !a2 +@a 180 * pi / 1 @a2 sin 1 + 2 / hsv +EOS + constants=> + { + spacing=>{ desc=>'Spacing between arms', default=>10 }, + }, + inputs=>[], + }, + diagripple=> + { + type=>'rpnexpr', + desc=>'Adds diagonal ripples to an image', + rpnexpr=><<'EOS', +x y + !dist @dist freq / sin !scale +@scale depth * !adj + x @adj + y @adj + getp1 @scale shadow + shadow 1 + / * +EOS + constants=> + { + freq=>{ desc=>'Frequency of ripples', default=>5, }, + depth=>{desc=>'Depth of ripples', default=>3,}, + shadow=> + { + desc=>'Fraction of brightness to remove for shadows', + default=>20, + }, + }, + inputs=> + [ + { desc=>'Image to add ripples to' } + ], + }, + twist=> + { + type=>'rpnexpr', + desc=>'Twist an image', + rpnexpr=><<'EOS', +x y cx cy distance !dist + y cy - x cx - atan2 @dist twist / + !ang +cx @ang cos @dist * + cy @ang sin @dist * + getp1 +EOS + constants=> + { + twist=>{ desc=>'Amount of twist', default=>2.5, }, + }, + inputs=> + [ + { desc=>'Image to twist' }, + ], + }, + # any other functions can wait until Imager::Expr::Infix supports + # jumps + ); + +sub new { + my ($class, $name) = @_; + + exists $funcs{$name} or return; + + bless { func=>$funcs{$name}, name=>$name }, $class; +} + +sub inputs { + my ($self) = @_; + return @{$self->{func}{inputs}} +} + +sub constants { + my $self = shift; + if (@_) { + return @{$self->{func}{constants}}{@_}; + } + else { + return keys %{$self->{func}{constants}}; + } +} + +sub transform { + my ($self, $opts, $constants, @in) = @_; + + my $func = $self->{func}; + my %opts = %$opts; + $opts{$func->{type}} = $func->{$func->{type}}; + my %con = %$constants; + for my $name (keys %{$func->{'constants'}}) { + unless (exists $con{$name}) { + if (exists $func->{'constants'}{$name}{default}) { + $con{$name} = $func->{'constants'}{$name}{default}; + } + else { + $self->{error} = "No value or default for constant $name"; + return; + } + } + } + $opts{'constants'} = \%con; + unless (@in == @{$func->{'inputs'}}) { + $self->{error} = @in." input images given, ". + @{$func->{'inputs'}}." supplied"; + return; + } + + my $out = Imager::transform2(\%opts, @in); + unless ($out) { + $self->{error} = $Imager::ERRSTR; + return; + } + return $out; +} + +sub errstr { + return $_[0]{error}; +} + +sub list { + return keys %funcs; +} + +sub describe { + my ($class, $name) = @_; + + my $func; + if (ref $class && !$name) { + $func = $class->{func}; + $name = $class->{name} + } + else { + $func = $funcs{$name} + or return undef; + } + my $desc = <<EOS; +Function : $name +Description: $func->{desc} +EOS + if ($func->{'inputs'} && @{$func->{'inputs'}}) { + $desc .= "Input images:\n"; + my $i = 1; + for my $in (@{$func->{'inputs'}}) { + $desc .= " $i: $in->{desc}\n"; + } + } + else { + $desc .= "There are no input images\n"; + } + if ($func->{'constants'} && keys %{$func->{'constants'}}) { + $desc .= "Input constants:\n"; + for my $key (keys %{$func->{'constants'}}) { + $desc .= " $key: $func->{'constants'}{$key}{desc}\n"; + $desc .= " Default: $func->{'constants'}{$key}{default}\n"; + } + } + else { + $desc .= "There are no constants\n"; + } + + return $desc; +} + + +1; + +__END__ + +=head1 NAME + + Imager::Transform - a library of register machine image transformations + +=head1 SYNOPSIS + + # get a list of transformations + my @funcs = Imager::Transform->list; + # create a transformation object + my $tran = Imager::Transform->new($name); + # describe it + print $tran->describe; + # a list of constant names + my @constants = $tran->constants; + # information about some of the constants + my @info = $tran->constants(@constants); + +=head1 DESCRIPTION + +This module provides a library of transformations that use the Imager +transform2() function. + +The aim is to provide a place to collect these transformations. + +At some point there might be an interface to add new functions, but +there's not a whole lot of point to that. + +The interface is a little sparse as yet. + +=head1 METHODS + +=over 4 + +=item my @names = Imager::Transform->list + +Returns a list of the transformations. + +=item my $desc = Imager::Transform->describe($name); + +=item my $desc = $tran->describe() + +Describes a transformation specified either by name (as a class +method) or by reference (as an instance method). + +The class method returns undef if there is no such transformation. + +=item my $tran = Imager::Transform->new($name) + +Create a new transformation object. Returns undef if there is no such +transformation. + +=item my @inputs = $tran->inputs; + +=item my $inputs = $tran->inputs; + +Returns a list of input image descriptions, or the number of them, +depending on content. + +The list contains hashrefs, which current contain only one member, +desc, a description of the use of the input image. + +=item $tran->constants + +Return's a list of names of constants that can be set for the +transformation. + +=item $tran->constants($name, $name, ...) + +Returns a hashref for each named constant, which contains the default +in key C<default> and a description in key C<desc>. + +=item my $out = $tran->transform(\%opts, \%constants, @imgs) + +Perform the image transformation. + +Returns the new image on success, or undef on failure, in which case +you can use $tran->errstr to get an error message. + +=item $tran->errstr + +The error message, if any from the last image transformation. + +=back + +=head1 BUGS + +Needs more transformations. + +=head1 SEE ALSO + +Imager(3), transform.perl + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Transformations.pod b/Master/tlpkg/tlperl0/lib/Imager/Transformations.pod new file mode 100755 index 00000000000..d0af4263bce --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Transformations.pod @@ -0,0 +1,930 @@ +=head1 NAME + +Imager::Transformations - Simple transformations of one image into another. + +=head1 SYNOPSIS + + use Imager; + + $newimg = $img->copy(); + + $newimg = $img->scale(xpixels=>400, qtype => 'mixing'); + $newimg = $img->scale(xpixels=>400, ypixels=>400); + $newimg = $img->scale(xpixels=>400, ypixels=>400, type=>'min'); + $newimg = $img->scale(scalefactor=>0.25); + + $newimg = $img->scaleX(pixels=>400); + $newimg = $img->scaleX(scalefactor=>0.25); + $newimg = $img->scaleY(pixels=>400); + $newimg = $img->scaleY(scalefactor=>0.25); + + $newimg = $img->crop(left=>50, right=>100, top=>10, bottom=>100); + $newimg = $img->crop(left=>50, top=>10, width=>50, height=>90); + + $dest->paste(left=>40,top=>20,img=>$logo); + + $img->rubthrough(src=>$srcimage,tx=>30, ty=>50); + $img->rubthrough(src=>$srcimage,tx=>30, ty=>50, + src_minx=>20, src_miny=>30, + src_maxx=>20, src_maxy=>30); + + $img->compose(src => $src, tx => 30, ty => 20, combine => 'color'); + $img->compose(src => $src, tx => 30, ty => 20, combine => 'color'); + mask => $mask, opacity => 0.5); + + $img->flip(dir=>"h"); # horizontal flip + $img->flip(dir=>"vh"); # vertical and horizontal flip + $newimg = $img->copy->flip(dir=>"v"); # make a copy and flip it vertically + + my $rot20 = $img->rotate(degrees=>20); + my $rotpi4 = $img->rotate(radians=>3.14159265/4); + + + # Convert image to gray + $new = $img->convert(preset=>'grey'); + + # Swap red/green channel + $new = $img->convert(matrix=>[ [ 0, 1, 0 ], + [ 1, 0, 0 ], + [ 0, 0, 1 ] ]); + + # limit the range of red channel from 0..255 to 0..127 + @map = map { int( $_/2 } 0..255; + $img->map( red=>\@map ); + + # Apply a Gamma of 1.4 + my $gamma = 1.4; + my @map = map { int( 0.5 + 255*($_/255)**$gamma ) } 0..255; + $img->map(all=>\@map); # inplace conversion + +=head1 DESCRIPTION + +The methods described in Imager::Transformations fall into two categories. +Either they take an existing image and modify it in place, or they +return a modified copy. + +Functions that modify inplace are C<flip()>, C<paste()>, +C<rubthrough()> and C<compose()>. If the original is to be left +intact it's possible to make a copy and alter the copy: + + $flipped = $img->copy()->flip(dir=>'h'); + +=head2 Image copying/resizing/cropping/rotating + +A list of the transformations that do not alter the source image follows: + +=over + +=item copy + +To create a copy of an image use the C<copy()> method. This is usefull +if you want to keep an original after doing something that changes the image. + + $newimg = $orig->copy(); + +=item scale + +X<scale>To scale an image so porportions are maintained use the +C<$img-E<gt>scale()> method. if you give either a xpixels or ypixels +parameter they will determine the width or height respectively. If +both are given the one resulting in a larger image is used, unless you +set the C<type> parameter to C<'min'>. example: C<$img> is 700 pixels +wide and 500 pixels tall. + + $newimg = $img->scale(xpixels=>400); # 400x285 + $newimg = $img->scale(ypixels=>400); # 560x400 + + $newimg = $img->scale(xpixels=>400,ypixels=>400); # 560x400 + $newimg = $img->scale(xpixels=>400,ypixels=>400,type=>'min'); # 400x285 + + $newimg = $img->scale(xpixels=>400, ypixels=>400),type=>'nonprop'); # 400x400 + + $newimg = $img->scale(scalefactor=>0.25); 175x125 + $newimg = $img->scale(); # 350x250 + +If you want to create low quality previews of images you can pass +C<qtype=E<gt>'preview'> to scale and it will use nearest neighbor +sampling instead of filtering. It is much faster but also generates +worse looking images - especially if the original has a lot of sharp +variations and the scaled image is by more than 3-5 times smaller than +the original. + +=over + +=item * + +xpixels, ypixels - desired size of the scaled image. The C<type> +parameter controls whether the larger or smaller of the two possible +sizes is chosen, or if the image is scaled non-proportionally. + +=item * + +constrain - an Image::Math::Constrain object defining the way in which +the image size should be constrained. + +=item * + +scalefactor - if none of xpixels, ypixels, xscalefactor, yscalefactor +or constrain is supplied then this is used as the ratio to scale by. +Default: 0.5. + +=item * + +xscalefactor, yscalefactor - if both are supplied then the image is +scaled as per these parameters, whether this is proportionally or not. +New in Imager 0.54. + +=item * + +type - controls whether the larger or smaller of the two possible +sizes is chosen, possible values are: + +=over + +=item * + +min - the smaller of the 2 sizes are chosen. + +=item * + +max - the larger of the 2 sizes. This is the default. + +=item * + +nonprop - non-proportional scaling. New in Imager 0.54. + +=back + +scale() will fail if C<type> is set to some other value. + +For example, if the original image is 400 pixels wide by 200 pixels +high and C<xpixels> is set to 300, and C<ypixels> is set to 160. When +C<type> is C<'min'> the resulting image is 300 x 150, when C<type> is +C<'max'> the resulting image is 320 x 150. + +C<type> is only used if both C<xpixels> and C<ypixels> are supplied. + +=item * + +qtype - defines the quality of scaling performed. Possible values are: + +=over + +=item * + +C<normal> - high quality scaling. This is the default. + +=item * + +C<preview> - lower quality. When scaling down this will skip input +pixels, eg. scaling by 0.5 will skip every other pixel. When scaling +up this will duplicate pixels. + +=item * + +C<mixing> - implements the mixing algorithm implemented by pnmscale. +This retains more detail when scaling down than C<normal>. When +scaling down this proportionally accumulates sample data from the +pixels, resulting in a proportional mix of all of the pixels. When +scaling up this will mix pixels when the sampling grid crosses a pixel +boundary but will otherwise copy pixel values. + +=back + +scale() will fail if C<qtype> is set to some other value. + +C<preview> is faster than C<mixing> which is much faster than C<normal>. + +=back + +To scale an image on a given axis without maintaining proportions, it +is best to call the scaleX() and scaleY() methods with the required +dimensions. eg. + + my $scaled = $img->scaleX(pixels=>400)->scaleY(pixels=>200); + +From Imager 0.54 you can scale without maintaining proportions either +by supplying both the xscalefactor and yscalefactor arguments: + + my $scaled = $img->scale(xscalefactor => 0.5, yscalefactor => 0.67); + +or by supplying C<xpixels> and C<ypixels> and setting C<type> to +"nonprop": + + my $scaled = $im->scale(xpixels => 200, ypixels => 200, type => 'nonprop'); + +Returns a new scaled image on success. The source image is not +modified. + +Returns false on failure, check the errstr() method for the reason for +failure. + +A mandatory warning is produced if scale() is called in void context. + + # setup + my $image = Imager->new; + $image->read(file => 'somefile.jpg') + or die $image->errstr; + + # all full quality unless indicated otherwise + # half the size: + my $half = $image->scale; + + # double the size + my $double = $image->scale(scalefactor => 2.0); + + # so a 400 x 400 box fits in the resulting image: + my $fit400x400inside = $image->scale(xpixels => 400, ypixels => 400); + my $fit400x400inside2 = $image->scale(xpixels => 400, ypixels => 400, + type=>'max'); + + # fit inside a 400 x 400 box + my $inside400x400 = $image->scale(xpixels => 400, ypixels => 400, + type=>'min'); + + # make it 400 pixels wide or high + my $width400 = $image->scale(xpixels => 400); + my $height400 = $image->scale(ypixels => 400); + + # low quality scales: + # to half size + my $low = $image->scale(qtype => 'preview'); + + # mixing method scale + my $mixed = $image->scale(qtype => 'mixing', scalefactor => 0.1); + + # using an Image::Math::Constrain object + use Image::Math::Constrain; + my $constrain = Image::Math::Constrain->new(800, 600); + my $scaled = $image->scale(constrain => $constrain); + + # same as Image::Math::Constrain version + my $scaled2 = $image->scale(xpixels => 800, ypixels => 600, type => 'min'); + +=item scaleX + +scaleX() will scale along the X dimension, return a new image with the +new width: + + my $newimg = $img->scaleX(pixels=>400); # 400x500 + $newimg = $img->scaleX(scalefactor=>0.25) # 175x500 + +=over + +=item * + +scalefactor - the amount to scale the X axis. Ignored if C<pixels> is +provided. Default: 0.5. + +=item * + +pixels - the new width of the image. + +=back + +Returns a new scaled image on success. The source image is not +modified. + +Returns false on failure, check the errstr() method for the reason for +failure. + +A mandatory warning is produced if scaleX() is called in void context. + +=item scaleY + +scaleY() will scale along the Y dimension, return a new image with the +new height: + + $newimg = $img->scaleY(pixels=>400); # 700x400 + $newimg = $img->scaleY(scalefactor=>0.25) # 700x125 + +=over + +=item * + +scalefactor - the amount to scale the Y axis. Ignored if C<pixels> is +provided. Default: 0.5. + +=item * + +pixels - the new height of the image. + +=back + +Returns a new scaled image on success. The source image is not +modified. + +Returns false on failure, check the errstr() method for the reason for +failure. + +A mandatory warning is produced if scaleY() is called in void context. + +=item scale_calculate + +Performs the same calculations that the scale() method does to +calculate the scaling factors from the parameters you pass. + +scale_calculate() can be called as an object method, or as a class +method. + +Takes the following parameters over scale(): + +=over + +=item * + +width, height - the image width and height to base the scaling on. +Required if scale_calculate() is called as a class method. If called +as an object method these default to the image width and height +respectively. + +=back + +You might use scale_calculate() as a class method when generating an +IMG tag, for example. + +Returns an empty list on failure. + +Returns a list containing horizontal scale factor, vertical scale +factor, new width, new height, on success. + + my ($x_scale, $y_scale, $new_width, $new_height) = + Imager->scale_calculate(width => 1024, height => 768, + ypixels => 180, type => 'min'); + + my ($x_scale, $y_scale, $new_width, $new_height) = + $img->scale_calculate(xpixels => 200, type => 'min'); + +=item crop + +Another way to resize an image is to crop it. The parameters to +crop are the edges of the area that you want in the returned image, +where the right and bottom edges are non-inclusive. If a parameter is +omitted a default is used instead. + +crop() returns the cropped image and does not modify the source image. + +The possible parameters are: + +=over + +=item * + +C<left> - the left edge of the area to be cropped. Default: 0 + +=item * + +C<top> - the top edge of the area to be cropped. Default: 0 + +=item * + +C<right> - the right edge of the area to be cropped. Default: right +edge of image. + +=item * + +C<bottom> - the bottom edge of the area to be cropped. Default: +bottom edge of image. + +=item * + +C<width> - width of the crop area. Ignored if both C<left> and C<right> are +supplied. Centered on the image if neither C<left> nor C<right> are +supplied. + +=item * + +C<height> - height of the crop area. Ignored if both C<top> and +C<bottom> are supplied. Centered on the image if neither C<top> nor +C<bottom> are supplied. + +=back + +For example: + + # these produce the same image + $newimg = $img->crop(left=>50, right=>100, top=>10, bottom=>100); + $newimg = $img->crop(left=>50, top=>10, width=>50, height=>90); + $newimg = $img->crop(right=>100, bottom=>100, width=>50, height=>90); + + # and the following produce the same image + $newimg = $img->crop(left=>50, right=>100); + $newimg = $img->crop(left=>50, right=>100, top=>0, + bottom=>$img->getheight); + + # grab the top left corner of the image + $newimg = $img->crop(right=>50, bottom=>50); + +You can also specify width and height parameters which will produce a +new image cropped from the center of the input image, with the given +width and height. + + $newimg = $img->crop(width=>50, height=>50); + +If you supply C<left>, C<width> and C<right> values, the C<right> +value will be ignored. If you supply C<top>, C<height> and C<bottom> +values, the C<bottom> value will be ignored. + +The edges of the cropped area default to the edges of the source +image, for example: + + # a vertical bar from the middle from top to bottom + $newimg = $img->crop(width=>50); + + # the right half + $newimg = $img->crop(left=>$img->getwidth() / 2); + +If the resulting image would have zero width or height then crop() +returns false and $img->errstr is an appropriate error message. + +A mandatory warning is produced if crop() is called in void context. + +=item rotate + +Use the rotate() method to rotate an image. This method will return a +new, rotated image. + +To rotate by an exact amount in degrees or radians, use the 'degrees' +or 'radians' parameter: + + my $rot20 = $img->rotate(degrees=>20); + my $rotpi4 = $img->rotate(radians=>3.14159265/4); + +Exact image rotation uses the same underlying transformation engine as +the matrix_transform() method (see Imager::Engines). + +You can also supply a C<back> argument which acts as a background +color for the areas of the image with no samples available (outside +the rectangle of the source image.) This can be either an +Imager::Color or Imager::Color::Float object. This is B<not> mixed +transparent pixels in the middle of the source image, it is B<only> +used for pixels where there is no corresponding pixel in the source +image. + +To rotate in steps of 90 degrees, use the 'right' parameter: + + my $rotated = $img->rotate(right=>270); + +Rotations are clockwise for positive values. + +Parameters: + +=over + +=item * + +right - rotate by an exact multiple of 90 degrees, specified in +degreess. + +=item * + +radians - rotate by an angle specified in radians. + +=item * + +degrees - rotate by an angle specified in degrees. + +=item * + +back - for C<radians> and C<degrees> this is the color used for the +areas not covered by the original image. For example, the corners of +an image rotated by 45 degrees. + +This can be either an Imager::Color object, an Imager::Color::Float +object or any parameter that Imager can convert to a color object, see +L<Imager::Draw/Color Parameters> for details. + +This is B<not> mixed transparent pixels in the middle of the source +image, it is B<only> used for pixels where there is no corresponding +pixel in the source image. + +Default: transparent black. + +=back + + # rotate 45 degrees clockwise, + my $rotated = $img->rotate(degrees => 45); + + # rotate 10 degrees counter-clockwise + # set pixels not sourced from the original to red + my $rotated = $img->rotate(degrees => -10, back => 'red'); + +=back + +=head2 Image pasting/flipping + +A list of the transformations that alter the source image follows: + +=over + +=item paste + +X<paste>To copy an image to onto another image use the C<paste()> +method. + + $dest->paste(left=>40, top=>20, src=>$logo); + +That copies the entire C<$logo> image onto the C<$dest> image so that the +upper left corner of the C<$logo> image is at (40,20). + +Parameters: + +=over + +=item * + +src, img - the source image. I<src> added for compatibility with +rubthrough(). + +=item * + +left, top - position in output of the top left of the pasted image. +Default: (0,0) + +=item * + +src_minx, src_miny - the top left corner in the source image to start +the paste from. Default: (0, 0) + +=item * + +src_maxx, src_maxy - the bottom right in the source image of the sub +image to paste. This position is B<non> inclusive. Default: bottom +right corner of the source image. + +=item * + +width, height - if the corresponding src_maxx or src_maxy is not +defined then width or height is used for the width or height of the +sub image to be pasted. + +=back + + # copy the 20x20 pixel image from (20,20) in $src_image to (10,10) in $img + $img->paste(src=>$src_image, + left => 10, top => 10, + src_minx => 20, src_miny => 20, + src_maxx => 40, src_maxx => 40); + +If the source image has an alpha channel and the target doesn't, then +the source is treated as if composed onto a black background. + +If the source image is color and the target is grayscale, the the +source is treated as if run through C<< convert(preset=>'gray') >>. + +=item rubthrough + +A more complicated way of blending images is where one image is +put 'over' the other with a certain amount of opaqueness. The +method that does this is rubthrough. + + $img->rubthrough(src=>$overlay, + tx=>30, ty=>50, + src_minx=>20, src_miny=>30, + src_maxx=>20, src_maxy=>30); + +That will take the sub image defined by I<$overlay> and +I<[src_minx,src_maxx)[src_miny,src_maxy)> and overlay it on top of +I<$img> with the upper left corner at (30,50). You can rub 2 or 4 +channel images onto a 3 channel image, or a 2 channel image onto a 1 +channel image. The last channel is used as an alpha channel. To add +an alpha channel to an image see I<convert()>. + +Parameters: + +=over + +=item * + +tx, ty - location in the the target image ($self) to render the top +left corner of the source. + +=item * + +src_minx, src_miny - the top left corner in the source to transfer to +the target image. Default: (0, 0). + +=item * + +src_maxx, src_maxy - the bottom right in the source image of the sub +image to overlay. This position is B<non> inclusive. Default: bottom +right corner of the source image. + +=back + + # overlay all of $source onto $targ + $targ->rubthrough(tx => 20, ty => 25, src => $source); + + # overlay the top left corner of $source onto $targ + $targ->rubthrough(tx => 20, ty => 25, src => $source, + src_maxx => 20, src_maxy => 20); + + # overlay the bottom right corner of $source onto $targ + $targ->rubthrough(tx => 20, ty => 30, src => $src, + src_minx => $src->getwidth() - 20, + src_miny => $src->getheight() - 20); + +rubthrough() returns true on success. On failure check +$target->errstr for the reason for failure. + +=item compose + +Draws the source image over the target image, with the src alpha +channel modified by the optional mask and the opacity. + + $img->compose(src=>$overlay, + tx=>30, ty=>50, + src_minx=>20, src_miny=>30, + src_maxx=>20, src_maxy=>30, + mask => $mask, opacity => 0.5); + +That will take the sub image defined by I<$overlay> and +I<[src_minx,src_maxx)[src_miny,src_maxy)> and overlay it on top of +I<$img> with the upper left corner at (30,50). You can rub 2 or 4 +channel images onto a 3 channel image, or a 2 channel image onto a 1 +channel image. + +Parameters: + +=over + +=item * + +src - the source image to draw onto the target. Required. + +=item * + +tx, ty - location in the the target image ($self) to render the top +left corner of the source. These can also be supplied as C<left> and +C<right>. Default: (0, 0). + +=item * + +src_minx, src_miny - the top left corner in the source to transfer to +the target image. Default: (0, 0). + +=item * + +src_maxx, src_maxy - the bottom right in the source image of the sub +image to overlay. This position is B<non> inclusive. Default: bottom +right corner of the source image. + +=item * + +mask - a mask image. The first channel of this image is used to +modify the alpha channel of the source image. This can me used to +mask out portions of the source image. Where the first channel is +zero none of the source image will be used, where the first channel is +max the full alpha of the source image will be used, as further +modified by the opacity. + +=item * + +opacity - further modifies the alpha channel of the source image, in +the range 0.0 to 1.0. Default: 1.0. + +=item * + +combine - the method to combine the source pixels with the target. +See the combine option documentation in Imager::Fill. Default: +normal. + +=back + +Calling compose() with no mask, combine set to C<normal>, opacity set +to C<1.0> is equivalent to calling rubthrough(). + +compose() is intended to be produce similar effects to layers in +interactive paint software. + + # overlay all of $source onto $targ + $targ->compose(tx => 20, ty => 25, src => $source); + + # overlay the top left corner of $source onto $targ + $targ->compose(tx => 20, ty => 25, src => $source, + src_maxx => 20, src_maxy => 20); + + # overlay the bottom right corner of $source onto $targ + $targ->compose(tx => 20, ty => 30, src => $src, + src_minx => $src->getwidth() - 20, + src_miny => $src->getheight() - 20); + +compose() returns true on success. On failure check $target->errstr +for the reason for failure. + +=item flip + +An inplace horizontal or vertical flip is possible by calling the +C<flip()> method. If the original is to be preserved it's possible to +make a copy first. The only parameter it takes is the C<dir> +parameter which can take the values C<h>, C<v>, C<vh> and C<hv>. + + $img->flip(dir=>"h"); # horizontal flip + $img->flip(dir=>"vh"); # vertical and horizontal flip + $nimg = $img->copy->flip(dir=>"v"); # make a copy and flip it vertically + +flip() returns true on success. On failure check $img->errstr for the +reason for failure. + +=back + +=head2 Color transformations + +=over + +=item convert + +You can use the convert method to transform the color space of an +image using a matrix. For ease of use some presets are provided. + +The convert method can be used to: + +=over + +=item * + +convert an RGB or RGBA image to grayscale. + +=item * + +convert a grayscale image to RGB. + +=item * + +extract a single channel from an image. + +=item * + +set a given channel to a particular value (or from another channel) + +=back + +The currently defined presets are: + +=over + +=item gray + +=item grey + +converts an RGBA image into a grayscale image with alpha channel, or +an RGB image into a grayscale image without an alpha channel. + +This weights the RGB channels at 22.2%, 70.7% and 7.1% respectively. + +=item noalpha + +removes the alpha channel from a 2 or 4 channel image. An identity +for other images. + +=item red + +=item channel0 + +extracts the first channel of the image into a single channel image + +=item green + +=item channel1 + +extracts the second channel of the image into a single channel image + +=item blue + +=item channel2 + +extracts the third channel of the image into a single channel image + +=item alpha + +extracts the alpha channel of the image into a single channel image. + +If the image has 1 or 3 channels (assumed to be grayscale of RGB) then +the resulting image will be all white. + +=item rgb + +converts a grayscale image to RGB, preserving the alpha channel if any + +=item addalpha + +adds an alpha channel to a grayscale or RGB image. Preserves an +existing alpha channel for a 2 or 4 channel image. + +=back + +For example, to convert an RGB image into a greyscale image: + + $new = $img->convert(preset=>'grey'); # or gray + +or to convert a grayscale image to an RGB image: + + $new = $img->convert(preset=>'rgb'); + +The presets aren't necessary simple constants in the code, some are +generated based on the number of channels in the input image. + +If you want to perform some other colour transformation, you can use +the 'matrix' parameter. + +For each output pixel the following matrix multiplication is done: + + | channel[0] | | $c00, ..., $c0k | | inchannel[0] | + | ... | = | ... | x | ... | + | channel[k] | | $ck0, ..., $ckk | | inchannel[k] | + 1 +Where C<k = $img-E<gt>getchannels()-1>. + +So if you want to swap the red and green channels on a 3 channel image: + + $new = $img->convert(matrix=>[ [ 0, 1, 0 ], + [ 1, 0, 0 ], + [ 0, 0, 1 ] ]); + +or to convert a 3 channel image to greyscale using equal weightings: + + $new = $img->convert(matrix=>[ [ 0.333, 0.333, 0.334 ] ]) + +Convert a 2 channel image (grayscale with alpha) to an RGBA image with +the grey converted to the specified RGB color: + + # set (RGB) scaled on the grey scale portion and copy the alpha + # channel as is + my $colored = $gray->convert(matrix=>[ [ ($red/255), 0 ], + [ ($green/255), 0 ], + [ ($blue/255), 0 ], + [ 0, 1 ], + ]); + +To convert a 3 channel image to a 4 channel image with a 50 percent +alpha channel: + + my $withalpha = $rgb->convert(matrix =>[ [ 1, 0, 0, 0 ], + [ 0, 1, 0, 0 ], + [ 0, 0, 1, 0 ], + [ 0, 0, 0, 0.5 ], + ]); + +=back + +=head2 Color Mappings + +=over + +=item map + +You can use the map method to map the values of each channel of an +image independently using a list of lookup tables. It's important to +realize that the modification is made inplace. The function simply +returns the input image again or undef on failure. + +Each channel is mapped independently through a lookup table with 256 +entries. The elements in the table should not be less than 0 and not +greater than 255. If they are out of the 0..255 range they are +clamped to the range. If a table does not contain 256 entries it is +silently ignored. + +Single channels can mapped by specifying their name and the mapping +table. The channel names are C<red>, C<green>, C<blue>, C<alpha>. + + @map = map { int( $_/2 } 0..255; + $img->map( red=>\@map ); + +It is also possible to specify a single map that is applied to all +channels, alpha channel included. For example this applies a gamma +correction with a gamma of 1.4 to the input image. + + $gamma = 1.4; + @map = map { int( 0.5 + 255*($_/255)**$gamma ) } 0..255; + $img->map(all=> \@map); + +The C<all> map is used as a default channel, if no other map is +specified for a channel then the C<all> map is used instead. If we +had not wanted to apply gamma to the alpha channel we would have used: + + $img->map(all=> \@map, alpha=>[]); + +Since C<[]> contains fewer than 256 element the gamma channel is +unaffected. + +It is also possible to simply specify an array of maps that are +applied to the images in the rgba order. For example to apply +maps to the C<red> and C<blue> channels one would use: + + $img->map(maps=>[\@redmap, [], \@bluemap]); + +=back + +=head1 SEE ALSO + +L<Imager>, L<Imager::Engines> + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org>, Arnar M. Hrafnkelsson + +=head1 REVISION + +$Revision: 1667 $ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/Tutorial.pod b/Master/tlpkg/tlperl0/lib/Imager/Tutorial.pod new file mode 100755 index 00000000000..a26d8d9bdc0 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/Tutorial.pod @@ -0,0 +1,180 @@ +=head1 NAME + +Imager::Tutorial - an introduction to Imager. + +=head1 DESCRIPTION + +=head2 Before you start + +If you have the necessary knowledge, install the image format +libraries you want Imager image file support for, and Imager itself, +otherwise arrange to have it done. + +You will also want some sort of image viewer tool, whether an image +editor like Photoshop or the GIMP, or a web browser. + +=head2 Hello Boxes! - A Simple Start + +As with any perl program it's useful to start with a #! line, and to +enable strict mode: + + #!/usr/bin/perl -w + # you might to 'use warnings;' instead of the -w above + use strict; + +These lines will be omitted in further examples. + +As with any module, you need to load it: + + use Imager; + +Now create a image to draw on: + + my $image = Imager->new(xsize => 100, ysize => 100); + +and draw a couple of filled rectangles on it: + + $image->box(xmin => 0, ymin => 0, xmax => 99, ymax => 99, + filled => 1, color => 'blue'); + $image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79, + filled => 1, color => 'green'); + +Since the first box fills the whole image, it can be simplified to: + + $image->box(filled => 1, color => 'blue'); + +and save it to a file: + + $image->write(file=>'tutorial1.ppm') + or die 'Cannot save tutorial1.ppm: ', $image->errstr; + +So our completed program is: + + use Imager; + + my $image = Imager->new(xsize => 100, ysize => 100); + + $image->box(filled => 1, color => 'blue'); + $image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79, + filled => 1, color => 'green'); + + $image->write(file=>'tutorial1.ppm') + or die 'Cannot save tutorial1.ppm: ', $image->errstr; + +=head2 Adding some text + +The first thing you need to draw text is a font object: + + # use a different file, depending on the font support you have in + # your installed Imager. + my $font_filename = 'fontfiles/ImUgly.ttf'; + my $font = Imager::Font->new(file=>$font_filename) + or die "Cannot load $font_filename: ", Imager->errstr; + +If you're on Windows, you can supply a face name instead: + + my $font = Imager::Font->new(face=>'Arial Bold') + or die "Cannot load 'Arial Bold: ", Imager->errstr; + +and draw the text: + + my $text = "Hello Boxes!"; + my $text_size = 12; + + $font->align(string => $text, + size => $text_size, + color => 'red', + x => $image->getwidth/2, + y => $image->getheight/2, + halign => 'center', + valign => 'center', + image => $image); + +So inserting this into our existing code we have: + + use Imager; + + my $image = Imager->new(xsize => 100, ysize => 100); + + $image->box(xmin => 0, ymin => 0, xmax => 99, ymax => 99, + filled => 1, color => 'blue'); + $image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79, + filled => 1, color => 'green'); + + # use a different file, depending on the font support you have in + # your installed Imager. + my $font_filename = 'fontfiles/ImUgly.ttf'; + my $font = Imager::Font->new(file=>$font_filename) + or die "Cannot load $font_filename: ", Imager->errstr; + + my $text = "Hello Boxes!"; + my $text_size = 12; + + $font->align(string => $text, + size => $text_size, + color => 'red', + x => $image->getwidth/2, + y => $image->getheight/2, + halign => 'center', + valign => 'center', + image => $image); + + $image->write(file=>'tutorial2.ppm') + or die 'Cannot save tutorial2.ppm: ', $image->errstr; + +=head2 Using an existing image as a base + +To load an image from a file, first create an empty image object: + + my $read_image = Imager->new; + +then call the read method: + + my $image_source = shift; # from the command-line + $read_image->read(file=>$image_source) + or die "Cannot load $image_source: ", $image->errstr; + +To keep to our working size, we'll scale the image: + + # the scale() method always does a proportional scale, we don't want + # that here + my $scaled_image = $read_image->scaleX(pixels=>100)->scaleY(pixels=>100); + +draw our inner box on that, and save the result: + + $scaled_image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79, + filled => 1, color => 'green'); + + $scaled_image->write(file=>'tutorial3.ppm') + or die 'Cannot save tutorial3.ppm: ', $image->errstr; + +so the complete program is: + + use Imager; + + my $read_image = Imager->new; + + my $image_source = shift; # from the command-line + $read_image->read(file=>$image_source) + or die "Cannot load $image_source: ", $image->errstr; + + # the scale() method always does a proportional scale, we don't want + # that here + my $scaled_image = $read_image->scaleX(pixels=>100)->scaleY(pixels=>100); + + $scaled_image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79, + filled => 1, color => 'green'); + + $scaled_image->write(file=>'tutorial3.ppm') + or die 'Cannot save tutorial3.ppm: ', $image->errstr; + + +=head1 AUTHOR + +Tony Cook <tony@imager.perl.org> + +=head1 REVISION + +$Revision: 811 $ + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/draw.h b/Master/tlpkg/tlperl0/lib/Imager/include/draw.h new file mode 100755 index 00000000000..3453de302b6 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/draw.h @@ -0,0 +1,21 @@ +#include "imager.h" + +typedef struct { + int min,max; +} minmax; + +typedef struct { + minmax *data; + int lines; +} i_mmarray; + +/* FIXME: Merge this into datatypes.{c,h} */ + +void i_mmarray_cr(i_mmarray *ar,int l); +void i_mmarray_dst(i_mmarray *ar); +void i_mmarray_add(i_mmarray *ar,int x,int y); +int i_mmarray_gmin(i_mmarray *ar,int y); +int i_mmarray_getm(i_mmarray *ar,int y); +void i_mmarray_render(i_img *im,i_mmarray *ar,i_color *val); +void i_mmarray_info(i_mmarray *ar); + diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/dynaload.h b/Master/tlpkg/tlperl0/lib/Imager/include/dynaload.h new file mode 100755 index 00000000000..75f55cef434 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/dynaload.h @@ -0,0 +1,58 @@ +#ifndef _DYNALOAD_H_ +#define _DYNALOAD_H_ + +#include "log.h" + +#include "EXTERN.h" +#include "perl.h" +#include "ppport.h" + +#include "ext.h" + +typedef struct DSO_handle_tag DSO_handle; + +typedef struct { + HV* hv; + char *key; + void *store; +} UTIL_args; + +#if 0 +int getobj(void *hv_t,char *key,char *type,void **store); +int getint(void *hv_t,char *key,int *store); +int getdouble(void *hv_t,char *key,double *store); +int getvoid(void *hv_t,char *key,void **store); +#endif + +void *DSO_open(char* file,char** evalstring); +func_ptr *DSO_funclist(DSO_handle *handle); +int DSO_close(void *); +void DSO_call(DSO_handle *handle,int func_index,HV* hv); + +#ifdef __EMX__ /* OS/2 */ +# ifndef RTLD_LAZY +# define RTLD_LAZY 0 +# endif /* RTLD_LAZY */ +int dlclose(minthandle_t); +#endif /* __EMX__ */ + +#ifdef DLSYMUN + +#define I_EVALSTR "_evalstr" +#define I_SYMBOL_TABLE "_symbol_table" +#define I_UTIL_TABLE "_util_table" +#define I_FUNCTION_LIST "_function_list" +#define I_INSTALL_TABLES "_install_tables" + +#else + +#define I_EVALSTR "evalstr" +#define I_SYMBOL_TABLE "symbol_table" +#define I_UTIL_TABLE "util_table" +#define I_FUNCTION_LIST "function_list" +#define I_INSTALL_TABLES "install_tables" + +#endif + +#endif /* _DYNALOAD_H_ */ + diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/ext.h b/Master/tlpkg/tlperl0/lib/Imager/include/ext.h new file mode 100755 index 00000000000..dd1cfbd8f0e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/ext.h @@ -0,0 +1,23 @@ +#include "imager.h" + +#ifndef IMAGER_EXT_H +#define IMAGER_EXT_H + +/* structures for passing data between Imager-plugin and the Imager-module */ + +typedef struct { + char *name; + void (*iptr)(void* ptr); + char *pcode; +} func_ptr; + + +typedef struct { + int (*getstr)(void *hv_t,char* key,char **store); + int (*getint)(void *hv_t,char *key,int *store); + int (*getdouble)(void *hv_t,char* key,double *store); + int (*getvoid)(void *hv_t,char* key,void **store); + int (*getobj)(void *hv_t,char* key,char* type,void **store); +} UTIL_table_t; + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/feat.h b/Master/tlpkg/tlperl0/lib/Imager/include/feat.h new file mode 100755 index 00000000000..25fac9e320d --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/feat.h @@ -0,0 +1,34 @@ +#include "imager.h" + +static char *i_format_list[]={ +#ifdef HAVE_LIBJPEG + "jpeg", +#endif +#ifdef HAVE_LIBTIFF + "tiff", +#endif +#ifdef HAVE_LIBPNG + "png", +#endif +#ifdef HAVE_LIBGIF + "gif", +#endif +#ifdef HAVE_LIBT1 + "t1", +#endif +#ifdef HAVE_LIBTT + "tt", +#endif +#ifdef HAVE_WIN32 + "w32", +#endif +#ifdef HAVE_FT2 + "ft2", +#endif + "raw", + "pnm", + "bmp", + "tga", + "ifs", + NULL}; + diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imager.h b/Master/tlpkg/tlperl0/lib/Imager/include/imager.h new file mode 100755 index 00000000000..e44311cc2c5 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imager.h @@ -0,0 +1,612 @@ +#ifndef _IMAGE_H_ +#define _IMAGE_H_ + +#include "imconfig.h" +#include "imio.h" +#include "iolayer.h" +#include "log.h" +#include "stackmach.h" + + +#ifndef _MSC_VER +#include <unistd.h> +#endif +#include <string.h> +#include <stdio.h> +#include <math.h> +#include <stdlib.h> + +#ifdef SUNOS +#include <strings.h> +#endif + +#ifndef PI +#define PI 3.14159265358979323846 +#endif + +#ifndef MAXINT +#define MAXINT 2147483647 +#endif + +#include "imdatatypes.h" + +undef_int i_has_format(char *frmt); + +/* constructors and destructors */ + +i_color *ICL_new_internal( unsigned char r,unsigned char g,unsigned char b,unsigned char a); +i_color *ICL_set_internal(i_color *cl,unsigned char r,unsigned char g,unsigned char b,unsigned char a); +void ICL_info (const i_color *cl); +void ICL_DESTROY (i_color *cl); +void ICL_add (i_color *dst, i_color *src, int ch); + +extern i_fcolor *i_fcolor_new(double r, double g, double b, double a); +extern void i_fcolor_destroy(i_fcolor *cl); + +extern void i_rgb_to_hsvf(i_fcolor *color); +extern void i_hsv_to_rgbf(i_fcolor *color); +extern void i_rgb_to_hsv(i_color *color); +extern void i_hsv_to_rgb(i_color *color); + +i_img *IIM_new(int x,int y,int ch); +#define i_img_8_new IIM_new +void IIM_DESTROY(i_img *im); +i_img *i_img_new( void ); +i_img *i_img_empty(i_img *im,int x,int y); +i_img *i_img_empty_ch(i_img *im,int x,int y,int ch); +void i_img_exorcise(i_img *im); +void i_img_destroy(i_img *im); +i_img *i_img_alloc(void); +void i_img_init(i_img *im); + +void i_img_info(i_img *im,int *info); + +extern i_img *i_sametype(i_img *im, int xsize, int ysize); +extern i_img *i_sametype_chans(i_img *im, int xsize, int ysize, int channels); + +i_img *i_img_pal_new(int x, int y, int ch, int maxpal); + +/* Image feature settings */ + +void i_img_setmask (i_img *im,int ch_mask); +int i_img_getmask (i_img *im); +int i_img_getchannels(i_img *im); +i_img_dim i_img_get_width(i_img *im); +i_img_dim i_img_get_height(i_img *im); + +/* Base functions */ + +extern int i_ppix(i_img *im,int x,int y, const i_color *val); +extern int i_gpix(i_img *im,int x,int y,i_color *val); +extern int i_ppixf(i_img *im,int x,int y, const i_fcolor *val); +extern int i_gpixf(i_img *im,int x,int y,i_fcolor *val); + +#define i_ppix(im, x, y, val) (((im)->i_f_ppix)((im), (x), (y), (val))) +#define i_gpix(im, x, y, val) (((im)->i_f_gpix)((im), (x), (y), (val))) +#define i_ppixf(im, x, y, val) (((im)->i_f_ppixf)((im), (x), (y), (val))) +#define i_gpixf(im, x, y, val) (((im)->i_f_gpixf)((im), (x), (y), (val))) + +extern int i_plin(i_img *im, int l, int r, int y, const i_color *vals); +extern int i_glin(i_img *im, int l, int r, int y, i_color *vals); +extern int i_plinf(i_img *im, int l, int r, int y, const i_fcolor *vals); +extern int i_glinf(i_img *im, int l, int r, int y, i_fcolor *vals); +extern int i_gsamp(i_img *im, int l, int r, int y, i_sample_t *samp, + const int *chans, int chan_count); +extern int i_gsampf(i_img *im, int l, int r, int y, i_fsample_t *samp, + const int *chans, int chan_count); +extern int i_gpal(i_img *im, int x, int r, int y, i_palidx *vals); +extern int i_ppal(i_img *im, int x, int r, int y, const i_palidx *vals); +extern int i_addcolors(i_img *im, const i_color *colors, int count); +extern int i_getcolors(i_img *im, int i, i_color *, int count); +extern int i_colorcount(i_img *im); +extern int i_maxcolors(i_img *im); +extern int i_findcolor(i_img *im, const i_color *color, i_palidx *entry); +extern int i_setcolors(i_img *im, int index, const i_color *colors, + int count); + +#define i_plin(im, l, r, y, val) (((im)->i_f_plin)(im, l, r, y, val)) +#define i_glin(im, l, r, y, val) (((im)->i_f_glin)(im, l, r, y, val)) +#define i_plinf(im, l, r, y, val) (((im)->i_f_plinf)(im, l, r, y, val)) +#define i_glinf(im, l, r, y, val) (((im)->i_f_glinf)(im, l, r, y, val)) + +#define i_gsamp(im, l, r, y, samps, chans, count) \ + (((im)->i_f_gsamp)((im), (l), (r), (y), (samps), (chans), (count))) +#define i_gsampf(im, l, r, y, samps, chans, count) \ + (((im)->i_f_gsampf)((im), (l), (r), (y), (samps), (chans), (count))) + +#define i_gsamp_bits(im, l, r, y, samps, chans, count, bits) \ + (((im)->i_f_gsamp_bits) ? ((im)->i_f_gsamp_bits)((im), (l), (r), (y), (samps), (chans), (count), (bits)) : -1) +#define i_psamp_bits(im, l, r, y, samps, chans, count, bits) \ + (((im)->i_f_psamp_bits) ? ((im)->i_f_psamp_bits)((im), (l), (r), (y), (samps), (chans), (count), (bits)) : -1) + +#define i_findcolor(im, color, entry) \ + (((im)->i_f_findcolor) ? ((im)->i_f_findcolor)((im), (color), (entry)) : 0) + +#define i_gpal(im, l, r, y, vals) \ + (((im)->i_f_gpal) ? ((im)->i_f_gpal)((im), (l), (r), (y), (vals)) : 0) +#define i_ppal(im, l, r, y, vals) \ + (((im)->i_f_ppal) ? ((im)->i_f_ppal)((im), (l), (r), (y), (vals)) : 0) +#define i_addcolors(im, colors, count) \ + (((im)->i_f_addcolors) ? ((im)->i_f_addcolors)((im), (colors), (count)) : -1) +#define i_getcolors(im, index, color, count) \ + (((im)->i_f_getcolors) ? \ + ((im)->i_f_getcolors)((im), (index), (color), (count)) : 0) +#define i_setcolors(im, index, color, count) \ + (((im)->i_f_setcolors) ? \ + ((im)->i_f_setcolors)((im), (index), (color), (count)) : 0) +#define i_colorcount(im) \ + (((im)->i_f_colorcount) ? ((im)->i_f_colorcount)(im) : -1) +#define i_maxcolors(im) \ + (((im)->i_f_maxcolors) ? ((im)->i_f_maxcolors)(im) : -1) +#define i_findcolor(im, color, entry) \ + (((im)->i_f_findcolor) ? ((im)->i_f_findcolor)((im), (color), (entry)) : 0) + +#define i_img_virtual(im) ((im)->virtual) +#define i_img_type(im) ((im)->type) +#define i_img_bits(im) ((im)->bits) + +extern i_fill_t *i_new_fill_solidf(const i_fcolor *c, int combine); +extern i_fill_t *i_new_fill_solid(const i_color *c, int combine); +extern i_fill_t * +i_new_fill_hatch(const i_color *fg, const i_color *bg, int combine, int hatch, + const unsigned char *cust_hatch, int dx, int dy); +extern i_fill_t * +i_new_fill_hatchf(const i_fcolor *fg, const i_fcolor *bg, int combine, int hatch, + const unsigned char *cust_hatch, int dx, int dy); +extern i_fill_t * +i_new_fill_image(i_img *im, const double *matrix, int xoff, int yoff, int combine); +extern i_fill_t *i_new_fill_opacity(i_fill_t *, double alpha_mult); +extern void i_fill_destroy(i_fill_t *fill); + +float i_gpix_pch(i_img *im,int x,int y,int ch); + +/* functions for drawing primitives */ + +void i_box (i_img *im,int x1,int y1,int x2,int y2,const i_color *val); +void i_box_filled (i_img *im,int x1,int y1,int x2,int y2,const i_color *val); +void i_box_cfill(i_img *im, int x1, int y1, int x2, int y2, i_fill_t *fill); +void i_line (i_img *im,int x1,int y1,int x2,int y2,const i_color *val, int endp); +void i_line_aa (i_img *im,int x1,int y1,int x2,int y2,const i_color *val, int endp); +void i_arc (i_img *im,int x,int y,float rad,float d1,float d2,const i_color *val); +void i_arc_aa (i_img *im, double x, double y, double rad, double d1, double d2, const i_color *val); +void i_arc_cfill(i_img *im,int x,int y,float rad,float d1,float d2,i_fill_t *fill); +void i_arc_aa_cfill(i_img *im,double x,double y,double rad,double d1,double d2,i_fill_t *fill); +void i_circle_aa (i_img *im,float x, float y,float rad,const i_color *val); +void i_copyto (i_img *im,i_img *src,int x1,int y1,int x2,int y2,int tx,int ty); +void i_copyto_trans(i_img *im,i_img *src,int x1,int y1,int x2,int y2,int tx,int ty,const i_color *trans); +i_img* i_copy (i_img *src); +int i_rubthru (i_img *im, i_img *src, int tx, int ty, int src_minx, int src_miny, int src_maxx, int src_maxy); +extern int +i_compose_mask(i_img *out, i_img *src, i_img *mask, + int out_left, int out_top, int src_left, int src_top, + int mask_left, int mask_top, int width, int height, + int combine, double opacity); +extern int +i_compose(i_img *out, i_img *src, + int out_left, int out_top, int src_left, int src_top, + int width, int height, int combine, double opacity); + +undef_int i_flipxy (i_img *im, int direction); +extern i_img *i_rotate90(i_img *im, int degrees); +extern i_img *i_rotate_exact(i_img *im, double amount); +extern i_img *i_rotate_exact_bg(i_img *im, double amount, const i_color *backp, const i_fcolor *fbackp); +extern i_img *i_matrix_transform(i_img *im, int xsize, int ysize, const double *matrix); +extern i_img *i_matrix_transform_bg(i_img *im, int xsize, int ysize, const double *matrix, const i_color *backp, const i_fcolor *fbackp); + +void i_bezier_multi(i_img *im,int l,const double *x,const double *y,const i_color *val); +void i_poly_aa (i_img *im,int l,const double *x,const double *y,const i_color *val); +void i_poly_aa_cfill(i_img *im,int l,const double *x,const double *y,i_fill_t *fill); + +undef_int i_flood_fill (i_img *im,int seedx,int seedy, const i_color *dcol); +undef_int i_flood_cfill(i_img *im, int seedx, int seedy, i_fill_t *fill); +undef_int i_flood_fill_border (i_img *im,int seedx,int seedy, const i_color *dcol, const i_color *border); +undef_int i_flood_cfill_border(i_img *im, int seedx, int seedy, i_fill_t *fill, const i_color *border); + + +/* image processing functions */ + +int i_gaussian (i_img *im, double stdev); +int i_conv (i_img *im,const double *coeff,int len); +void i_unsharp_mask(i_img *im, double stddev, double scale); + +/* colour manipulation */ +extern i_img *i_convert(i_img *src, const float *coeff, int outchan, int inchan); +extern void i_map(i_img *im, unsigned char (*maps)[256], unsigned int mask); + +float i_img_diff (i_img *im1,i_img *im2); +double i_img_diffd(i_img *im1,i_img *im2); + +/* font routines */ + +undef_int i_init_fonts( int t1log ); + +#ifdef HAVE_LIBT1 + +undef_int i_init_t1( int t1log ); +int i_t1_new( char *pfb, char *afm ); +int i_t1_destroy( int font_id ); +undef_int i_t1_cp( i_img *im, int xb, int yb, int channel, int fontnum, float points, char* str, int len, int align, int utf8, char const *flags ); +undef_int i_t1_text( i_img *im, int xb, int yb, const i_color *cl, int fontnum, float points, const char* str, int len, int align, int utf8, char const *flags ); +int i_t1_bbox( int fontnum, float point, const char *str, int len, int cords[6], int utf8, char const *flags ); +void i_t1_set_aa( int st ); +void close_t1( void ); +int i_t1_has_chars(int font_num, char const *text, int len, int utf8, char *out); +extern int i_t1_face_name(int font_num, char *name_buf, size_t name_buf_size); +extern int i_t1_glyph_name(int font_num, unsigned long ch, char *name_buf, + size_t name_buf_size); +#endif + +#ifdef HAVE_LIBTT + +undef_int i_init_tt( void ); +TT_Fonthandle* i_tt_new(const char *fontname); +void i_tt_destroy( TT_Fonthandle *handle ); +undef_int i_tt_cp( TT_Fonthandle *handle,i_img *im,int xb,int yb,int channel,float points,char const* txt,int len,int smooth, int utf8, int align); +undef_int i_tt_text( TT_Fonthandle *handle, i_img *im, int xb, int yb, const i_color *cl, float points, char const* txt, int len, int smooth, int utf8, int align); +undef_int i_tt_bbox( TT_Fonthandle *handle, float points,const char *txt,int len,int cords[6], int utf8); +int i_tt_has_chars(TT_Fonthandle *handle, char const *text, int len, int utf8, char *out); +void i_tt_dump_names(TT_Fonthandle *handle); +int i_tt_face_name(TT_Fonthandle *handle, char *name_buf, + size_t name_buf_size); +int i_tt_glyph_name(TT_Fonthandle *handle, unsigned long ch, char *name_buf, + size_t name_buf_size); + +#endif /* End of freetype headers */ + +#ifdef HAVE_FT2 + +extern int i_ft2_init(void); +extern FT2_Fonthandle * i_ft2_new(const char *name, int index); +extern void i_ft2_destroy(FT2_Fonthandle *handle); +extern int i_ft2_setdpi(FT2_Fonthandle *handle, int xdpi, int ydpi); +extern int i_ft2_getdpi(FT2_Fonthandle *handle, int *xdpi, int *ydpi); +extern int i_ft2_settransform(FT2_Fonthandle *handle, const double *matrix); +extern int i_ft2_sethinting(FT2_Fonthandle *handle, int hinting); +extern int i_ft2_bbox(FT2_Fonthandle *handle, double cheight, double cwidth, + char const *text, int len, int *bbox, int utf8); +extern int i_ft2_bbox_r(FT2_Fonthandle *handle, double cheight, double cwidth, + char const *text, int len, int vlayout, int utf8, int *bbox); +extern int i_ft2_text(FT2_Fonthandle *handle, i_img *im, int tx, int ty, + const i_color *cl, double cheight, double cwidth, + char const *text, int len, int align, int aa, + int vlayout, int utf8); +extern int i_ft2_cp(FT2_Fonthandle *handle, i_img *im, int tx, int ty, + int channel, double cheight, double cwidth, + char const *text, int len, int align, int aa, int vlayout, + int utf8); +extern int i_ft2_has_chars(FT2_Fonthandle *handle, char const *text, int len, + int utf8, char *work); +extern int i_ft2_face_name(FT2_Fonthandle *handle, char *name_buf, + size_t name_buf_size); +extern int i_ft2_can_face_name(void); +extern int i_ft2_glyph_name(FT2_Fonthandle *handle, unsigned long ch, + char *name_buf, size_t name_buf_size, + int reliable_only); +extern int i_ft2_can_do_glyph_names(void); +extern int i_ft2_face_has_glyph_names(FT2_Fonthandle *handle); + +extern int i_ft2_get_multiple_masters(FT2_Fonthandle *handle, + i_font_mm *mm); +extern int +i_ft2_is_multiple_master(FT2_Fonthandle *handle); +extern int +i_ft2_set_mm_coords(FT2_Fonthandle *handle, int coord_count, const long *coords); +#endif + +#ifdef WIN32 + +extern int i_wf_bbox(const char *face, int size, const char *text, int length, int *bbox, int utf8); +extern int i_wf_text(const char *face, i_img *im, int tx, int ty, const i_color *cl, + int size, const char *text, int len, int align, int aa, int utf8); +extern int i_wf_cp(const char *face, i_img *im, int tx, int ty, int channel, + int size, const char *text, int len, int align, int aa, int utf8); +extern int i_wf_addfont(char const *file); +extern int i_wf_delfont(char const *file); + +#endif + +/* functions for reading and writing formats */ + +/* general reader callback + userdata - data the user passed into the reader + buffer - the buffer to fill with data + need - the amount of data needed + want - the amount of space we have to store data + fill buffer and return the number of bytes read, 0 for eof, -1 for error +*/ + +typedef int (*i_read_callback_t)(char *userdata, char *buffer, int need, + int want); + +/* i_gen_reader() translates the low-level requests from whatever library + into buffered requests. + but the called function can always bypass buffering by only ever + reading I<need> bytes. +*/ +#define CBBUFSIZ 4096 + +typedef struct { + i_read_callback_t cb; + char *userdata; + char buffer[CBBUFSIZ]; + int length; + int cpos; +} i_gen_read_data; + +extern int i_gen_reader(i_gen_read_data *info, char *buffer, int need); +extern i_gen_read_data *i_gen_read_data_new(i_read_callback_t cb, char *userdata); +extern void i_free_gen_read_data(i_gen_read_data *); + +/* general writer callback + userdata - the data the user passed into the writer + data - the data to write + data_size - the number of bytes to write + write the data, return non-zero on success, zero on failure. +*/ +typedef int (*i_write_callback_t)(char *userdata, char const *data, int size); + +typedef struct { + i_write_callback_t cb; + char *userdata; + char buffer[CBBUFSIZ]; + int maxlength; + int filledto; +} i_gen_write_data; + +extern int i_gen_writer(i_gen_write_data *info, char const *data, int size); +extern i_gen_write_data *i_gen_write_data_new(i_write_callback_t cb, char *userdata, int maxlength); +extern int i_free_gen_write_data(i_gen_write_data *, int flush); + +extern void i_quant_makemap(i_quantize *quant, i_img **imgs, int count); +extern i_palidx *i_quant_translate(i_quantize *quant, i_img *img); +extern void i_quant_transparent(i_quantize *quant, i_palidx *indices, i_img *img, i_palidx trans_index); + +extern i_img *i_img_pal_new(int x, int y, int channels, int maxpal); +extern i_img *i_img_to_pal(i_img *src, i_quantize *quant); +extern i_img *i_img_to_rgb(i_img *src); +extern i_img *i_img_masked_new(i_img *targ, i_img *mask, int x, int y, + int w, int h); +extern i_img *i_img_16_new(int x, int y, int ch); +extern i_img *i_img_to_rgb16(i_img *im); +extern i_img *i_img_double_new(int x, int y, int ch); + +extern int i_img_is_monochrome(i_img *im, int *zero_is_white); +extern void i_get_file_background(i_img *im, i_color *bg); +extern void i_get_file_backgroundf(i_img *im, i_fcolor *bg); + +const char * i_test_format_probe(io_glue *data, int length); + + +#ifdef HAVE_LIBJPEG +i_img * +i_readjpeg_wiol(io_glue *ig, int length, char** iptc_itext, int *itlength); +undef_int i_writejpeg_wiol(i_img *im, io_glue *ig, int qfactor); +#endif /* HAVE_LIBJPEG */ + +#ifdef HAVE_LIBTIFF +i_img * i_readtiff_wiol(io_glue *ig, int allow_incomplete, int page); +i_img ** i_readtiff_multi_wiol(io_glue *ig, int length, int *count); +undef_int i_writetiff_wiol(i_img *im, io_glue *ig); +undef_int i_writetiff_multi_wiol(io_glue *ig, i_img **imgs, int count); +undef_int i_writetiff_wiol_faxable(i_img *im, io_glue *ig, int fine); +undef_int i_writetiff_multi_wiol_faxable(io_glue *ig, i_img **imgs, int count, int fine); +char const * i_tiff_libversion(void); +int i_tiff_has_compression(char const *name); + +#endif /* HAVE_LIBTIFF */ + +#ifdef HAVE_LIBPNG +i_img *i_readpng_wiol(io_glue *ig, int length); +undef_int i_writepng_wiol(i_img *im, io_glue *ig); +#endif /* HAVE_LIBPNG */ + +#ifdef HAVE_LIBGIF +i_img *i_readgif(int fd, int **colour_table, int *colours); +i_img *i_readgif_wiol(io_glue *ig, int **colour_table, int *colours); +i_img *i_readgif_scalar(char *data, int length, int **colour_table, int *colours); +i_img *i_readgif_callback(i_read_callback_t callback, char *userdata, int **colour_table, int *colours); +i_img *i_readgif_single_wiol(io_glue *ig, int page); +extern i_img **i_readgif_multi(int fd, int *count); +extern i_img **i_readgif_multi_scalar(char *data, int length, int *count); +extern i_img **i_readgif_multi_callback(i_read_callback_t callback, char *userdata, int *count); +extern i_img **i_readgif_multi_wiol(io_glue *ig, int *count); +undef_int i_writegif(i_img *im,int fd,int colors,int pixdev,int fixedlen,i_color fixed[]); +undef_int i_writegifmc(i_img *im,int fd,int colors); +undef_int i_writegifex(i_img *im,int fd); +undef_int i_writegif_gen(i_quantize *quant, int fd, i_img **imgs, int count); +undef_int i_writegif_callback(i_quantize *quant, i_write_callback_t cb, char *userdata, int maxbuffer, i_img **imgs, int count); +undef_int i_writegif_wiol(io_glue *ig, i_quantize *quant, + i_img **imgs, int count); +void i_qdist(i_img *im); + +#endif /* HAVE_LIBGIF */ + +i_img * i_readraw_wiol(io_glue *ig, int x, int y, int datachannels, int storechannels, int intrl); +undef_int i_writeraw_wiol(i_img* im, io_glue *ig); + +i_img * i_readpnm_wiol(io_glue *ig, int allow_incomplete); +undef_int i_writeppm_wiol(i_img *im, io_glue *ig); + +extern int i_writebmp_wiol(i_img *im, io_glue *ig); +extern i_img *i_readbmp_wiol(io_glue *ig, int allow_incomplete); + +int tga_header_verify(unsigned char headbuf[18]); + +i_img * i_readtga_wiol(io_glue *ig, int length); +undef_int i_writetga_wiol(i_img *img, io_glue *ig, int wierdpack, int compress, char *idstring, size_t idlen); + +i_img * i_readrgb_wiol(io_glue *ig, int length); +undef_int i_writergb_wiol(i_img *img, io_glue *ig, int wierdpack, int compress, char *idstring, size_t idlen); + +i_img * i_scaleaxis(i_img *im, float Value, int Axis); +i_img * i_scale_nn(i_img *im, float scx, float scy); +i_img * i_scale_mixing(i_img *src, int width, int height); +i_img * i_haar(i_img *im); +int i_count_colors(i_img *im,int maxc); +int i_get_anonymous_color_histo(i_img *im, unsigned int **col_usage, int maxc); + +i_img * i_transform(i_img *im, int *opx,int opxl,int *opy,int opyl,double parm[],int parmlen); + +struct rm_op; +i_img * i_transform2(int width, int height, int channels, + struct rm_op *ops, int ops_count, + double *n_regs, int n_regs_count, + i_color *c_regs, int c_regs_count, + i_img **in_imgs, int in_imgs_count); + +/* filters */ + +void i_contrast(i_img *im, float intensity); +void i_hardinvert(i_img *im); +void i_noise(i_img *im, float amount, unsigned char type); +void i_bumpmap(i_img *im,i_img *bump,int channel,int light_x,int light_y,int strength); +void i_bumpmap_complex(i_img *im, i_img *bump, int channel, int tx, int ty, float Lx, float Ly, + float Lz, float cd, float cs, float n, i_color *Ia, i_color *Il, i_color *Is); +void i_postlevels(i_img *im,int levels); +void i_mosaic(i_img *im,int size); +void i_watermark(i_img *im,i_img *wmark,int tx,int ty,int pixdiff); +void i_autolevels(i_img *im,float lsat,float usat,float skew); +void i_radnoise(i_img *im,int xo,int yo,float rscale,float ascale); +void i_turbnoise(i_img *im,float xo,float yo,float scale); +void i_gradgen(i_img *im, int num, int *xo, int *yo, i_color *ival, int dmeasure); +int i_nearest_color(i_img *im, int num, int *xo, int *yo, i_color *ival, int dmeasure); +i_img *i_diff_image(i_img *im, i_img *im2, double mindist); +int +i_fountain(i_img *im, double xa, double ya, double xb, double yb, + i_fountain_type type, i_fountain_repeat repeat, + int combine, int super_sample, double ssample_param, + int count, i_fountain_seg *segs); +extern i_fill_t * +i_new_fill_fount(double xa, double ya, double xb, double yb, + i_fountain_type type, i_fountain_repeat repeat, + int combine, int super_sample, double ssample_param, + int count, i_fountain_seg *segs); + +/* Debug only functions */ + +void malloc_state( void ); + +/* this is sort of obsolete now */ + +typedef struct { + undef_int (*i_has_format)(char *frmt); + i_color*(*ICL_set)(i_color *cl,unsigned char r,unsigned char g,unsigned char b,unsigned char a); + void (*ICL_info)(const i_color *cl); + + i_img*(*i_img_new)( void ); + i_img*(*i_img_empty)(i_img *im,int x,int y); + i_img*(*i_img_empty_ch)(i_img *im,int x,int y,int ch); + void(*i_img_exorcise)(i_img *im); + + void(*i_img_info)(i_img *im,int *info); + + void(*i_img_setmask)(i_img *im,int ch_mask); + int (*i_img_getmask)(i_img *im); + + /* + int (*i_ppix)(i_img *im,int x,int y,i_color *val); + int (*i_gpix)(i_img *im,int x,int y,i_color *val); + */ + void(*i_box)(i_img *im,int x1,int y1,int x2,int y2,const i_color *val); + void(*i_line)(i_img *im,int x1,int y1,int x2,int y2,const i_color *val,int endp); + void(*i_arc)(i_img *im,int x,int y,float rad,float d1,float d2,const i_color *val); + void(*i_copyto)(i_img *im,i_img *src,int x1,int y1,int x2,int y2,int tx,int ty); + void(*i_copyto_trans)(i_img *im,i_img *src,int x1,int y1,int x2,int y2,int tx,int ty,const i_color *trans); + int(*i_rubthru)(i_img *im,i_img *src,int tx,int ty, int src_minx, int src_miny, int src_maxx, int src_maxy); + +} symbol_table_t; + +#include "imerror.h" + +/* image tag processing */ +extern void i_tags_new(i_img_tags *tags); +extern int i_tags_addn(i_img_tags *tags, char const *name, int code, + int idata); +extern int i_tags_add(i_img_tags *tags, char const *name, int code, + char const *data, int size, int idata); +extern int i_tags_set(i_img_tags *tags, char const *name, + char const *data, int size); +extern int i_tags_setn(i_img_tags *tags, char const *name, int idata); + +extern void i_tags_destroy(i_img_tags *tags); +extern int i_tags_find(i_img_tags *tags, char const *name, int start, + int *entry); +extern int i_tags_findn(i_img_tags *tags, int code, int start, int *entry); +extern int i_tags_delete(i_img_tags *tags, int entry); +extern int i_tags_delbyname(i_img_tags *tags, char const *name); +extern int i_tags_delbycode(i_img_tags *tags, int code); +extern int i_tags_get_float(i_img_tags *tags, char const *name, int code, + double *value); +extern int i_tags_set_float(i_img_tags *tags, char const *name, int code, + double value); +extern int i_tags_set_float2(i_img_tags *tags, char const *name, int code, + double value, int places); +extern int i_tags_get_int(i_img_tags *tags, char const *name, int code, + int *value); +extern int i_tags_get_string(i_img_tags *tags, char const *name, int code, + char *value, size_t value_size); +extern int i_tags_get_color(i_img_tags *tags, char const *name, int code, + i_color *value); +extern int i_tags_set_color(i_img_tags *tags, char const *name, int code, + i_color const *value); +extern void i_tags_print(i_img_tags *tags); + +/* image file limits */ +extern int +i_set_image_file_limits(int width, int height, int bytes); +extern int +i_get_image_file_limits(int *width, int *height, int *bytes); +extern int +i_int_check_image_file_limits(int width, int height, int channels, int sample_size); + +/* memory allocation */ +void* mymalloc(int size); +void myfree(void *p); +void* myrealloc(void *p, size_t newsize); +void* mymalloc_file_line (size_t size, char* file, int line); +void myfree_file_line (void *p, char*file, int line); +void* myrealloc_file_line(void *p, size_t newsize, char* file,int line); + +#ifdef IMAGER_DEBUG_MALLOC + +#define mymalloc(x) (mymalloc_file_line((x), __FILE__, __LINE__)) +#define myrealloc(x,y) (myrealloc_file_line((x),(y), __FILE__, __LINE__)) +#define myfree(x) (myfree_file_line((x), __FILE__, __LINE__)) + +void malloc_state (void); +void* mymalloc_comm (int size, char *comm); +void bndcheck_all (void); + +#else + +#define malloc_comm(a,b) (mymalloc(a)) +void malloc_state(void); + +#endif /* IMAGER_MALLOC_DEBUG */ + +#include "imrender.h" +#include "immacros.h" + +extern void +i_adapt_colors(int dest_channels, int src_channels, i_color *colors, + size_t count); +extern void +i_adapt_fcolors(int dest_channels, int src_channels, i_fcolor *colors, + size_t count); + +extern void +i_adapt_colors_bg(int dest_channels, int src_channels, i_color *colors, + size_t count, i_color const *bg); +extern void +i_adapt_fcolors_bg(int dest_channels, int src_channels, i_fcolor *colors, + size_t count, i_fcolor const *bg); + +extern int +i_gsamp_bg(i_img *im, int l, int r, int y, i_sample_t *samples, + int out_channels, i_color const *bg); + +extern int +i_gsampf_bg(i_img *im, int l, int r, int y, i_fsample_t *samples, + int out_channels, i_fcolor const *bg); + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imageri.h b/Master/tlpkg/tlperl0/lib/Imager/include/imageri.h new file mode 100755 index 00000000000..e01df468397 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imageri.h @@ -0,0 +1,111 @@ +/* Declares utility functions useful across various files which + aren't meant to be available externally +*/ + +#ifndef IMAGEI_H_ +#define IMAGEI_H_ + +#include "imager.h" + +/* wrapper functions that implement the floating point sample version of a + function in terms of the 8-bit sample version +*/ +extern int i_ppixf_fp(i_img *im, int x, int y, const i_fcolor *pix); +extern int i_gpixf_fp(i_img *im, int x, int y, i_fcolor *pix); +extern int i_plinf_fp(i_img *im, int l, int r, int y, const i_fcolor *pix); +extern int i_glinf_fp(i_img *im, int l, int r, int y, i_fcolor *pix); +extern int i_gsampf_fp(i_img *im, int l, int r, int y, i_fsample_t *samp, + int const *chans, int chan_count); + +/* wrapper functions that forward palette calls to the underlying image, + assuming the underlying image is the first pointer in whatever + ext_data points at +*/ +extern int i_addcolors_forward(i_img *im, const i_color *, int count); +extern int i_getcolors_forward(i_img *im, int i, i_color *, int count); +extern int i_colorcount_forward(i_img *im); +extern int i_maxcolors_forward(i_img *im); +extern int i_findcolor_forward(i_img *im, const i_color *color, + i_palidx *entry); +extern int i_setcolors_forward(i_img *im, int index, const i_color *colors, + int count); + +/* fallback handler for gsamp_bits */ +extern int i_gsamp_bits_fb(i_img *im, int x, int r, int y, unsigned *samp, + const int *chans, int chan_count, int bits); + +#define SampleFTo16(num) ((int)((num) * 65535.0 + 0.01)) +/* we add that little bit to avoid rounding issues */ +#define Sample16ToF(num) ((num) / 65535.0) + +#define SampleFTo8(num) ((int)((num) * 255.0 + 0.01)) +#define Sample8ToF(num) ((num) / 255.0) + +#define Sample16To8(num) ((num) / 257) +#define Sample8To16(num) ((num) * 257) + +extern void i_get_combine(int combine, i_fill_combine_f *, i_fill_combinef_f *); + +#define im_min(a, b) ((a) < (b) ? (a) : (b)) +#define im_max(a, b) ((a) > (b) ? (a) : (b)) + +#include "ext.h" + +extern UTIL_table_t i_UTIL_table; + +/* Ideally this will move into imconfig.h if we ever probe */ +#if defined(_GNU_SOURCE) || __STDC_VERSION__ >= 199901L +/* snprintf() is part of C99 and provided by Glibc */ +#define HAVE_SNPRINTF +#endif + +/* test if all channels are writable */ +#define I_ALL_CHANNELS_WRITABLE(im) (((im)->ch_mask & 0xF) == 0xf) + +typedef struct i_int_hline_seg_tag { + int minx, x_limit; +} i_int_hline_seg; + +typedef struct i_int_hline_entry_tag { + int count; + int alloc; + i_int_hline_seg segs[1]; +} i_int_hline_entry; + +/* represents a set of horizontal line segments to be filled in later */ +typedef struct i_int_hlines_tag { + int start_y, limit_y; + int start_x, limit_x; + i_int_hline_entry **entries; +} i_int_hlines; + +extern void +i_int_init_hlines( + i_int_hlines *hlines, + int start_y, + int count_y, + int start_x, + int width_x + ); +extern void i_int_init_hlines_img(i_int_hlines *hlines, i_img *img); +extern void i_int_hlines_add(i_int_hlines *hlines, int y, int minx, int width); +extern void i_int_hlines_destroy(i_int_hlines *hlines); + +extern void i_int_hlines_fill_color(i_img *im, i_int_hlines *hlines, const i_color *val); +extern void i_int_hlines_fill_fill(i_img *im, i_int_hlines *hlines, i_fill_t *fill); + +#define I_LIMIT_8(x) ((x) < 0 ? 0 : (x) > 255 ? 255 : (x)) +#define I_LIMIT_DOUBLE(x) ((x) < 0.0 ? 0.0 : (x) > 1.0 ? 1.0 : (x)) + +#define IM_STRING(x) #x + +/* I considered using assert.h here, but perl does it's own thing with + assert() and the NDEBUG test is opposite to the direction I prefer */ +#ifdef IM_ASSERT +extern void im_assert_fail(char const *, int, char const *); +#define im_assert(x) ((x) ? (void)(0) : im_assert_fail(__FILE__, __LINE__, IM_STRING(x))) +#else +#define im_assert(x) (void)(0) +#endif + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imconfig.h b/Master/tlpkg/tlperl0/lib/Imager/include/imconfig.h new file mode 100755 index 00000000000..187a099d97d --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imconfig.h @@ -0,0 +1,62 @@ +/* This file is automatically generated by Makefile.PL. + Don't edit this file, since any changes will be lost */ + +#ifndef IMAGER_IMCONFIG_H +#define IMAGER_IMCONFIG_H + +/* + Logging system +*/ + +#define IMAGER_LOG 1 + +/* + Parsed giflib version +*/ + +#define IM_GIFMAJOR 4 +#define IM_GIFMINOR 1 + +/* + gif available +*/ + +#define HAVE_LIBGIF 1 + +/* + jpeg available +*/ + +#define HAVE_LIBJPEG 1 + +/* + png available +*/ + +#define HAVE_LIBPNG 1 + +/* + tiff available +*/ + +#define HAVE_LIBTIFF 1 + +/* + freetype2 available +*/ + +#define HAVE_FT2 1 + +/* + w32 available +*/ + +#define HAVE_WIN32 1 + +/* + Enable experimental EXIF support +*/ + +#define IMEXIF_ENABLE 1 + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imdatatypes.h b/Master/tlpkg/tlperl0/lib/Imager/include/imdatatypes.h new file mode 100755 index 00000000000..007ba1018b7 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imdatatypes.h @@ -0,0 +1,715 @@ +#ifndef _DATATYPES_H_ +#define _DATATYPES_H_ + +#include "imconfig.h" +#include "imio.h" + +#define MAXCHANNELS 4 + +/* used for palette indices in some internal code (which might be + exposed at some point +*/ +typedef unsigned char i_palidx; + +/* We handle 2 types of sample, this is hopefully the most common, and the + smaller of the ones we support */ +typedef unsigned char i_sample_t; + +typedef struct { i_sample_t gray_color; } gray_color; +typedef struct { i_sample_t r,g,b; } rgb_color; +typedef struct { i_sample_t r,g,b,a; } rgba_color; +typedef struct { i_sample_t c,m,y,k; } cmyk_color; + +typedef int undef_int; /* special value to put in typemaps to retun undef on 0 and 1 on 1 */ + +/* +=item i_color +=category Data Types +=synopsis i_color black; +=synopsis black.rgba.r = black.rgba.g = black.rgba.b = black.rgba.a = 0; + +Type for 8-bit/sample color. + +Samples as per; + + i_color c; + +i_color is a union of: + +=over + +=item * + +gray - contains a single element gray_color, eg. c.gray.gray_color + +=item * + +rgb - contains three elements r, g, b, eg. c.rgb.r + +=item * + +rgba - contains four elements r, g, b, a, eg. c.rgba.a + +=item * + +cmyk - contains four elements c, m, y, k, eg. C<c.cmyk.y>. Note that +Imager never uses CMYK colors except when reading/writing files. + +=item * + +channels - an array of four channels, eg C<c.channels[2]>. + +=back + +=cut +*/ + +typedef union { + gray_color gray; + rgb_color rgb; + rgba_color rgba; + cmyk_color cmyk; + i_sample_t channel[MAXCHANNELS]; + unsigned int ui; +} i_color; + +/* this is the larger sample type, it should be able to accurately represent + any sample size we use */ +typedef double i_fsample_t; + +typedef struct { i_fsample_t gray_color; } i_fgray_color_t; +typedef struct { i_fsample_t r, g, b; } i_frgb_color_t; +typedef struct { i_fsample_t r, g, b, a; } i_frgba_color_t; +typedef struct { i_fsample_t c, m, y, k; } i_fcmyk_color_t; + +/* +=item i_fcolor +=category Data Types + +This is the double/sample color type. + +Its layout exactly corresponds to i_color. + +=cut +*/ + +typedef union { + i_fgray_color_t gray; + i_frgb_color_t rgb; + i_frgba_color_t rgba; + i_fcmyk_color_t cmyk; + i_fsample_t channel[MAXCHANNELS]; +} i_fcolor; + +typedef enum { + i_direct_type, /* direct colour, keeps RGB values per pixel */ + i_palette_type /* keeps a palette index per pixel */ +} i_img_type_t; + +typedef enum { + /* bits per sample, not per pixel */ + /* a paletted image might have one bit per sample */ + i_8_bits = 8, + i_16_bits = 16, + i_double_bits = sizeof(double) * 8 +} i_img_bits_t; + +typedef struct { + char *name; /* name of a given tag, might be NULL */ + int code; /* number of a given tag, -1 if it has no meaning */ + char *data; /* value of a given tag if it's not an int, may be NULL */ + int size; /* size of the data */ + int idata; /* value of a given tag if data is NULL */ +} i_img_tag; + +typedef struct { + int count; /* how many tags have been set */ + int alloc; /* how many tags have been allocated for */ + i_img_tag *tags; +} i_img_tags; + +typedef struct i_img_ i_img; +typedef int (*i_f_ppix_t)(i_img *im, int x, int y, const i_color *pix); +typedef int (*i_f_ppixf_t)(i_img *im, int x, int y, const i_fcolor *pix); +typedef int (*i_f_plin_t)(i_img *im, int x, int r, int y, const i_color *vals); +typedef int (*i_f_plinf_t)(i_img *im, int x, int r, int y, const i_fcolor *vals); +typedef int (*i_f_gpix_t)(i_img *im, int x, int y, i_color *pix); +typedef int (*i_f_gpixf_t)(i_img *im, int x, int y, i_fcolor *pix); +typedef int (*i_f_glin_t)(i_img *im, int x, int r, int y, i_color *vals); +typedef int (*i_f_glinf_t)(i_img *im, int x, int r, int y, i_fcolor *vals); + +typedef int (*i_f_gsamp_t)(i_img *im, int x, int r, int y, i_sample_t *samp, + const int *chans, int chan_count); +typedef int (*i_f_gsampf_t)(i_img *im, int x, int r, int y, i_fsample_t *samp, + const int *chan, int chan_count); + +typedef int (*i_f_gpal_t)(i_img *im, int x, int r, int y, i_palidx *vals); +typedef int (*i_f_ppal_t)(i_img *im, int x, int r, int y, const i_palidx *vals); +typedef int (*i_f_addcolors_t)(i_img *im, const i_color *colors, int count); +typedef int (*i_f_getcolors_t)(i_img *im, int i, i_color *, int count); +typedef int (*i_f_colorcount_t)(i_img *im); +typedef int (*i_f_maxcolors_t)(i_img *im); +typedef int (*i_f_findcolor_t)(i_img *im, const i_color *color, i_palidx *entry); +typedef int (*i_f_setcolors_t)(i_img *im, int index, const i_color *colors, + int count); + +typedef void (*i_f_destroy_t)(i_img *im); + +typedef int (*i_f_gsamp_bits_t)(i_img *im, int x, int r, int y, unsigned *samp, + const int *chans, int chan_count, int bits); +typedef int (*i_f_psamp_bits_t)(i_img *im, int x, int r, int y, unsigned const *samp, + const int *chans, int chan_count, int bits); + +/* +=item i_img_dim +=category Data Types +=synopsis i_img_dim x; +=order 90 + +A signed integer type that represents an image dimension or ordinate. + +May be larger than int on some platforms. + +=cut +*/ +typedef int i_img_dim; + +/* +=item i_img +=category Data Types +=synopsis i_img *img; +=order 10 + +This is Imager's image type. + +It contains the following members: + +=over + +=item * + +channels - the number of channels in the image + +=item * + +xsize, ysize - the width and height of the image in pixels + +=item * + +bytes - the number of bytes used to store the image data. Undefined +where virtual is non-zero. + +=item * + +ch_mask - a mask of writable channels. eg. if this is 6 then only +channels 1 and 2 are writable. There may be bits set for which there +are no channels in the image. + +=item * + +bits - the number of bits stored per sample. Should be one of +i_8_bits, i_16_bits, i_double_bits. + +=item * + +type - either i_direct_type for direct color images, or i_palette_type +for paletted images. + +=item * + +virtual - if zero then this image is-self contained. If non-zero then +this image could be an interface to some other implementation. + +=item * + +idata - the image data. This should not be directly accessed. A new +image implementation can use this to store its image data. +i_img_destroy() will myfree() this pointer if it's non-null. + +=item * + +tags - a structure storing the image's tags. This should only be +accessed via the i_tags_*() functions. + +=item * + +ext_data - a pointer for use internal to an image implementation. +This should be freed by the image's destroy handler. + +=item * + +im_data - data internal to Imager. This is initialized by +i_img_init(). + +=item * + +i_f_ppix, i_f_ppixf, i_f_plin, i_f_plinf, i_f_gpix, i_f_gpixf, +i_f_glin, i_f_glinf, i_f_gsamp, i_f_gampf - implementations for each +of the required image functions. An image implementation should +initialize these between calling i_img_alloc() and i_img_init(). + +=item * + +i_f_gpal, i_f_ppal, i_f_addcolors, i_f_getcolors, i_f_colorcount, +i_f_maxcolors, i_f_findcolor, i_f_setcolors - implementations for each +paletted image function. + +=item * + +i_f_destroy - custom image destruction function. This should be used +to release memory if necessary. + +=item * + +i_f_gsamp_bits - implements i_gsamp_bits() for this image. + +=item * + +i_f_psamp_bits - implements i_psamp_bits() for this image. + +=back + +=cut +*/ + +struct i_img_ { + int channels; + i_img_dim xsize,ysize; + size_t bytes; + unsigned int ch_mask; + i_img_bits_t bits; + i_img_type_t type; + int virtual; /* image might not keep any data, must use functions */ + unsigned char *idata; /* renamed to force inspection of existing code */ + /* can be NULL if virtual is non-zero */ + i_img_tags tags; + + void *ext_data; + + /* interface functions */ + i_f_ppix_t i_f_ppix; + i_f_ppixf_t i_f_ppixf; + i_f_plin_t i_f_plin; + i_f_plinf_t i_f_plinf; + i_f_gpix_t i_f_gpix; + i_f_gpixf_t i_f_gpixf; + i_f_glin_t i_f_glin; + i_f_glinf_t i_f_glinf; + i_f_gsamp_t i_f_gsamp; + i_f_gsampf_t i_f_gsampf; + + /* only valid for type == i_palette_type */ + i_f_gpal_t i_f_gpal; + i_f_ppal_t i_f_ppal; + i_f_addcolors_t i_f_addcolors; + i_f_getcolors_t i_f_getcolors; + i_f_colorcount_t i_f_colorcount; + i_f_maxcolors_t i_f_maxcolors; + i_f_findcolor_t i_f_findcolor; + i_f_setcolors_t i_f_setcolors; + + i_f_destroy_t i_f_destroy; + + /* as of 0.61 */ + i_f_gsamp_bits_t i_f_gsamp_bits; + i_f_psamp_bits_t i_f_psamp_bits; + + void *im_data; +}; + +/* ext_data for paletted images + */ +typedef struct { + int count; /* amount of space used in palette (in entries) */ + int alloc; /* amount of space allocated for palette (in entries) */ + i_color *pal; + int last_found; +} i_img_pal_ext; + +/* Helper datatypes + The types in here so far are: + + doubly linked bucket list - pretty efficient + octtree - no idea about goodness + + needed: hashes. + +*/ + +/* bitmap mask */ + +struct i_bitmap { + int xsize,ysize; + char *data; +}; + +struct i_bitmap* btm_new(int xsize,int ysize); +void btm_destroy(struct i_bitmap *btm); +int btm_test(struct i_bitmap *btm,int x,int y); +void btm_set(struct i_bitmap *btm,int x,int y); + + +/* Stack/Linked list */ + +struct llink { + struct llink *p,*n; + void *data; + int fill; /* Number used in this link */ +}; + +struct llist { + struct llink *h,*t; + int multip; /* # of copies in a single chain */ + int ssize; /* size of each small element */ + int count; /* number of elements on the list */ +}; + + +/* Links */ + +struct llink *llink_new( struct llink* p,int size ); +int llist_llink_push( struct llist *lst, struct llink *lnk, void *data ); + +/* Lists */ + +struct llist *llist_new( int multip, int ssize ); +void llist_destroy( struct llist *l ); +void llist_push( struct llist *l, void *data ); +void llist_dump( struct llist *l ); +int llist_pop( struct llist *l,void *data ); + + + + +/* Octtree */ + +struct octt { + struct octt *t[8]; + int cnt; +}; + +struct octt *octt_new(void); +int octt_add(struct octt *ct,unsigned char r,unsigned char g,unsigned char b); +void octt_dump(struct octt *ct); +void octt_count(struct octt *ct,int *tot,int max,int *overflow); +void octt_delete(struct octt *ct); +void octt_histo(struct octt *ct, unsigned int **col_usage_it_adr); + +/* font bounding box results */ +enum bounding_box_index_t { + BBOX_NEG_WIDTH, + BBOX_GLOBAL_DESCENT, + BBOX_POS_WIDTH, + BBOX_GLOBAL_ASCENT, + BBOX_DESCENT, + BBOX_ASCENT, + BBOX_ADVANCE_WIDTH, + BBOX_RIGHT_BEARING, + BOUNDING_BOX_COUNT +}; + +/* Generic fills */ +struct i_fill_tag; + +typedef void (*i_fill_with_color_f) + (struct i_fill_tag *fill, int x, int y, int width, int channels, + i_color *data); +typedef void (*i_fill_with_fcolor_f) + (struct i_fill_tag *fill, int x, int y, int width, int channels, + i_fcolor *data); +typedef void (*i_fill_destroy_f)(struct i_fill_tag *fill); + +/* combine functions modify their target and are permitted to modify + the source to prevent having to perform extra copying/memory + allocations, etc + The out array has I<channels> channels. + + The in array has I<channels> channels + an alpha channel if one + isn't included in I<channels>. +*/ + +typedef void (*i_fill_combine_f)(i_color *out, i_color *in, int channels, + int count); +typedef void (*i_fill_combinef_f)(i_fcolor *out, i_fcolor *in, int channels, + int count); + +/* fountain fill types */ +typedef enum { + i_fst_linear, + i_fst_curved, + i_fst_sine, + i_fst_sphere_up, + i_fst_sphere_down, + i_fst_end +} i_fountain_seg_type; +typedef enum { + i_fc_direct, + i_fc_hue_up, + i_fc_hue_down, + i_fc_end +} i_fountain_color; +typedef struct { + double start, middle, end; + i_fcolor c[2]; + i_fountain_seg_type type; + i_fountain_color color; +} i_fountain_seg; +typedef enum { + i_fr_none, + i_fr_sawtooth, + i_fr_triangle, + i_fr_saw_both, + i_fr_tri_both +} i_fountain_repeat; +typedef enum { + i_ft_linear, + i_ft_bilinear, + i_ft_radial, + i_ft_radial_square, + i_ft_revolution, + i_ft_conical, + i_ft_end +} i_fountain_type; +typedef enum { + i_fts_none, + i_fts_grid, + i_fts_random, + i_fts_circle +} i_ft_supersample; + +/* +=item i_fill_t +=category Data Types +=synopsis i_fill_t *fill; + +This is the "abstract" base type for Imager's fill types. + +Unless you're implementing a new fill type you'll typically treat this +as an opaque type. + +=cut +*/ + +typedef struct i_fill_tag +{ + /* called for 8-bit/sample image (and maybe lower) */ + /* this may be NULL, if so call fill_with_fcolor */ + i_fill_with_color_f f_fill_with_color; + + /* called for other sample sizes */ + /* this must be non-NULL */ + i_fill_with_fcolor_f f_fill_with_fcolor; + + /* called if non-NULL to release any extra resources */ + i_fill_destroy_f destroy; + + /* if non-zero the caller will fill data with the original data + from the image */ + i_fill_combine_f combine; + i_fill_combinef_f combinef; +} i_fill_t; + +typedef enum { + ic_none, + ic_normal, + ic_multiply, + ic_dissolve, + ic_add, + ic_subtract, + ic_diff, + ic_lighten, + ic_darken, + ic_hue, + ic_sat, + ic_value, + ic_color +} i_combine_t; + +/* + describes an axis of a MM font. + Modelled on FT2's FT_MM_Axis. + It would be nice to have a default entry too, but FT2 + doesn't support it. +*/ +typedef struct i_font_mm_axis_tag { + char const *name; + int minimum; + int maximum; +} i_font_mm_axis; + +#define IM_FONT_MM_MAX_AXES 4 + +/* + multiple master information for a font, if any + modelled on FT2's FT_Multi_Master. +*/ +typedef struct i_font_mm_tag { + int num_axis; + int num_designs; /* provided but not necessarily useful */ + i_font_mm_axis axis[IM_FONT_MM_MAX_AXES]; +} i_font_mm; + +#ifdef HAVE_LIBTT + +struct TT_Fonthandle_; + +typedef struct TT_Fonthandle_ TT_Fonthandle; + +#endif + +#ifdef HAVE_FT2 + +typedef struct FT2_Fonthandle FT2_Fonthandle; + +#endif + +/* transparency handling for quantized output */ +typedef enum i_transp_tag { + tr_none, /* ignore any alpha channel */ + tr_threshold, /* threshold the transparency - uses tr_threshold */ + tr_errdiff, /* error diffusion */ + tr_ordered /* an ordered dither */ +} i_transp; + +/* controls how we build the colour map */ +typedef enum i_make_colors_tag { + mc_none, /* user supplied colour map only */ + mc_web_map, /* Use the 216 colour web colour map */ + mc_addi, /* Addi's algorithm */ + mc_median_cut, /* median cut - similar to giflib, hopefully */ + mc_mono, /* fixed mono color map */ + mc_mask = 0xFF /* (mask for generator) */ +} i_make_colors; + +/* controls how we translate the colours */ +typedef enum i_translate_tag { + pt_giflib, /* get gif lib to do it (ignores make_colours) */ + pt_closest, /* just use the closest match within the hashbox */ + pt_perturb, /* randomly perturb the data - uses perturb_size*/ + pt_errdiff /* error diffusion dither - uses errdiff */ +} i_translate; + +/* Which error diffusion map to use */ +typedef enum i_errdiff_tag { + ed_floyd, /* floyd-steinberg */ + ed_jarvis, /* Jarvis, Judice and Ninke */ + ed_stucki, /* Stucki */ + ed_custom, /* the map found in ed_map|width|height|orig */ + ed_mask = 0xFF, /* mask to get the map */ + ed_bidir = 0x100 /* change direction for each row */ +} i_errdiff; + +/* which ordered dither map to use + currently only available for transparency + I don't know of a way to do ordered dither of an image against some + general palette + */ +typedef enum i_ord_dith_tag +{ + od_random, /* sort of random */ + od_dot8, /* large dot */ + od_dot4, + od_hline, + od_vline, + od_slashline, /* / line dither */ + od_backline, /* \ line dither */ + od_tiny, /* small checkerbox */ + od_custom /* custom 8x8 map */ +} i_ord_dith; + +typedef struct i_gif_pos_tag { + int x, y; +} i_gif_pos; + +/* passed into i_writegif_gen() to control quantization */ +typedef struct i_quantize_tag { + /* how to handle transparency */ + i_transp transp; + /* the threshold at which to make pixels opaque */ + int tr_threshold; + i_errdiff tr_errdiff; + i_ord_dith tr_orddith; + unsigned char tr_custom[64]; + + /* how to make the colour map */ + i_make_colors make_colors; + + /* any existing colours + mc_existing is an existing colour table + mc_count is the number of existing colours + mc_size is the total size of the array that mc_existing points + at - this must be at least 256 + */ + i_color *mc_colors; + int mc_size; + int mc_count; + + /* how we translate the colours */ + i_translate translate; + + /* the error diffusion map to use if translate is mc_errdiff */ + i_errdiff errdiff; + /* the following define the error diffusion values to use if + errdiff is ed_custom. ed_orig is the column on the top row that + represents the current + */ + int *ed_map; + int ed_width, ed_height, ed_orig; + + /* the amount of perturbation to use for translate is mc_perturb */ + int perturb; +} i_quantize; + +typedef struct i_gif_opts { + /* each image has a local color map */ + int each_palette; + + /* images are interlaced */ + int interlace; + + /* time for which image is displayed + (in 1/100 seconds) + default: 0 + */ + int delay_count; + int *delays; + + /* user input flags + default: 0 + */ + int user_input_count; + char *user_input_flags; + + /* disposal + default: 0 */ + int disposal_count; + char *disposal; + + /* this is added to the color table when we make an image transparent */ + i_color tran_color; + + /* image positions */ + int position_count; + i_gif_pos *positions; + + /* Netscape loop extension - number of loops */ + int loop_count; + + /* should be eliminate unused colors? */ + int eliminate_unused; +} i_gif_opts; + +/* distance measures used by some filters */ +enum { + i_dmeasure_euclidean = 0, + i_dmeasure_euclidean_squared = 1, + i_dmeasure_manhatten = 2, + i_dmeasure_limit = 2, +}; + +#include "iolayert.h" + +#include "rendert.h" + +#endif + diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imerror.h b/Master/tlpkg/tlperl0/lib/Imager/include/imerror.h new file mode 100755 index 00000000000..313834f4b39 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imerror.h @@ -0,0 +1,27 @@ +#ifndef IMAGER_IMERROR_H +#define IMAGER_IMERROR_H + +/* error handling + see error.c for documentation + the error information is currently global +*/ +typedef struct { + char *msg; + int code; +} i_errmsg; + +typedef void (*i_error_cb)(int code, char const *msg); +typedef void (*i_failed_cb)(i_errmsg *msgs); +extern i_error_cb i_set_error_cb(i_error_cb); +extern i_failed_cb i_set_failed_cb(i_failed_cb); +extern void i_set_argv0(char const *); +extern int i_set_errors_fatal(int new_fatal); +extern i_errmsg *i_errors(void); + +extern void i_push_error(int code, char const *msg); +extern void i_push_errorf(int code, char const *fmt, ...); +extern void i_push_errorvf(int code, char const *fmt, va_list); +extern void i_clear_error(void); +extern int i_failed(int code, char const *msg); + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imexif.h b/Master/tlpkg/tlperl0/lib/Imager/include/imexif.h new file mode 100755 index 00000000000..70a2b161ca5 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imexif.h @@ -0,0 +1,10 @@ +/* imexif.h - interface to Exif handling */ +#ifndef IMAGER_IMEXIF_H +#define IMAGER_IMEXIF_H + +#include <stddef.h> +#include "imageri.h" + +extern int i_int_decode_exif(i_img *im, unsigned char *data, size_t length); + +#endif /* ifndef IMAGER_IMEXIF_H */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imext.h b/Master/tlpkg/tlperl0/lib/Imager/include/imext.h new file mode 100755 index 00000000000..13fef908699 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imext.h @@ -0,0 +1,206 @@ +#ifndef IMAGER_IMEXT_H_ +#define IMAGER_IMEXT_H_ + +#include "imexttypes.h" +#include "immacros.h" + +extern im_ext_funcs *imager_function_ext_table; + +#define DEFINE_IMAGER_CALLBACKS im_ext_funcs *imager_function_ext_table + +#ifndef IMAGER_MIN_API_LEVEL +#define IMAGER_MIN_API_LEVEL IMAGER_API_LEVEL +#endif + +#define PERL_INITIALIZE_IMAGER_CALLBACKS \ + do { \ + imager_function_ext_table = INT2PTR(im_ext_funcs *, SvIV(get_sv(PERL_FUNCTION_TABLE_NAME, 1))); \ + if (!imager_function_ext_table) \ + croak("Imager API function table not found!"); \ + if (imager_function_ext_table->version != IMAGER_API_VERSION) \ + croak("Imager API version incorrect"); \ + if (imager_function_ext_table->level < IMAGER_MIN_API_LEVEL) \ + croak("API level %d below minimum of %d", imager_function_ext_table->level, IMAGER_MIN_API_LEVEL); \ + } while (0) + +/* just for use here */ +#define im_extt imager_function_ext_table + +#ifdef IMAGER_DEBUG_MALLOC + +#define mymalloc(size) ((im_extt->f_mymalloc_file_line)((size), __FILE__, __LINE__)) +#define myrealloc(ptr, size) ((im_extt->f_myrealloc_file_line)((ptr), (size), __FILE__, __LINE__)) +#define myfree(ptr) ((im_extt->f_myfree_file_line)((ptr), __FILE__, __LINE__)) + +#else + +#define mymalloc(size) ((im_extt->f_mymalloc)(size)) +#define myfree(size) ((im_extt->f_myfree)(size)) +#define myrealloc(block, newsize) ((im_extt->f_myrealloc)((block), (newsize))) + +#endif + +#define i_img_8_new(xsize, ysize, channels) ((im_extt->f_i_img_8_new)((xsize), (ysize), (channels))) +#define i_img_16_new(xsize, ysize, channels) ((im_extt->f_i_img_16_new)((xsize), (ysize), (channels))) +#define i_img_double_new(xsize, ysize, channels) ((im_extt->f_i_img_double_new)((xsize), (ysize), (channels))) +#define i_img_pal_new(xsize, ysize, channels, maxpal) ((im_extt->f_i_img_pal_new)((xsize), (ysize), (channels), (maxpal))) + +#define i_img_destroy(im) ((im_extt->f_i_img_destroy)(im)) +#define i_sametype(im, xsize, ysize) ((im_extt->f_i_sametype)((im), (xsize), (ysize))) +#define i_sametype_chans(im, xsize, ysize, channels) ((im_extt->f_i_sametype_chans)((im), (xsize), (ysize), (channels))) +#define i_img_info(im, info) ((im_extt->f_i_img_info)((im), (info))) + +#ifndef IMAGER_DIRECT_IMAGE_CALLS +#define IMAGER_DIRECT_IMAGE_CALLS 1 +#endif + +#if IMAGER_DIRECT_IMAGE_CALLS +#define i_ppix(im, x, y, val) (((im)->i_f_ppix)((im), (x), (y), (val))) +#define i_gpix(im, x, y, val) (((im)->i_f_gpix)((im), (x), (y), (val))) +#define i_ppixf(im, x, y, val) (((im)->i_f_ppixf)((im), (x), (y), (val))) +#define i_gpixf(im, x, y, val) (((im)->i_f_gpixf)((im), (x), (y), (val))) +#define i_plin(im, l, r, y, val) (((im)->i_f_plin)(im, l, r, y, val)) +#define i_glin(im, l, r, y, val) (((im)->i_f_glin)(im, l, r, y, val)) +#define i_plinf(im, l, r, y, val) (((im)->i_f_plinf)(im, l, r, y, val)) +#define i_glinf(im, l, r, y, val) (((im)->i_f_glinf)(im, l, r, y, val)) + +#define i_gsamp(im, l, r, y, samps, chans, count) \ + (((im)->i_f_gsamp)((im), (l), (r), (y), (samps), (chans), (count))) +#define i_gsampf(im, l, r, y, samps, chans, count) \ + (((im)->i_f_gsampf)((im), (l), (r), (y), (samps), (chans), (count))) + +#define i_findcolor(im, color, entry) \ + (((im)->i_f_findcolor) ? ((im)->i_f_findcolor)((im), (color), (entry)) : 0) + +#define i_gpal(im, l, r, y, vals) \ + (((im)->i_f_gpal) ? ((im)->i_f_gpal)((im), (l), (r), (y), (vals)) : 0) +#define i_ppal(im, l, r, y, vals) \ + (((im)->i_f_ppal) ? ((im)->i_f_ppal)((im), (l), (r), (y), (vals)) : 0) +#define i_addcolors(im, colors, count) \ + (((im)->i_f_addcolors) ? ((im)->i_f_addcolors)((im), (colors), (count)) : -1) +#define i_getcolors(im, index, color, count) \ + (((im)->i_f_getcolors) ? \ + ((im)->i_f_getcolors)((im), (index), (color), (count)) : 0) +#define i_setcolors(im, index, color, count) \ + (((im)->i_f_setcolors) ? \ + ((im)->i_f_setcolors)((im), (index), (color), (count)) : 0) +#define i_colorcount(im) \ + (((im)->i_f_colorcount) ? ((im)->i_f_colorcount)(im) : -1) +#define i_maxcolors(im) \ + (((im)->i_f_maxcolors) ? ((im)->i_f_maxcolors)(im) : -1) +#define i_findcolor(im, color, entry) \ + (((im)->i_f_findcolor) ? ((im)->i_f_findcolor)((im), (color), (entry)) : 0) +#else +#define i_ppix(im, x, y, val) ((im_extt->f_i_ppix)((im), (x), (y), (val))) +#define i_gpix(im, x, y, val) ((im_extt->f_i_gpix)((im), (x), (y), (val))) +#define i_ppixf(im, x, y, val) ((im_extt->f_i_ppixf)((im), (x), (y), (val))) +#define i_gpixf(im, x, y, val) ((im_extt->f_i_gpixf)((im), (x), (y), (val))) +#define i_plin(im, l, r, y, val) ((im_extt->f_i_plin)((im), (l), (r), (y), (val))) +#define i_glin(im, l, r, y, val) ((im_extt->f_i_glin)((im), (l), (r), (y), (val))) +#define i_plinf(im, l, r, y, val) ((im_extt->f_i_plinf)((im), (l), (r), (y), (val))) +#define i_glinf(im, l, r, y, val) ((im_extt->f_i_glinf)((im), (l), (r), (y), (val))) +#define i_gsamp(im, l, r, y, samps, chans, count) \ + ((im_extt->f_i_gsamp)((im), (l), (r), (y), (samps), (chans), (count))) +#define i_gsampf(im, l, r, y, samps, chans, count) \ + ((im_extt->f_i_gsampf)((im), (l), (r), (y), (samps), (chans), (count))) + +#endif + +#define i_new_fill_solid(c, combine) ((im_extt->f_i_new_fill_solid)((c), (combine))) +#define i_new_fill_solidf(c, combine) ((im_extt->f_i_new_fill_solidf)((c), (combine))) +#define i_new_fill_hatch(fg, bg, combine, hatch, cust_hatch, dx, dy) \ + ((im_extt->f_i_new_fill_hatch)((fg), (bg), (combine), (hatch), (cust_hatch), (dx), (dy))) +#define i_new_fill_hatchf(fg, bg, combine, hatch, cust_hatch, dx, dy) \ + ((im_extt->f_i_new_fill_hatchf)((fg), (bg), (combine), (hatch), (cust_hatch), (dx), (dy))) +#define i_new_fill_image(im, matrix, xoff, yoff, combine) \ + ((im_extt->f_i_new_fill_image)((im), (matrix), (xoff), (yoff), (combine))) +#define i_new_fill_fount(xa, ya, xb, yb, type, repeat, combine, super_sample, ssample_param, count, segs) \ + ((im_extt->f_i_new_fill_fount)((xa), (ya), (xb), (yb), (type), (repeat), (combine), (super_sample), (ssample_param), (count), (segs))) +#define i_fill_destroy(fill) ((im_extt->f_i_fill_destroy)(fill)) + +#define i_quant_makemap(quant, imgs, count) \ + ((im_extt->f_i_quant_makemap)((quant), (imgs), (count))) +#define i_quant_translate(quant, img) \ + ((im_extt->f_i_quant_translate)((quant), (img))) +#define i_quant_transparent(quant, indices, img, trans_index) \ + ((im_extt->f_i_quant_transparent)((quant), (indices), (img), (trans_index))) + +#define i_clear_error() ((im_extt->f_i_clear_error)()) +#define i_push_error(code, msg) ((im_extt->f_i_push_error)((code), (msg))) +#define i_push_errorf (im_extt->f_i_push_errorf) +#define i_push_errorvf(code, fmt, list) \ + ((im_extt->f_i_push_errorvf)((code), (fmt), (list))) + +#define i_tags_new(tags) ((im_extt->f_i_tags_new)(tags)) +#define i_tags_set(tags, name, data, size) \ + ((im_extt->f_i_tags_set)((tags), (name), (data), (size))) +#define i_tags_setn(tags, name, idata) \ + ((im_extt->f_i_tags_setn)((tags), (name), (idata))) +#define i_tags_destroy(tags) ((im_extt->f_i_tags_destroy)(tags)) +#define i_tags_find(tags, name, start, entry) \ + ((im_extt->f_i_tags_find)((tags), (name), (start), (entry))) +#define i_tags_findn(tags, code, start, entry) \ + ((im_extt->f_i_tags_findn)((tags), (code), (start), (entry))) +#define i_tags_delete(tags, entry) \ + ((im_extt->f_i_tags_delete)((tags), (entry))) +#define i_tags_delbyname(tags, name) \ + ((im_extt->f_i_tags_delbyname)((tags), (name))) +#define i_tags_delbycode(tags, code) \ + ((im_extt->f_i_tags_delbycode)((tags), (code))) +#define i_tags_get_float(tags, name, code, value) \ + ((im_extt->f_i_tags_get_float)((tags), (name), (code), (value))) +#define i_tags_set_float(tags, name, code, value) \ + ((im_extt->f_i_tags_set_float)((tags), (name), (code), (value))) +#define i_tags_set_float2(tags, name, code, value, places) \ + ((im_extt->f_i_tags_set_float2)((tags), (name), (code), (value), (places))) +#define i_tags_get_int(tags, name, code, value) \ + ((im_extt->f_i_tags_get_int)((tags), (name), (code), (value))) +#define i_tags_get_string(tags, name, code, value, value_size) \ + ((im_extt->f_i_tags_get_string)((tags), (name), (code), (value), (value_size))) +#define i_tags_get_color(tags, name, code, value) \ + ((im_extt->f_i_tags_get_color)((tags), (name), (code), (value))) +#define i_tags_set_color(tags, name, code, value) \ + ((im_extt->f_i_tags_set_color)((tags), (name), (code), (value))) + +#define i_box(im, x1, y1, x2, y2, val) ((im_extt->f_i_box)((im), (x1), (y1), (x2), (y2), (val))) +#define i_box_filled(im, x1, y1, x2, y2, val) ((im_extt->f_i_box_filled)((im), (x1), (y1), (x2), (y2), (val))) +#define i_box_cfill(im, x1, y1, x2, y2, fill) ((im_extt->f_i_box_cfill)((im), (x1), (y1), (x2), (y2), (fill))) +#define i_line(im, x1, y1, x2, y2, val, endp) ((im_extt->f_i_line)((im), (x1), (y1), (x2), (y2), (val), (endp))) +#define i_line_aa(im, x1, y1, x2, y2, val, endp) ((im_extt->f_i_line_aa)((im), (x1), (y1), (x2), (y2), (val), (endp))) +#define i_arc(im, x, y, rad, d1, d2, val) ((im_extt->f_i_arc)((im), (x), (y), (rad), (d1), (d2), (val))) +#define i_arc_aa(im, x, y, rad, d1, d2, val) ((im_extt->f_i_arc_aa)((im), (x), (y), (rad), (d1), (d2), (val))) +#define i_arc_cfill(im, x, y, rad, d1, d2, fill) ((im_extt->f_i_arc_cfill)((im), (x), (y), (rad), (d1), (d2), (fill))) +#define i_arc_aa_cfill(im, x, y, rad, d1, d2, fill) ((im_extt->f_i_arc_aa_cfill)((im), (x), (y), (rad), (d1), (d2), (fill))) +#define i_circle_aa(im, x, y, rad, val) ((im_extt->f_i_circle_aa)((im), (x), (y), (rad), (val))) +#define i_flood_fill(im, seedx, seedy, dcol) ((im_extt->f_i_flood_fill)((im), (seedx), (seedy), (dcol))) +#define i_flood_cfill(im, seedx, seedy, fill) ((im_extt->f_i_flood_cfill)((im), (seedx), (seedy), (fill))) +#define i_flood_fill_border(im, seedx, seedy, dcol, border) ((im_extt->f_i_flood_fill_border)((im), (seedx), (seedy), (dcol), (border))) +#define i_flood_cfill_border(im, seedx, seedy, fill, border) ((im_extt->f_i_flood_cfill_border)((im), (seedx), (seedy), (fill), (border))) + +#define i_copyto(im, src, x1, y1, x2, y2, tx, ty) \ + ((im_extt->f_i_copyto)((im), (src), (x1), (y1), (x2), (y2), (tx), (ty))) +#define i_copyto_trans(im, src, x1, y1, x2, y2, tx, ty, trans) \ + ((im_extt->f_i_copyto_trans)((im), (src), (x1), (y1), (x2), (y2), (tx), (ty), (trans))) +#define i_copy(im) ((im_extt->f_i_copy)(im)) +#define i_rubthru(im, src, tx, ty, src_minx, src_miny, src_maxx, src_maxy) \ + ((im_extt->f_i_rubthru)((im), (src), (tx), (ty), (src_minx), (src_miny), (src_maxx), (src_maxy))) + +#define i_set_image_file_limits(max_width, max_height, max_bytes) \ + ((im_extt->f_i_set_image_file_limits)((max_width), (max_height), (max_bytes))) +#define i_get_image_file_limits(max_width, max_height, max_bytes) \ + ((im_extt->f_i_get_image_file_limits)((pmax_width), (pmax_height), (pmax_bytes))) +#define i_int_check_image_file_limits(width, height, channels, sample_size) \ + ((im_extt->f_i_int_check_image_file_limits)((width), (height), (channels), (sample_size))) + +#define i_img_setmask(img, mask) ((im_extt->f_i_img_setmask)((img), (mask))) +#define i_img_getmask(img) ((im_extt->f_i_img_getmask)(img)) +#define i_img_getchannels(img) ((im_extt->f_i_img_getchannels)(img)) +#define i_img_get_width(img) ((im_extt->f_i_img_get_width)(img)) +#define i_img_get_height(img) ((im_extt->f_i_img_get_height)(img)) +#define i_lhead(file, line) ((im_extt->f_i_lhead)((file), (line))) +#define i_loog (im_extt->f_i_loog) + +#define i_img_alloc() ((im_extt->f_i_img_alloc)()) +#define i_img_init(img) ((im_extt->f_i_img_init)(img)) + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imextdef.h b/Master/tlpkg/tlperl0/lib/Imager/include/imextdef.h new file mode 100755 index 00000000000..d1c5f50b76b --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imextdef.h @@ -0,0 +1,11 @@ +#ifndef IMAGER_IMEXTDEF_H +#define IMAGER_IMEXTDEF_H + +#include "imexttypes.h" + +extern im_ext_funcs imager_function_table; + +#define PERL_SET_GLOBAL_CALLBACKS \ + sv_setiv(get_sv(PERL_FUNCTION_TABLE_NAME, 1), PTR2IV(&imager_function_table)); + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imexttypes.h b/Master/tlpkg/tlperl0/lib/Imager/include/imexttypes.h new file mode 100755 index 00000000000..fc3dcf7ac5e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imexttypes.h @@ -0,0 +1,163 @@ +#ifndef IMAGER_IMEXTTYPES_H_ +#define IMAGER_IMEXTTYPES_H_ + +/* keep this file simple - apidocs.perl parses it. */ + +#include "imdatatypes.h" + +/* + IMAGER_API_VERSION is similar to the version number in the third and + fourth bytes of TIFF files - if it ever changes then the API has changed + too much for any application to remain compatible. +*/ +#define IMAGER_API_VERSION 1 + +/* + IMAGER_API_LEVEL is the level of the structure. New function pointers + will always remain at the end (unless IMAGER_API_VERSION changes), and + will result in an increment of IMAGER_API_LEVEL. +*/ + +#define IMAGER_API_LEVEL 4 + +typedef struct { + int version; + int level; + + /* IMAGER_API_LEVEL 1 functions */ + void * (*f_mymalloc)(int size); + void (*f_myfree)(void *block); + void * (*f_myrealloc)(void *block, size_t newsize); + void* (*f_mymalloc_file_line)(size_t size, char* file, int line); + void (*f_myfree_file_line)(void *p, char*file, int line); + void* (*f_myrealloc_file_line)(void *p, size_t newsize, char* file,int line); + + i_img *(*f_i_img_8_new)(int xsize, int ysize, int channels); + i_img *(*f_i_img_16_new)(int xsize, int ysize, int channels); + i_img *(*f_i_img_double_new)(int xsize, int ysize, int channels); + i_img *(*f_i_img_pal_new)(int xsize, int ysize, int channels, int maxpal); + void (*f_i_img_destroy)(i_img *im); + i_img *(*f_i_sametype)(i_img *im, int xsize, int ysize); + i_img *(*f_i_sametype_chans)(i_img *im, int xsize, int ysize, int channels); + void (*f_i_img_info)(i_img *im, int *info); + + int (*f_i_ppix)(i_img *im, int x, int y, const i_color *val); + int (*f_i_gpix)(i_img *im, int x, int y, i_color *val); + int (*f_i_ppixf)(i_img *im, int x, int y, const i_fcolor *val); + int (*f_i_gpixf)(i_img *im, int x, int y, i_fcolor *val); + int (*f_i_plin)(i_img *im, int l, int r, int y, const i_color *vals); + int (*f_i_glin)(i_img *im, int l, int r, int y, i_color *vals); + int (*f_i_plinf)(i_img *im, int l, int r, int y, const i_fcolor *vals); + int (*f_i_glinf)(i_img *im, int l, int r, int y, i_fcolor *vals); + int (*f_i_gsamp)(i_img *im, int l, int r, int y, i_sample_t *samp, + const int *chans, int chan_count); + int (*f_i_gsampf)(i_img *im, int l, int r, int y, i_fsample_t *samp, + const int *chans, int chan_count); + int (*f_i_gpal)(i_img *im, int x, int r, int y, i_palidx *vals); + int (*f_i_ppal)(i_img *im, int x, int r, int y, const i_palidx *vals); + int (*f_i_addcolors)(i_img *im, const i_color *colors, int count); + int (*f_i_getcolors)(i_img *im, int i, i_color *, int count); + int (*f_i_colorcount)(i_img *im); + int (*f_i_maxcolors)(i_img *im); + int (*f_i_findcolor)(i_img *im, const i_color *color, i_palidx *entry); + int (*f_i_setcolors)(i_img *im, int index, const i_color *colors, + int count); + + i_fill_t *(*f_i_new_fill_solid)(const i_color *c, int combine); + i_fill_t *(*f_i_new_fill_solidf)(const i_fcolor *c, int combine); + + i_fill_t *(*f_i_new_fill_hatch)(const i_color *fg, const i_color *bg, int combine, + int hatch, const unsigned char *cust_hatch, + int dx, int dy); + i_fill_t *(*f_i_new_fill_hatchf)(const i_fcolor *fg, const i_fcolor *bg, int combine, + int hatch, const unsigned char *cust_hatch, + int dx, int dy); + i_fill_t *(*f_i_new_fill_image)(i_img *im, const double *matrix, int xoff, + int yoff, int combine); + i_fill_t *(*f_i_new_fill_fount)(double xa, double ya, double xb, double yb, + i_fountain_type type, i_fountain_repeat repeat, + int combine, int super_sample, double ssample_param, + int count, i_fountain_seg *segs); + + void (*f_i_fill_destroy)(i_fill_t *fill); + + void (*f_i_quant_makemap)(i_quantize *quant, i_img **imgs, int count); + i_palidx * (*f_i_quant_translate)(i_quantize *quant, i_img *img); + void (*f_i_quant_transparent)(i_quantize *quant, i_palidx *indices, + i_img *img, i_palidx trans_index); + + void (*f_i_clear_error)(void); + void (*f_i_push_error)(int code, char const *msg); + void (*f_i_push_errorf)(int code, char const *fmt, ...); + void (*f_i_push_errorvf)(int code, char const *fmt, va_list); + + void (*f_i_tags_new)(i_img_tags *tags); + int (*f_i_tags_set)(i_img_tags *tags, char const *name, char const *data, + int size); + int (*f_i_tags_setn)(i_img_tags *tags, char const *name, int idata); + void (*f_i_tags_destroy)(i_img_tags *tags); + int (*f_i_tags_find)(i_img_tags *tags, char const *name, int start, + int *entry); + int (*f_i_tags_findn)(i_img_tags *tags, int code, int start, int *entry); + int (*f_i_tags_delete)(i_img_tags *tags, int entry); + int (*f_i_tags_delbyname)(i_img_tags *tags, char const *name); + int (*f_i_tags_delbycode)(i_img_tags *tags, int code); + int (*f_i_tags_get_float)(i_img_tags *tags, char const *name, int code, + double *value); + int (*f_i_tags_set_float)(i_img_tags *tags, char const *name, int code, + double value); + int (*f_i_tags_set_float2)(i_img_tags *tags, char const *name, int code, + double value, int places); + int (*f_i_tags_get_int)(i_img_tags *tags, char const *name, int code, + int *value); + int (*f_i_tags_get_string)(i_img_tags *tags, char const *name, int code, + char *value, size_t value_size); + int (*f_i_tags_get_color)(i_img_tags *tags, char const *name, int code, + i_color *value); + int (*f_i_tags_set_color)(i_img_tags *tags, char const *name, int code, + i_color const *value); + + void (*f_i_box)(i_img *im, int x1, int y1, int x2, int y2, const i_color *val); + void (*f_i_box_filled)(i_img *im, int x1, int y1, int x2, int y2, const i_color *val); + void (*f_i_box_cfill)(i_img *im, int x1, int y1, int x2, int y2, i_fill_t *fill); + void (*f_i_line)(i_img *im, int x1, int y1, int x2, int y2, const i_color *val, int endp); + void (*f_i_line_aa)(i_img *im, int x1, int y1, int x2, int y2, const i_color *val, int endp); + void (*f_i_arc)(i_img *im, int x, int y, float rad, float d1, float d2, const i_color *val); + void (*f_i_arc_aa)(i_img *im, double x, double y, double rad, double d1, double d2, const i_color *val); + void (*f_i_arc_cfill)(i_img *im, int x, int y, float rad, float d1, float d2, i_fill_t *val); + void (*f_i_arc_aa_cfill)(i_img *im, double x, double y, double rad, double d1, double d2, i_fill_t *fill); + void (*f_i_circle_aa)(i_img *im, float x, float y, float rad, const i_color *val); + int (*f_i_flood_fill)(i_img *im, int seedx, int seedy, const i_color *dcol); + int (*f_i_flood_cfill)(i_img *im, int seedx, int seedy, i_fill_t *fill); + + void (*f_i_copyto)(i_img *im, i_img *src, int x1, int y1, int x2, int y2, int tx, int ty); + void (*f_i_copyto_trans)(i_img *im, i_img *src, int x1, int y1, int x2, int y2, int tx, int ty, const i_color *trans); + i_img *(*f_i_copy)(i_img *im); + int (*f_i_rubthru)(i_img *im, i_img *src, int tx, int ty, int src_minx, int src_miny, int src_maxx, int src_maxy); + + /* IMAGER_API_LEVEL 2 functions */ + int (*f_i_set_image_file_limits)(int width, int height, int bytes); + int (*f_i_get_image_file_limits)(int *width, int *height, int *bytes); + int (*f_i_int_check_image_file_limits)(int width, int height, int channels, int sample_size); + int (*f_i_flood_fill_border)(i_img *im, int seedx, int seedy, const i_color *dcol, const i_color *border); + int (*f_i_flood_cfill_border)(i_img *im, int seedx, int seedy, i_fill_t *fill, const i_color *border); + + /* IMAGER_API_LEVEL 3 functions */ + void (*f_i_img_setmask)(i_img *im, int ch_mask); + int (*f_i_img_getmask)(i_img *im); + int (*f_i_img_getchannels)(i_img *im); + i_img_dim (*f_i_img_get_width)(i_img *im); + i_img_dim (*f_i_img_get_height)(i_img *im); + void (*f_i_lhead)(const char *file, int line_number); + void (*f_i_loog)(int level, const char *msg, ...); + + /* IMAGER_API_LEVEL 4 functions will be added here */ + i_img *(*f_i_img_alloc)(void); + void (*f_i_img_init)(i_img *); + + /* IMAGER_API_LEVEL 5 functions will be added here */ +} im_ext_funcs; + +#define PERL_FUNCTION_TABLE_NAME "Imager::__ext_func_table" + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imio.h b/Master/tlpkg/tlperl0/lib/Imager/include/imio.h new file mode 100755 index 00000000000..d78e4732702 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imio.h @@ -0,0 +1,34 @@ +#ifndef IMAGER_IMIO_H_ +#define IMAGER_IMIO_H_ +#include <stdio.h> +#include <sys/stat.h> + +#include "imconfig.h" +#include "log.h" + +typedef struct i_mempool { + void **p; + unsigned int alloc; + unsigned int used; +} i_mempool; + +void i_mempool_init(i_mempool *mp); +void i_mempool_extend(i_mempool *mp); +void *i_mempool_alloc(i_mempool *mp, size_t size); +void i_mempool_destroy(i_mempool *mp); + + + +#ifdef _MSC_VER +#undef min +#undef max +#endif + +extern unsigned long i_utf8_advance(char const **p, int *len); + +/* XXX Shouldn't these go away? */ + +int i_min(int a,int b); +int i_max(int x,int y); + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/immacros.h b/Master/tlpkg/tlperl0/lib/Imager/include/immacros.h new file mode 100755 index 00000000000..9d5757445bf --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/immacros.h @@ -0,0 +1,33 @@ +/* + Imager "functions" implemented as macros + + I suppose these could go in imdatatypes, but they aren't types. +*/ +#ifndef IMAGER_IMMACROS_H_ +#define IMAGER_IMMACROS_H_ + +/* +=item i_img_has_alpha(im) + +=category Image Information + +Return true if the image has an alpha channel. + +=cut +*/ + +#define i_img_has_alpha(im) ((im)->channels == 2 || (im)->channels == 4) + +/* +=item i_img_color_channels(im) + +=category Image Information + +The number of channels holding color information. + +=cut +*/ + +#define i_img_color_channels(im) (i_img_has_alpha(im) ? (im)->channels - 1 : (im)->channels) + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imperl.h b/Master/tlpkg/tlperl0/lib/Imager/include/imperl.h new file mode 100755 index 00000000000..fad1d66cc54 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imperl.h @@ -0,0 +1,35 @@ +/* + This header file defines types that Imager's typemap uses to convert to + perl types. + + This is meant for use in XS code, not in normal C source. + */ +#ifndef IMAGER_IMPERL_H +#define IMAGER_IMPERL_H + +#include "imdatatypes.h" + +typedef i_color* Imager__Color; +typedef i_fcolor* Imager__Color__Float; +typedef i_img* Imager__ImgRaw; +typedef int undef_neg_int; +typedef i_img * Imager; + +#ifdef HAVE_LIBTT +typedef TT_Fonthandle* Imager__Font__TT; +#endif + +#ifdef HAVE_FT2 +typedef FT2_Fonthandle* Imager__Font__FT2; +#endif + +/* for the fill objects + Since a fill object may later have dependent images, (or fills!) + we need perl wrappers - oh well +*/ +#define IFILL_DESTROY(fill) i_fill_destroy(fill); +typedef i_fill_t* Imager__FillHandle; + +typedef io_glue *Imager__IO; + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/imrender.h b/Master/tlpkg/tlperl0/lib/Imager/include/imrender.h new file mode 100755 index 00000000000..9ded02232eb --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/imrender.h @@ -0,0 +1,23 @@ +#ifndef IMAGER_IMRENDER_H +#define IMAGER_IMRENDER_H + +#include "rendert.h" + +extern void +i_render_init(i_render *r, i_img *im, int width); +extern void +i_render_done(i_render *r); +extern void +i_render_color(i_render *r, int x, int y, int width, unsigned char const *src, + i_color const *color); +extern void +i_render_fill(i_render *r, int x, int y, int width, unsigned char const *src, + i_fill_t *fill); +extern void +i_render_line(i_render *r, int x, int y, int width, const i_sample_t *src, + i_color *line, i_fill_combine_f combine); +extern void +i_render_linef(i_render *r, int x, int y, int width, const double *src, + i_fcolor *line, i_fill_combinef_f combine); + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/iolayer.h b/Master/tlpkg/tlperl0/lib/Imager/include/iolayer.h new file mode 100755 index 00000000000..ec164c0f3f4 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/iolayer.h @@ -0,0 +1,34 @@ +#ifndef _IOLAYER_H_ +#define _IOLAYER_H_ + + +/* How the IO layer works: + * + * Start by getting an io_glue object. Then define its + * datasource via io_obj_setp_buffer or io_obj_setp_cb. Before + * using the io_glue object be sure to call io_glue_commit_types(). + * After that data can be read via the io_glue->readcb() method. + * + */ + + +#include "iolayert.h" + +/* #define BBSIZ 1096 */ +#define BBSIZ 16384 +#define IO_FAKE_SEEK 1<<0L +#define IO_TEMP_SEEK 1<<1L + + +void io_glue_commit_types(io_glue *ig); +void io_glue_gettypes (io_glue *ig, int reqmeth); + +/* XS functions */ +io_glue *io_new_fd(int fd); +io_glue *io_new_bufchain(void); +io_glue *io_new_buffer(char *data, size_t len, i_io_closebufp_t closecb, void *closedata); +io_glue *io_new_cb(void *p, i_io_readl_t readcb, i_io_writel_t writecb, i_io_seekl_t seekcb, i_io_closel_t closecb, i_io_destroyl_t destroycb); +size_t io_slurp(io_glue *ig, unsigned char **c); +void io_glue_destroy(io_glue *ig); + +#endif /* _IOLAYER_H_ */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/iolayert.h b/Master/tlpkg/tlperl0/lib/Imager/include/iolayert.h new file mode 100755 index 00000000000..9857d67b0eb --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/iolayert.h @@ -0,0 +1,99 @@ +#ifndef IMAGER_IOLAYERT_H +#define IMAGER_IOLAYERT_H + +#ifndef _MSC_VER +#include <unistd.h> +#endif +#include <sys/types.h> +#include <stddef.h> + +typedef enum { FDSEEK, FDNOSEEK, BUFFER, CBSEEK, CBNOSEEK, BUFCHAIN } io_type; + +#ifdef _MSC_VER +typedef int ssize_t; +#endif + +typedef struct i_io_glue_t i_io_glue_t; + +/* compatibility for now */ +typedef i_io_glue_t io_glue; + +/* Callbacks we give out */ + +typedef ssize_t(*i_io_readp_t) (io_glue *ig, void *buf, size_t count); +typedef ssize_t(*i_io_writep_t)(io_glue *ig, const void *buf, size_t count); +typedef off_t (*i_io_seekp_t) (io_glue *ig, off_t offset, int whence); +typedef int (*i_io_closep_t)(io_glue *ig); +typedef ssize_t(*i_io_sizep_t) (io_glue *ig); + +typedef void (*i_io_closebufp_t)(void *p); +typedef void (*i_io_destroyp_t)(i_io_glue_t *ig); + + +/* Callbacks we get */ + +typedef ssize_t(*i_io_readl_t) (void *p, void *buf, size_t count); +typedef ssize_t(*i_io_writel_t)(void *p, const void *buf, size_t count); +typedef off_t (*i_io_seekl_t) (void *p, off_t offset, int whence); +typedef int (*i_io_closel_t)(void *p); +typedef void (*i_io_destroyl_t)(void *p); +typedef ssize_t(*i_io_sizel_t) (void *p); + +extern char *io_type_names[]; + + + +/* Structures to describe data sources */ + +typedef struct { + io_type type; + int fd; +} io_fdseek; + +typedef struct { + io_type type; /* Must be first parameter */ + char *name; /* Data source name */ + char *data; + size_t len; + i_io_closebufp_t closecb; /* free memory mapped segment or decrement refcount */ + void *closedata; +} io_buffer; + +typedef struct { + io_type type; /* Must be first parameter */ + char *name; /* Data source name */ + void *p; /* Callback data */ + i_io_readl_t readcb; + i_io_writel_t writecb; + i_io_seekl_t seekcb; + i_io_closel_t closecb; + i_io_destroyl_t destroycb; +} io_cb; + +typedef union { + io_type type; + io_fdseek fdseek; + io_buffer buffer; + io_cb cb; +} io_obj; + +struct i_io_glue_t { + io_obj source; + int flags; /* Flags */ + void *exdata; /* Pair specific data */ + i_io_readp_t readcb; + i_io_writep_t writecb; + i_io_seekp_t seekcb; + i_io_closep_t closecb; + i_io_sizep_t sizecb; + i_io_destroyp_t destroycb; +}; + +#define i_io_type(ig) ((ig)->source.ig_type) +#define i_io_read(ig, buf, size) ((ig)->readcb((ig), (buf), (size))) +#define i_io_write(ig, data, size) ((ig)->writecb((ig), (data), (size))) +#define i_io_seek(ig, offset, whence) ((ig)->seekcb((ig), (offset), (whence))) +#define i_io_close(ig) ((ig)->closecb(ig)) + + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/log.h b/Master/tlpkg/tlperl0/lib/Imager/include/log.h new file mode 100755 index 00000000000..5b1f483957b --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/log.h @@ -0,0 +1,38 @@ +#ifndef _LOG_H_ +#define _LOG_H_ + +#include <stdio.h> +#include <stdarg.h> +#include <time.h> +/* + input: name of file to log too + input: onoff, 0 means no logging + global: creates a global variable FILE* lg_file +*/ + +void i_lhead ( const char *file, int line ); +void i_init_log( const char *name, int onoff ); +void i_loog(int level,const char *msg, ... ); +void i_fatal ( int exitcode,const char *fmt, ... ); + +/* +=item mm_log((level, format, ...)) +=category Logging + +This is the main entry point to logging. Note that the extra set of +parentheses are required due to limitations in C89 macros. + +This will format a string with the current file and line number to the +log file if logging is enabled. + +=cut +*/ + +#ifdef IMAGER_LOG +#define mm_log(x) { i_lhead(__FILE__,__LINE__); i_loog x; } +#else +#define mm_log(x) +#endif + + +#endif /* _LOG_H_ */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/plug.h b/Master/tlpkg/tlperl0/lib/Imager/include/plug.h new file mode 100755 index 00000000000..e3583fca2cc --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/plug.h @@ -0,0 +1,42 @@ +#include "imager.h" + +/* structures for passing data between Imager-plugin and the Imager-module */ + +#include "ext.h" + + +#define getINT(k,s) (util_table->getint(INP,k,s)) +#define getDOUBLE(k,s) (util_table->getdouble(INP,k,s)) +#define getVOID(k,s) (util_table->getvoid(INP,k,(void**)s)) +#define getSTR(k,s) (util_table->getstr(INP,k,(char**)s)) +#define getOBJ(k,t,s) (util_table->getobj(INP,k,t,(void**)s)) + +#define i_color_set(cl,r,g,b,a) (symbol_table->i_color_set(cl,r,g,b,a)) +#define i_color_info(cl) (symbol_table->i_color_info(cl)) + +#define i_img_new() (symbol_table->i_img_new()) +#define i_img_empty(im,x,y) ((symbol_table->i_img_empty(im,x,y)) +#define i_img_empty_ch(im,x,y,ch) ((symbol_table->i_img_empty_ch(im,x,y,ch)) +#define i_img_exorcise(im) (symbol_table->i_img_exorcise(im)) +#define i_img_info(im,info) (symbol_table->i_img_info(im,info)) + +#define i_img_setmask(im,ch_mask) (symbol_table->i_img_setmask(im,ch_mask)) +#define i_img_getmask(im) (symbol_table->i_img_getmask(im)) + +/* +Not needed? The i_gpix() macro in image.h will call the right function +directly. +#define i_ppix(im,x,y,val) (symbol_table->i_ppix(im,x,y,val)) +#define i_gpix(im,x,y,val) (symbol_table->i_gpix(im,x,y,val)) +*/ + +#define i_box(im, x1, y1, x2, y2,val) (symbol_table->i_box(im, x1, y1, x2, y2,val)) +#define i_draw(im, x1, y1, x2, y2,val) (symbol_table->i_draw(im, x1, y1, x2, y2,val)) +#define i_arc(im, x, y, rad, d1, d2,val) (symbol_table->i_arc(im, x, y, rad, d1, d2,val)) +#define i_copyto(im,src, x1, y1, x2, y2, tx, ty,trans) (symbol_table->i_copyto(im,src, x1, y1, x2, y2, tx, ty,trans)) +#define i_rubthru(im,src, tx, ty) (symbol_table->i_rubthru(im,src, tx, ty)) + +#ifdef WIN32 +extern char __declspec(dllexport) evalstr[]; +extern func_ptr __declspec(dllexport) function_list[]; +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/ppport.h b/Master/tlpkg/tlperl0/lib/Imager/include/ppport.h new file mode 100755 index 00000000000..437df5c1b9b --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/ppport.h @@ -0,0 +1,4954 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.06_01 + + Automatically created by Devel::PPPort running under + perl 5.008008 on Tue Jul 4 22:01:23 2006. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.06_01 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.9.3. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +up to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions that were not present in earlier +versions of Perl, and that can't be provided using a macro, you have +to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions will be marked C<explicit> in the list shown by +C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions, you want either C<static> or global variants. + +For a C<static> function, use: + + #define NEED_function + +For a global function, use: + + #define NEED_function_GLOBAL + +Note that you mustn't have more than one global request for one +function in your project. + + Function Static Request Global Request + ----------------------------------------------------------------------------------------- + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions using the C<DPPP_NAMESPACE> macro. +Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +usage() if $opt{help}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +# Never use C comments in this file!!!!! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeVAL||5.004000| +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NEWSV||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newc||| +Newz||| +New||| +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERL_BCDVERSION|5.009003||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.007002||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.007002||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SUBVERSION|5.006000||p +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_DECL|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||n +PL_Sv|5.005000||p +PL_compiling|5.004050||p +PL_copline|5.005000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_last_in_gv|||n +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofs_sv|||n +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +ST||| +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set||5.009003| +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX||| +SvPV_force_nomg|5.007002||p +SvPV_force||| +SvPV_nolen|5.006000||p +SvPV_nomg|5.007002||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc||| +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set||5.009003| +SvRV||| +SvSETMAGIC||| +SvSHARE||5.007003| +SvSTASH_set||5.009003| +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK||5.007001| +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set||5.009003| +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +THIS|||n +UNDERBAR|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN||| +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data||| +allocmy||| +amagic_call||| +any_dup||| +ao||| +append_elem||| +append_list||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +asIV||| +asUV||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fake||| +av_fetch||| +av_fill||| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_xsutils||| +bytes_from_utf8||5.007001| +bytes_to_utf8||5.006001| +cache_re||| +call_argv|5.006000||p +call_atexit||5.006000| +call_body||| +call_list_body||| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_uni||| +checkcomma||| +checkposixcc||| +ck_anoncode||| +ck_bitop||| +ck_concat||| +ck_defined||| +ck_delete||| +ck_die||| +ck_eof||| +ck_eval||| +ck_exec||| +ck_exists||| +ck_exit||| +ck_ftst||| +ck_fun||| +ck_glob||| +ck_grep||| +ck_index||| +ck_join||| +ck_lengthconst||| +ck_lfun||| +ck_listiob||| +ck_match||| +ck_method||| +ck_null||| +ck_open||| +ck_repeat||| +ck_require||| +ck_retarget||| +ck_return||| +ck_rfun||| +ck_rvconst||| +ck_sassign||| +ck_select||| +ck_shift||| +ck_sort||| +ck_spair||| +ck_split||| +ck_subr||| +ck_substr||| +ck_svconst||| +ck_trunc||| +ck_unpack||| +cl_and||| +cl_anything||| +cl_init_zero||| +cl_init||| +cl_is_anything||| +cl_or||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +croak_nocontext|||vn +croak|||v +csighandler||5.007001|n +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK||5.009003| +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +deb||5.007003|v +del_he||| +del_sv||| +delimcpy||5.004000| +depcom||| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pipe||| +do_pmop_dump||5.006000| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch_body||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptosub||| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_eaccess||| +eval_pv|5.006000||p +eval_sv|5.006000||p +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +fd_on_nosuid_fs||| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_beginning||| +find_byclass||| +find_in_my_stash||| +find_runcv||| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_av|5.006000||p +get_context||5.006000|n +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_autoload4||5.004000| +gv_check||| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags||5.009002| +gv_fetchpv||| +gv_fetchsv||5.009002| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_share||| +gv_stashpvn|5.006000||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hek_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.009001| +hv_auxinit||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_common||| +hv_fetch_ent||5.004000| +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_ksplit||5.004000| +hv_magic_check||| +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incl_perldb||| +incline||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_lexer||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUM||| +isALPHA||| +isDIGIT||| +isLOWER||| +isSPACE||| +isUPPER||| +is_an_int||| +is_gv_magical_sv||| +is_gv_magical||| +is_handle_constructor||| +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char_slow||| +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +listkids||| +list||| +load_module_nocontext|||vn +load_module||5.006000|v +localize||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHu|5.009002||p +magic_clear_all_env||| +magic_clearenv||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_freeregexp||| +magic_getarylen||| +magic_getdefelem||| +magic_getglob||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setbm||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_setfm||| +magic_setglob||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +magicname||| +make_trie||| +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +moreswitches||| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_socketpair||5.007003|n +my_stat||| +my_strftime||5.007002| +my_swabn|||n +my_swap||| +my_unexec||| +my||| +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.006000||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMYSUB||5.006000| +newNULLLIST||| +newOP||| +newPADOP||5.006000| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.006000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_share||5.007001| +newSVpvn|5.006000||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newUNOP||| +newWHILEOP||5.009003| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +oopsAV||| +oopsCV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_null||5.007002| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +path_is_absolute||| +peep||| +pending_ident||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pmflag||| +pmop_dump||5.006000| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||| +pregexec||| +pregfree||| +prepend_elem||| +printf_nocontext|||vn +ptr_table_clear||| +ptr_table_fetch||| +ptr_table_free||| +ptr_table_new||| +ptr_table_split||| +ptr_table_store||| +push_scope||| +put_byte||| +pv_display||5.006000| +pv_uni_display||5.007003| +qerror||| +re_croak2||| +re_dup||| +re_intuit_start||5.006000| +re_intuit_string||5.006000| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +refkids||| +refto||| +ref||| +reg_node||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.007003| +regclass||| +regcp_set_to||| +regcppop||| +regcppush||| +regcurly||| +regdump||5.005000| +regexec_flags||5.005000| +reghop3||| +reghopmaybe3||| +reghopmaybe||| +reghop||| +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regoptail||| +regpiece||| +regpposixcc||| +regprop||| +regrepeat_hard||| +regrepeat||| +regtail||| +regtry||| +reguni||| +regwhite||| +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_errno||| +require_pv||5.006000| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +runops_debug||5.005000| +runops_standard||5.005000| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags||| +save_helem||5.004050| +save_hints||5.005000| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv||5.007001| +save_pptr||| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_threadsv||5.005000| +save_vptr||5.006000| +savepvn||| +savepv||| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type||| +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.008001| +scan_word||| +scope||| +screaminstr||5.005000| +seed||| +set_context||5.006000|n +set_csh||| +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +setenv_getix||| +share_hek_flags||| +share_hek||| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace||| +sortsv||5.007003| +ss_dup||| +stack_grow||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.009003| +stdize_locale||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2nv||| +sv_2pv_flags||5.007002| +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen||| +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.006000||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.006000||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.006000||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_dump||| +sv_dup||| +sv_eq||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_inc||| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_len_utf8||5.006000| +sv_len||| +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||5.007003| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u||5.006000| +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags||5.007002| +sv_pvn_force|||p +sv_pvn_nomg|5.007003||p +sv_pvn|5.006000||p +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_release_IVX||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.006000||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.006000||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.006000||p +sv_setpvn||| +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.006000||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.006000||p +sv_setuv|5.006000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_mg|5.006000||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.006000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +svtype||| +swallow_bom||| +swash_fetch||5.007002| +swash_init||5.006000| +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +upg_version||5.009000| +usage||| +utf16_textfilter||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf16rev_textfilter||| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_init||| +utf8_mg_pos||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||5.007001| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||5.007001| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdie||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module||5.006000| +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner||5.006000|v +warn|||v +watch||| +whichsig||| +write_to_stderr||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %depends); +my $replace = 0; +my $hint = ''; + +while (<DATA>) { + if ($hint) { + if (m{^\s*\*\s(.*?)\s*$}) { + $hints{$hint} ||= ''; # suppress warning with older perls + $hints{$hint} .= "$1\n"; + } + else { + $hint = ''; + } + } + $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "$hints{$f}" if exists $hints{$f}; + $info++; + } + unless ($info) { + print "No portability information available.\n"; + } + $count++; + } + if ($count > 0) { + print "\n"; + } + else { + print "Found no API matching '$opt{'api-info'}'.\n"; + } + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( xs c h cc cpp ); +my $srcext = join '|', @srcext; + +if (@ARGV) { + my %seen; + @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV; +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /\.($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*.$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +unless (@files) { + die "No input files given!\n"; +} + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # temporarily remove C comments from the code + my @ccom; + $c =~ s{ + ( + [^"'/]+ + | + (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ + | + (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ + ) + | + (/ (?: + \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / + | + /[^\r\n]* + )) + }{ + defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce"; + }egsx; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + if (exists $need{$_}) { + $file{needs}{$_} = 'static'; + } + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { + warning("Possibly wrong #define $1 in $filename"); + } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses}}) { + next unless $file{uses}{$func}; # if it's only a dependency + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + elsif (exists $replace{$func}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + else { + diag("Uses $func"); + } + hint($func); + } + + for $func (sort keys %{$file{uses_todo}}) { + warning("Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo})); + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and can_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; + +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub can_use +{ + eval "use @_;"; + return $@ eq ''; +} + +sub rec_depend +{ + my $func = shift; + my %seen; + return () unless exists $depends{$func}; + grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +sub hint +{ + $opt{quiet} and return; + $opt{hints} or return; + my $func = shift; + exists $hints{$func} or return; + $given_hints{$func}++ and return; + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif + +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif + +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) +/* Replace: 1 */ +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_Sv Sv +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_na na +# define PL_no_modify no_modify +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_ppaddr ppaddr +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +/* Replace: 0 */ +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif +#ifndef NOOP +# define NOOP (void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR + +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif + +# define NUM2PTR(any,d) (any)(PTRV)(d) +# define PTR2IV(p) INT2PTR(IV,p) +# define PTR2UV(p) INT2PTR(UV,p) +# define PTR2NV(p) NUM2PTR(NV,p) + +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif + +#endif /* !INT2PTR */ + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#undef STMT_START +#undef STMT_END +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) +#endif + +#endif +#ifndef Poison +# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) +#endif +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) +#endif +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ + +/* Replace perl_eval_pv with eval_pv */ +/* eval_pv depends on eval_sv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +void +DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) + start_subparse(), +#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvPV_nolen + +#if defined(NEED_sv_2pv_nolen) +static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +static +#else +extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); +#endif + +#ifdef sv_2pv_nolen +# undef sv_2pv_nolen +#endif +#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) +#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) + +#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) + +char * +DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) +{ + STRLEN n_a; + return sv_2pv(sv, &n_a); +} + +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). + */ + +/* SvPV_nolen depends on sv_2pv_nolen */ +#define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_nolen(sv)) + +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +/* SvPVbyte depends on sv_2pvbyte */ +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif + +/* sv_2pvbyte_nolen depends on sv_2pv_nolen */ +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen sv_2pv_nolen +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ +#ifndef sv_pvn +# define sv_pvn(sv, len) SvPV(sv, len) +#endif + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ +#ifndef sv_pvn_force +# define sv_pvn_force(sv, len) SvPV_force(sv, len) +#endif + +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +/* sv_vcatpvf depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_vsetpvf depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +/* sv_vcatpvf_mg depends on sv_vcatpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ +#ifdef PERL_IMPLICIT_CONTEXT +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +/* sv_vsetpvf_mg depends on sv_vsetpvfn */ +#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef SvPV_force_nomg +# define SvPV_force_nomg SvPV_force +#endif + +#ifndef SvPV_nomg +# define SvPV_nomg SvPV +#endif + +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif + +/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif /* PERL_VERSION */ +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +/* grok_number depends on grok_numeric_radix */ + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimiser friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimiser could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimiser not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/regmach.h b/Master/tlpkg/tlperl0/lib/Imager/include/regmach.h new file mode 100755 index 00000000000..ed1e30374ab --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/regmach.h @@ -0,0 +1,89 @@ +#ifndef _REGMACH_H_ +#define _REGMACH_H_ + +#include <stdio.h> +#include <math.h> +#include "imager.h" + +enum rm_byte_codes { + rbc_add, /* ra + rb -> r*/ + rbc_subtract, /* ra - rb -> r */ + rbc_mult, /* ra * rb -> r */ + rbc_div, /* ra / rb -> r */ + rbc_mod, /* ra % rb -> r */ + rbc_pow, /* ra ** rb -> r */ + rbc_uminus, /* -ra -> r */ + rbc_multp, /* pa ** rb -> p */ + rbc_addp, /* pa + pb -> p */ + rbc_subtractp, /* pa - pb -> p */ + /* rbcParm, we just preload a register */ + rbc_sin, /* sin(ra) -> r */ + rbc_cos, /* cos(ra) -> r */ + rbc_atan2, /* atan2(ra,rb) -> r */ + rbc_sqrt, /* sqrt(ra) -> r */ + rbc_distance, /* distance(rx, ry, rx, ry) -> r */ + /* getp? codes must be in order */ + rbc_getp1, /* getp1(ra, rb) -> p */ + rbc_getp2, /* getp2(ra, rb) -> p */ + rbc_getp3, /* getp3(ra, rb) -> p */ + rbc_value, /* value(pa) -> r */ + rbc_hue, /* hue(pa) -> r */ + rbc_sat, /* sat(pa) -> r */ + rbc_hsv, /* hsv(rh, rs, rv) -> p */ + rbc_red, /* red(pa) -> r */ + rbc_green, /* green(pa) -> r */ + rbc_blue, /* blue(pa) -> r */ + rbc_rgb, /* rgb(rr, rg, rb) -> p */ + rbc_int, /* int(ra) -> r */ + rbc_if, /* if(rc, rt, rf) -> r */ + rbc_ifp, /* if(rc, pt, pf) -> p */ + rbc_le, /* ra <= rb -> r */ + rbc_lt, /* ra < rb -> r */ + rbc_ge, /* ra >= rb -> r */ + rbc_gt, /* ra > rb -> r */ + rbc_eq, /* ra == rb -> r -- does approx equal */ + rbc_ne, /* ra != rb -> r -- does approx equal */ + rbc_and, /* ra && rb -> r */ + rbc_or, /* ra || rb -> r */ + rbc_not, /* !ra -> r */ + rbc_abs, /* abs(ra) -> r */ + rbc_ret, /* returns pa */ + rbc_jump, /* jump to ja */ + rbc_jumpz, /* jump if ra == 0 to jb */ + rbc_jumpnz, /* jump if ra != 0 to jb */ + rbc_set, /* ra -> r */ + rbc_setp, /* pa -> p*/ + rbc_print, /* print(ra) -> r -- prints, leaves on stack */ + rbc_rgba, /* rgba(ra, rb, rc, rd) -> p */ + rbc_hsva, /* hsva(ra, rb, rc, rd) -> p */ + rbc_alpha, /* alpha(pa) -> r */ + rbc_log, /* log(ra) -> r */ + rbc_exp, /* exp(ra) -> r */ + rbc_det, /* det(ra, rb, rc, rd) -> r */ + rbc_op_count +}; + +/* rm_word was originally char, but even for some simpler expressions + I was getting close to running out of register numbers. + It should also simplify structure alignment issues. (I hope.) +*/ +typedef int rm_word; +#define RM_WORD_PACK "i" + +struct rm_op { + rm_word code; /* op code */ + rm_word ra; /* first operand */ + rm_word rb; /* possible second operand */ + rm_word rc; /* possible third operand */ + rm_word rd; /* possible fourth operand */ + rm_word rout; /* output register */ +}; + +i_color i_rm_run(struct rm_op codes[], size_t code_count, + double n_regs[], size_t n_regs_count, + i_color c_regs[], size_t c_regs_count, + i_img *images[], size_t image_count); + +/* op_run(fx, sizeof(fx), parms, 2)) */ + +#endif /* _REGMACH_H_ */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/rendert.h b/Master/tlpkg/tlperl0/lib/Imager/include/rendert.h new file mode 100755 index 00000000000..2eb79a25676 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/rendert.h @@ -0,0 +1,17 @@ +#ifndef IMAGER_RENDERT_H +#define IMAGER_RENDERT_H + +typedef struct { + int magic; + i_img *im; + + int line_width; + i_color *line_8; + i_fcolor *line_double; + + int fill_width; + i_color *fill_line_8; + i_fcolor *fill_line_double; +} i_render; + +#endif diff --git a/Master/tlpkg/tlperl0/lib/Imager/include/stackmach.h b/Master/tlpkg/tlperl0/lib/Imager/include/stackmach.h new file mode 100755 index 00000000000..d70572b227e --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/include/stackmach.h @@ -0,0 +1,25 @@ +#ifndef _STACKMACH_H_ +#define _STACKMACH_H_ + +#include <stdio.h> +#include <math.h> + +enum ByteCodes { + bcAdd, + bcSubtract, + bcMult, + bcDiv, + bcParm, + bcSin, + bcCos +}; + +double i_op_run(int codes[], size_t code_size, double parms[], size_t parm_size); + +/* op_run(fx, sizeof(fx), parms, 2)) */ + + + + + +#endif /* _STACKMACH_H_ */ diff --git a/Master/tlpkg/tlperl0/lib/Imager/interface.pod b/Master/tlpkg/tlperl0/lib/Imager/interface.pod new file mode 100755 index 00000000000..580e6e5fc8a --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/interface.pod @@ -0,0 +1,343 @@ +=head1 NAME + +Imager::interface.pod - decribes the C level virtual image interface + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +The Imager virtual interface aims to allow image types to be created +for special purposes, both to allow consistent access to images with +different sample sizes, and organizations, but also to allow creation +of synthesized or virtual images. + +This is a C level interface rather than Perl. + +=head2 Existing Images + +As of this writing we have the following concrete image types: + +=over + +=item * + +8-bit/sample direct images + +=item * + +16-bit/sample direct images + +=item * + +double/sample direct images + +=item * + +8-bit/sample 8-bit/index paletted images + +=back + +Currently there is only one virtual image type: + +=over + +=item * + +masked images, where a mask image can control write access to an +underlying image. + +=back + +Other possible concrete images include: + +=over + +=item * + +"bitmaps", 1 bit/sample images (perhaps limited to a single channel) + +=item * + +16-bit/index paletted images + +=back + +Some other possible virtual images: + +=over + +=item * + +image alpha combining, where the combining function can be specified +(see the layer modes in graphical editors like the GIMP or photoshop. + +=back + +=head1 THE INTERFACE + +Each image type needs to define a number of functions which implement +the image operations. + +The image structure includes information describes the image, which +can be used to determine the structure of the image: + +=over + +=item channels + +the number of samples kept for each pixel in the image. For paletted +images the samples are kept for each entry in the palette. + +=item xsize, ysize + +the dimensions of the image in pixels. + +=item bytes + +the number of bytes of data kept for the image. Zero for virtual +images. Does not include the space required for the palette for +paletted images. + +=item ch_mask + +controls which samples will be written to for direct images. + +=item bits + +the number of bits kept for each sample. There are enum values +i_8_bits, i_16_bits and i_double_bits (64). + +=item type + +the type of image, either i_direct_type or i_palette_type. Direct +images keep the samples for every pixel image, while i_palette_type +images keep an index into a color table for each pixel. + +=item virtual + +whether the image keeps any pixel data. If this is non-zero then +idata points to image data, otherwise it points to implementation +defined data, though ext_data is more likely to be used for that. + +=item idata + +image data. If the image is 8-bit direct, non-virtual, then this +consists of each sample of the image stored one after another, +otherwise it is implementation defined. + +=item tags + +will be used to store meta-data for an image, eg. tags from a TIFF +file, or animation information from a GIF file. This should be +initialized with a call to i_tags_new() in your image constructor if +creating a new image type. + +=item ext_data + +for internal use of image types. This is not released by the standard +i_img_exorcise() function. If you create a new image type and want to +store a pointer to allocated memory here you should point i_f_destroy +at a function that will release the data. + +=back + +If a caller has no knowledge of the internal format of an image, the +caller must call the appropriate image function pointer. Imager +provides macros that wrap these functions, so it isn't necessary to +call them directly. + +Many functions have a similar function with an 'f' suffix, these take +or return samples specified with floating point values rather than +8-bit integers (unsigned char). Floating point samples are returned +in the range 0 to 1 inclusive. + +=over + +=item i_f_ppix(im, x, y, color) + +=item i_f_ppixf(im, x, y, fcolor) + +stores the specified color at pixel (x,y) in the image. If the pixel +can be stored return 0, otherwise -1. An image type may choose to +return 0 under some circumstances, eg. writing to a masked area of an +image. The color or fcolor always contains the actual samples to be +written, rather than a palette index. + +=item i_f_plin(im, l, r, y, colors) + +=item i_f_plinf(im, l, r, y, fcolors) + +stores (r-l) pixels at positions (l,y) ... (r-1, y) from the array +specified by colors (or fcolors). Returns the number of pixels +written to. If l is negative it will return 0. If r > im->xsize then +only (im->xsize - l) will be written. + +=item i_f_gpix(im, x, y, color) + +=item i_f_gpixf(im, x, y, fcolor) + +retrieves a single pixel from position (x,y). This returns the +samples rather than the index for paletted images. + +=item i_f_glin(im, l, r, y, colors) + +=item i_f_glinf(im, l, r, y, fcolors) + +retrieves (r-l) pixels from positions (l, y) through (r-1, y) into the +array specified by colors. Returns the number of pixels retrieved. +If l < 0 no pixels are retrieved. If r > im->xsize then pixels (l, y) +... (im->xsize-1, y) are retrieved. Retrieves the samples rather than +the color indexes for paletted images. + +=item i_f_gsamp(im, l, r, y, samples, chans, chan_count) + +=item i_f_gsampf(im, l, r, y, fsamples, chans, chan_count) + +Retrieves samples from channels specified by chans (for length +chan_count) from pixels at positions (l,y) ... (r-1, y). If chans is +NULL then samples from channels 0 ... chan_count-1 will be retrieved. +Returns the number of sample retrieved (_not_ the number of channels). +If a channel in chans is not present in the image or l < 0, returns 0. +If r > im->xsize, then the samples from (l,y) ... (im->xsize-1, y) are +returned. + +=back + +The following are for images where type == i_palette_type only. + +=over + +=item i_f_gpal(im, l, r, y, vals) + +Retrieves color indexes from the image for pixels (l, y) ... (r-1, y) +into vals. Returns the number of indexes retrieved. + +=item i_f_ppal(im, l, r, y, vals) + +Stores color indexes into the image for pixels (l, y) ... (r-1, y) +from vals. Returns the number of indexes retrieved. If indices are +outside the range of the images palette, then you may have problems +reading those pixels with i_gpix() or i_glin(). + +=item i_f_addcolors(im, colors, count) + +Adds the count colors to the image's palette. Returns the index of +the first color added, or -1 if there is not enough space for count +colors. + +=item i_f_getcolors(im, index, colors, count) + +Retrieves count colors from the image's palette starting from entry +index in the palette. Returns non-zero on success. + +=item i_f_colorcount(im) + +Returns the number of colors in the image's palette. Returns -1 if +this is not a paletted image. + +=item i_f_maxcolors(im) + +Returns the maximum number of colors that can fit in the image's +palette. Returns -1 if this is not a paletted image. + +=item i_f_findcolor(im, color, entry) + +Searches the image's palette for the specified color, setting *entry +to the index and returning non-zero. Returns zero if the color is not +found. + +=item i_f_setcolors_t(im, index, colors, count) + +Sets count colors starting from index in the image from the array +colors. The colors to be set must already have entries in the image's +palette. Returns non-zero on success. + +=back + +Finally, the i_f_destroy function pointer can be set which is called +when the image is destroyed. This can be used to release memory +pointed to by ext_data or release any other resources. + +When writing to a paletted image with i_ppix() or i_plin() and the +color you are writing doesn't exist in the image, then it's possible +that the image will be internally converted to a direct image with the +same number of channels. + +=head1 TOOLS + +Several functions have been written to simplify creating new image types. + +These tools are available by including imagei.h. + +=head2 Floating point wrappers + +These functions implement the floating point sample versions of each +interface function in terms of the integer sample version. + +These are: + +=over + +=item i_ppixf_fp + +=item i_gpixf_fp + +=item i_plinf_fp + +=item i_glinf_fp + +=item i_gsampf_fp + +=back + + +=head2 Forwarding functions + +These functions are used in virtual images where the call should +simply be forwarded to the underlying image. The underlying image is +assumed to be the first pointer in a structure pointed at by ext_data. + +If this is not the case then these functions will just crash :) + +=over + +=item i_addcolors_forward + +=item i_getcolors_forward + +=item i_colorcount_forward + +=item i_maxcolors_forward + +=item i_findcolor_forward + +=item i_setcolors_forward + +=back + +=head2 Sample macros + +Imagei.h defines several macros for converting samples between +different sizes. + +Each macro is of the form SampleI<size>ToI<size> where I<size> is one +of 8, 16, or F (for floating-point samples). + +=over + +=item SampleFTo16(sample) + +=item Sample16ToF(sample) + +=item SampleFTo8(sample) + +=item Sample8ToF(sample) + +=item Sample16To8(num) + +=item Sample8To16(num) + +=back + +=cut diff --git a/Master/tlpkg/tlperl0/lib/Imager/regmach.pod b/Master/tlpkg/tlperl0/lib/Imager/regmach.pod new file mode 100755 index 00000000000..844742d6d8a --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/regmach.pod @@ -0,0 +1,103 @@ +=head1 NAME + +Imager::regmach - documents the register virtual machine used by +Imager::transform2(). + +=head1 SYNOPSIS + +The register machine is a complete rewrite of the stack machine +orginally used by Imager::transform(), written for use by +Imager::transform2(). + +=head1 DESCRIPTION + +(This document might be a little incoherent.) + +The register machine is a fast implementation of a small instruction +set designed for evaluating an arithmetic expression to produce a +colour for an image. + +The machine takes as input: + +=over 4 + +=item instructions + +An array of instructions + +=item numeric registers + +An array of numeric registers. Some registers are initialized as +literals. + +=item colour registers + +An array of colour registers. Currently these registers aren't +initialized. + +=item input images + +An array of Imager i_img pointers. The getpn operators read pixels +from these images. + +=back + +The instructions supplied each take up to 4 input numeric or colour +registers with a single output numeric or colour register. The +machine attempts to execute instructions as safely as possible, +assuming that correct instructions have been provided, eg. the machine +protects against divide by zero, but doesn't check register numbers +for validity. + +The final instruction must be a 'ret' instruction, which returns the +result ;) + +=head2 Adding new instructions + +To add a new instruction: + +=over 4 + +=item 1 + +Add a new opcode to the enumeration in regmach.h - make sure to add +comment after the enum name giving the input registers (rX for +numeric, pX for colour) that the instruction takes. These must be in +the order that the instruction expects to take the. Put a letter (r +or p) after -> to indicate the result type. + +=item 2 + +Add a case to regmach.c that executes the instruction. + +=item 3 + +make + +=back + +The makefile should rebuild the Regops.pm file, and your new +instruction will be added as a function. + +If you want to add a single alternative instruction that might take +different argument types (it must take the same number of parameters), +create another instruction with that name followed by a p. The +current expression parsers explicitly look for such instruction names. + +=head2 Future directions + +Conditional and non-conditional jumps to implement iteration. This +will break the current optimizer in L<Imager::Expr> (and the compilers +for both expression compilers, for that matter.) + +Complex arithmetic (Addi suggested this one). This would most likely +be a separate machine. Otherwise we'll have a very significant +performance loss. + +=head1 WARNINGS + +If you feed bad 'machine code' to the register machine, you have a +good chance of a SIGSEGV. + +=cut + diff --git a/Master/tlpkg/tlperl0/lib/Imager/typemap b/Master/tlpkg/tlperl0/lib/Imager/typemap new file mode 100755 index 00000000000..4438d086a17 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Imager/typemap @@ -0,0 +1,118 @@ +#i_img * T_PTR_NULL +Imager::Color T_PTROBJ +Imager::Color::Float T_PTROBJ +Imager::ImgRaw T_IMAGER_IMAGE +Imager::Font::TT T_PTROBJ +Imager::IO T_PTROBJ +Imager::Font::FT2 T_PTROBJ +Imager::FillHandle T_PTROBJ +Imager::Internal::Hlines T_PTROBJ +const char * T_PV +float T_FLOAT +float* T_ARRAY +undef_int T_IV_U +undef_neg_int T_IV_NEGU +HASH T_HVREF +utf8_str T_UTF8_STR + +# these types are for use by Inline, which can't handle types containing :: +Imager__Color T_PTROBJ_INV +Imager__Color__Float T_PTROBJ_INV +Imager__ImgRaw T_IMAGER_IMAGE +Imager__FillHandle T_PTROBJ_INV +Imager__IO T_PTROBJ_INV + +# mostly intended for non-Imager-core use +Imager T_IMAGER_FULL_IMAGE + +############################################################################# +INPUT +T_PTR_NULL + if (SvOK($arg)) $var = INT2PTR($type,SvIV($arg)); + else $var = NULL + +# the pre-5.8.0 T_AVREF input map was fixed in 5.8.0 +T_AVREF + if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV) + $var = (AV*)SvRV($arg); + else + Perl_croak(aTHX_ \"$var is not an array reference\") + +# handles Imager objects rather than just raw objects +T_IMAGER_IMAGE + if (sv_derived_from($arg, \"Imager::ImgRaw\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else if (sv_derived_from($arg, \"Imager\") && + SvTYPE(SvRV($arg)) == SVt_PVHV) { + HV *hv = (HV *)SvRV($arg); + SV **sv = hv_fetch(hv, \"IMG\", 3, 0); + if (sv && *sv && sv_derived_from(*sv, \"Imager::ImgRaw\")) { + IV tmp = SvIV((SV*)SvRV(*sv)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type Imager::ImgRaw\"); + } + else + Perl_croak(aTHX_ \"$var is not of type Imager::ImgRaw\"); + +T_IMAGER_FULL_IMAGE + if (sv_derived_from($arg, \"Imager\") && + SvTYPE(SvRV($arg)) == SVt_PVHV) { + HV *hv = (HV *)SvRV($arg); + SV **sv = hv_fetch(hv, \"IMG\", 3, 0); + if (sv && *sv && sv_derived_from(*sv, \"Imager::ImgRaw\")) { + IV tmp = SvIV((SV*)SvRV(*sv)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak(aTHX_ \"$var is not of type Imager::ImgRaw\"); + } + else + Perl_croak(aTHX_ \"$var is not of type Imager\"); + +# same as T_PTROBJ, but replace __ with ::, the opposite of the way +# xsubpp's processing works +# this is to compensate for Inline's problem with type names containing :: +T_PTROBJ_INV + if (sv_derived_from($arg, \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not of type ${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\"); + + +############################################################################# +OUTPUT +T_IV_U + if ($var == 0) $arg=&PL_sv_undef; + else sv_setiv($arg, (IV)$var); +T_IV_NEGU + if ($var < 0) $arg=&PL_sv_undef; + else sv_setiv($arg, (IV)$var); +T_PTR_NULL + sv_setiv($arg, (IV)$var); + +# same as T_PTROBJ +T_IMAGER_IMAGE + sv_setref_pv($arg, \"Imager::ImgRaw\", (void*)$var); + +T_PTROBJ_INV + sv_setref_pv($arg, \"${(my $ntt=$ntype)=~s/__/::/g;\$ntt}\", (void*)$var); + +# ugh, the things we do for ease of use +# this isn't suitable in some cases +T_IMAGER_FULL_IMAGE + if ($var) { + SV *imobj = NEWSV(0, 0); + HV *hv = newHV(); + sv_setref_pv(imobj, \"Imager::ImgRaw\", $var); + hv_store(hv, "IMG", 3, imobj, 0); + $arg = sv_2mortal(sv_bless(newRV_noinc((SV*)hv), gv_stashpv("Imager", 1))); + } + else { + $arg = &PL_sv_undef; + } |